aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/Zinc/Debug.pm905
1 files changed, 681 insertions, 224 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index be2b298..a4fbde5 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -8,7 +8,6 @@
#---------------------------------------------------------------------------
package ZincDebug;
-
use strict 'vars';
use vars qw(@ISA @EXPORT);
use Carp;
@@ -18,96 +17,480 @@ use Tk::Zinc;
use Tk::LabFrame;
use Tk::Pane;
use Tk::Dialog;
+use Tk::Tree;
@ISA = qw(Exporter);
-@EXPORT = qw(finditems);
+@EXPORT = qw(finditems snapshot tree);
-my ($help_tl0, $help_tl, $result_tl, $result_fm, $showitemflag);
+my ($help_tl0, $help_tl, $result_tl, $result_fm, $search_tl, $showitemflag);
my ($text_id, $rectangle_id);
my ($x0, $y0);
my ($help_print, $imagecounter, $saving) = (0,0);
-
+my $searchEntryValue;
+my $tree_tl;
my $zinc;
+my $enclosedModBtn;
+my $overlapModBtn;
+my $treeModBtn;
+my $searchKey;
+my $snapKey;
+my $treeKey;
+my $tree;
+my @keys;
+my @seq;
+
+sub tree {
+
+ &setwidget(shift);
+ return unless $zinc;
+ # options
+ my %options = @_;
+ for my $opt (keys(%options)) {
+ carp "in ZincDebug module, tree() function, unknown option $opt\n"
+ unless ($opt eq '-itemModBtn' or $opt eq '-key');
+ }
+ $treeKey = ($options{-key}) ? $options{-key} : 'Control-t';
+ $treeModBtn = ($options{-itemModBtn}) ? $options{-itemModBtn} : ['Control', 2];
+ return unless &compatseq($treeModBtn);
+ return unless &compatkey($treeKey);
+ #
+ # binding for help screen
+ #
+ $zinc->toplevel->Tk::bind('<Key-Escape>', \&showhelp);
+ #
+ # binding for building tree
+ #
+ $zinc->toplevel->Tk::bind('<'.$treeKey.'>', \&showtree);
+ #
+ # binding for displaying item in tree
+ #
+ my $tkb = $treeModBtn;
+ $zinc->Tk::bind('<'.$tkb->[0]."-".$tkb->[1].'>', \&findintree);
+
+} # end tree
sub finditems {
- $zinc = shift;
+
+ &setwidget(shift);
+ return unless $zinc;
# options
my %options = @_;
for my $opt (keys(%options)) {
- carp "in ZincDebug module, finditems function, unknown option $opt\n"
+ carp "in ZincDebug module, finditems() function, unknown option $opt\n"
unless ($opt eq '-color' or $opt eq '-enclosedModBtn' or
- $opt eq '-overlapModBtn' or $opt eq '-snapshotModBtn' or
- $opt eq '-snapshotVerbosity' or $opt eq '-snapshotBasename' );
+ $opt eq '-overlapModBtn' or $opt eq '-searchKey');
}
my $color = ($options{-color}) ? $options{-color} : 'sienna';
- my $ekb = ($options{-enclosedModBtn}) ? $options{-enclosedModBtn} : ['Control', 3];
- my $okb = ($options{-overlapModBtn}) ? $options{-overlapModBtn} : ['Shift', 3];
- my $pkb = ($options{-printModBtn}) ? $options{-printModBtn} : ['Control-Shift', 2];
- my $snapshotVerbosity = (defined $options{-snapshotVerbosity}) ?
- $options{-snapshotVerbosity} : 1;
- my $snapshotBasename = ($options{-snapshotBasename}) ?
- $options{-snapshotBasename} : "zincsnapshot";
- carp "in ZincDebug module, finditems function, enclosed search and ".
- "zinc snapshot won't work because ".
- "two of them use the same sequence.\n" .
- "enclose : [$ekb->[0], $ekb->[1]]\n" .
- "overlap [$okb->[0], $okb->[1]]\n" .
- "snapshot [$pkb->[0], $pkb->[1]]\n"
-
- if
- ($ekb->[0] eq $okb->[0] and $ekb->[1] eq $okb->[1]) or
- ($pkb->[0] eq $okb->[0] and $pkb->[1] eq $okb->[1]) or
- ($pkb->[0] eq $ekb->[0] and $pkb->[1] eq $ekb->[1]) ;
+ $enclosedModBtn = ($options{-enclosedModBtn}) ? $options{-enclosedModBtn} :
+ ['Control', 3];
+ $overlapModBtn = ($options{-overlapModBtn}) ? $options{-overlapModBtn} :
+ ['Shift', 3];
+ $searchKey = ($options{-searchKey}) ? $options{-searchKey} : 'Control-f';
+ return unless &compatseq($enclosedModBtn, $overlapModBtn);
+ return unless &compatkey($searchKey);
#
# binding for help screen
#
- $zinc->toplevel->Tk::bind('<Key-Escape>', [\&showhelp, $ekb, $okb, $pkb]);
+ $zinc->toplevel->Tk::bind('<Key-Escape>', \&showhelp);
#
# bindings for Enclosed search
#
- $zinc->Tk::bind("<".$ekb->[0]."-".$ekb->[1].">",
+ my $ekb = $enclosedModBtn;
+ $zinc->Tk::bind('all', "<".$ekb->[0]."-".$ekb->[1].">",
[\&startrectangle, 'simple', 'Enclosed', $color]);
- $zinc->Tk::bind("<".$ekb->[0]."-B".$ekb->[1]."-Motion>", \&resizerectangle);
- $zinc->Tk::bind("<".$ekb->[0]."-B".$ekb->[1]."-ButtonRelease>",
+ $zinc->Tk::bind('all', "<".$ekb->[0]."-B".$ekb->[1]."-Motion>", \&resizerectangle);
+ $zinc->Tk::bind('all', "<".$ekb->[0]."-B".$ekb->[1]."-ButtonRelease>",
[\&stoprectangle, 'enclosed', 'Enclosed search']);
#
# bindings for Overlap search
#
- $zinc->Tk::bind("<".$okb->[0]."-".$okb->[1].">",
+ my $okb = $overlapModBtn;
+ $zinc->Tk::bind('all', "<".$okb->[0]."-".$okb->[1].">",
[\&startrectangle, 'mixed', 'Overlap', $color]);
- $zinc->Tk::bind("<".$okb->[0]."-B".$okb->[1]."-Motion>", \&resizerectangle);
- $zinc->Tk::bind("<".$okb->[0]."-B".$okb->[1]."-ButtonRelease>",
+ $zinc->Tk::bind('all', "<".$okb->[0]."-B".$okb->[1]."-Motion>", \&resizerectangle);
+ $zinc->Tk::bind('all', "<".$okb->[0]."-B".$okb->[1]."-ButtonRelease>",
[\&stoprectangle, 'overlapping', 'Overlap search']);
#
+ # binding for search entry
+ #
+ $zinc->toplevel->Tk::bind('<'.$searchKey.'>', \&searchentry);
+
+} # end finditems
+
+
+
+sub snapshot {
+
+ &setwidget(shift);
+ return unless $zinc;
+ # options
+ my %options = @_;
+ for my $opt (keys(%options)) {
+ carp "in ZincDebug module, snapshot() function, unknown option $opt\n"
+ unless ($opt eq '-key' or
+ $opt eq '-verbosity' or $opt eq '-basename');
+ }
+ $snapKey = ($options{-key}) ? $options{-key} : 'Control-s';
+ my $snapshotVerbosity = (defined $options{-verbosity}) ? $options{-verbosity} : 1;
+ my $snapshotBasename = ($options{-basename}) ? $options{-basename} : "zincsnapshot";
+ return unless &compatkey($snapKey);
+ #
+ # binding for help screen
+ #
+ $zinc->toplevel->Tk::bind('<Key-Escape>', \&showhelp);
+ #
# binding for printing a full zinc window
- $zinc->Tk::bind("<".$pkb->[0]."-B".$pkb->[1]."-ButtonRelease>",
- [\&printWindow , $snapshotBasename, $snapshotVerbosity]);
-}
+ #
+ $zinc->toplevel->Tk::bind("<".$snapKey.">",
+ [\&printWindow , $snapshotBasename, $snapshotVerbosity]);
+
+} # end snapshot
+
+
+#---------------------------------------------------------------------------
+#
+# TREE PRIVATE FUNCTIONS
+#
+#---------------------------------------------------------------------------
+sub findintree {
+ if (not $tree_tl) {
+ &showtree;
+ }
+ my $ev = $zinc->XEvent;
+ ($x0, $y0) = ($ev->x, $ev->y);
+ my @atomicgroups = &unsetAtomicity;
+ my $item = $zinc->find('closest', $x0, $y0);
+ &restoreAtomicity(@atomicgroups);
+ return unless $item > 1;
+ my @ancestors = reverse($zinc->find('ancestors', $item));
+ my $path = join('.', @ancestors).".".$item;
+ $tree->see($path);
+ $tree->selectionClear;
+ $tree->anchorSet($path);
+ $tree->selectionSet($path);
+ &surrounditem($zinc, $item);
+ $tree->focus;
+
+} # end findintree
+
+
+
+sub showtree {
+ $tree_tl->destroy if $tree_tl and Tk::Exists($search_tl);
+ $tree_tl = $zinc->Toplevel;
+ $tree_tl->title("Zinc Items Tree");
+ # help text
+ my $font = $zinc->cget(-font);
+ my $text = $tree_tl->Text(-height => 8,
+ -relief => 'flat',
+ -font => $font,
+ -wrap => 'word',
+ -foreground => 'gray30',
+ )->pack(-side => 'top');
+ $text->tagConfigure('keyword', -foreground => 'black');
+ $text->insert('end', "<Up>", "keyword");
+ $text->insert('end', " arrow key moves the anchor point to the item right on ".
+ "top of the current anchor item. ");
+ $text->insert('end', "<Down>", "keyword");
+ $text->insert('end', " arrow key moves the anchor point to the item right below ".
+ "the current anchor item. ");
+ $text->insert('end', "<Left>", "keyword");
+ $text->insert('end', " arrow key moves the anchor to the parent item of the ".
+ "current anchor item. ");
+ $text->insert('end', "<Right>", "keyword");
+ $text->insert('end', " moves the anchor to the first child of the current anchor ".
+ "item. If the current anchor item does not have any children, moves ".
+ "the anchor to the item right below the current anchor item.\n\n");
+ $text->insert('end', "<Click>", "keyword");
+ $text->insert('end', " or ");
+ $text->insert('end', "<Space>", "keyword");
+ $text->insert('end', " highlights corresponding Zinc item and ");
+ $text->insert('end', "<Double-Click>", "keyword");
+ $text->insert('end', " or ");
+ $text->insert('end', "<Return>", "keyword");
+ $text->insert('end', " displays item's features\n");
+
+ $tree = $tree_tl->Scrolled('Tree',
+ -scrollbars => 'se',
+ -height => 40,
+ -width => 50,
+ -itemtype => 'text',
+ -selectmode => 'single',
+ -separator => '.',
+ -drawbranch => 1,
+ -indent => 30,
+ -command => sub {
+ my $path = shift;
+ my $item = (split(/\./, $path))[-1];
+ $zinc->remove("zincdebug");
+ &showresult("", $zinc, $item);
+ },
+ );
+ $tree->configure(-browsecmd => sub { my $path = shift;
+ my $item = (split(/\./, $path))[-1];
+ &surrounditem($zinc, $item);
+ },
+ );
+
+ $tree->pack(-padx => 10, -pady => 10,
+ -ipadx => 10,
+ -fill => 'both',
+ -expand => 1,
+ );
+
+ $tree->add("1", -text => "Group(1)", -state => 'disabled');
+ &scangroup($tree, 1, "1",);
+ $tree->autosetmode;
+ $tree_tl->Button(-text => 'Close',
+ -command => sub {$zinc->remove("zincdebug");
+ $tree_tl->destroy},
+ )->pack(-side => 'top', -pady => 10);
+
+
+} # end showtree
+
+
+sub scangroup {
+ my ($tree, $group, $path) = @_;
+ my @items = $zinc->find('withtag', "$group.");
+
+ for my $item (@items) {
+ my $type = ucfirst($zinc->type($item));
+ my $priority = $zinc->itemcget($item, -priority);
+ $tree->add($path.".".$item, -text => "$type($item)");
+ if ($type eq "Group") {
+ &scangroup($tree, $item, $path.".".$item);
+ }
+ }
+
+} # end scangroup
+
+#---------------------------------------------------------------------------
+#
+# FIND PRIVATE FUNCTIONS
+#
+#---------------------------------------------------------------------------
+# begin to draw rectangular area for search
+sub startrectangle {
+ my ($widget, $style, $text, $color) = @_;
+ $zinc->remove($rectangle_id, $text_id);
+ my $ev = $zinc->XEvent;
+ ($x0, $y0) = ($ev->x, $ev->y);
+ $rectangle_id = $zinc->add('rectangle', 1, [$x0, $y0, $x0, $y0],
+ -linecolor => $color,
+ -linewidth => 2,
+ -linestyle => $style,
+ );
+ $text_id = $zinc->add('text', 1,
+ -color => $color,
+ -font => '7x13',
+ -position => [$x0+5, $y0-15],
+ -text => $text,
+ );
+
+} # end startrectangle
+
+
+# resize the rectangular area for search
+sub resizerectangle {
+ my $ev = $zinc->XEvent;
+ my ($x, $y) = ($ev->x, $ev->y);
+ return unless ($zinc->find('withtag', $rectangle_id));
+
+ $zinc->coords($rectangle_id, 1, 1, [$x, $y]);
+ if ($x < $x0) {
+ if ($y < $y0) {
+ $zinc->coords($text_id, [$x+5, $y-15]);
+ } else {
+ $zinc->coords($text_id, [$x+5, $y0-15]);
+ }
+ } else {
+ if ($y < $y0) {
+ $zinc->coords($text_id, [$x0+5, $y-15]);
+ } else {
+ $zinc->coords($text_id, [$x0+5, $y0-15]);
+ }
+ }
+ $zinc->raise($rectangle_id);
+ $zinc->raise($text_id);
+
+} # end resizerectangle
+
+
+
+# stop drawing rectangular area for search
+sub stoprectangle {
+ my ($widget, $searchtype, $text) = @_;
+ return unless ($zinc->find('withtag', $rectangle_id));
+
+ my @atomicgroups = &unsetAtomicity;
+ my @coords = $zinc->coords($rectangle_id);
+ my @items;
+ for my $item ($zinc->find($searchtype, @coords, 1, 1)) {
+ push (@items, $item) if $item != $rectangle_id and
+ $item != $text_id;
+ }
+ &restoreAtomicity(@atomicgroups);
+ &showresult($text, $zinc, @items) if @items;
+
+} # end stoprectangle
+
+
+
+# in order to avoid find problems with group atomicity, we set all -atomic
+# attributes to 0
+sub unsetAtomicity {
+ my @groups = $zinc->find('withtype', 'group');
+ my @atomicgroups;
+ for my $group (@groups) {
+ if ($zinc->itemcget($group, -atomic)) {
+ push(@atomicgroups, $group);
+ $zinc->itemconfigure($group, -atomic => 0);
+ }
+ }
+ return @atomicgroups;
+
+} # end unsetAtomicity
+
+
+
+sub restoreAtomicity {
+ my @atomicgroups = @_;
+ for my $group (@atomicgroups) {
+ $zinc->itemconfigure($group, -atomic => 1);
+ }
+
+} # end restoreAtomicity
+
+
+
+# display search entry field
+sub searchentry {
+ $search_tl->destroy if $search_tl and Tk::Exists($search_tl);
+ $search_tl = $zinc->Toplevel;
+ $search_tl->title("Specific search");
+ my $fm = $search_tl->Frame->pack(-side => 'top');
+ $fm->Label(-text => "Item TagOrId : ",
+ )->pack(-side => 'left', -padx => 10, -pady => 10);
+ my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
+ -padx => 10, -pady => 10);
+ my $status = $search_tl->Label(-foreground => 'sienna',
+ )->pack(-side => 'top');
+ $search_tl->Button(-text => 'Close',
+ -command => sub {$search_tl->destroy},
+ )->pack(-side => 'top', -pady => 10);
+ $entry->focus;
+ $entry->delete(0, 'end');
+ $entry->insert(0, $searchEntryValue) if $searchEntryValue;
+ $entry->bind('<Key-Return>', [sub {
+ $status->configure(-text => "");
+ $status->update;
+ $searchEntryValue = $entry->get();
+ my @items = $zinc->find('withtag', $searchEntryValue);
+ if (@items) {
+ &showresult("Search with TagOrId $searchEntryValue", $zinc, @items);
+ } else {
+ $status->configure(-text => "No such TagOrId ($searchEntryValue)");
+ }
+ }]);
+
+} # end searchentry
-#------------------------------------------------------------------------------------
-# display in a toplevel the result of search
+
+# test and set $zinc variable
+sub setwidget {
+
+ my $widget = shift;
+ if ($zinc) {
+ if ($zinc ne $widget) {
+ carp "In ZincDebug module, widget value already exists. ".
+ "New value is ignored\n";
+ }
+ } elsif (not $widget) {
+ carp "In ZincDebug module, widget must be specified\n";
+ } else {
+ $zinc = $widget;
+ }
+
+} # end setwidget
+
+# test input keys compatibility
+sub compatkey {
+ push(@keys, @_);
+ my %keys;
+ for (@keys) {
+ if ($keys{$_}) {
+ carp "In ZincDebug module, several bindings on <$_> key exist. ".
+ "Only the last created will work\n";
+ return 0;
+ }
+ $keys{$_} = 1;
+ }
+ return 1;
+
+} # end compatkey
+
+
+
+# test input sequences compatibility
+sub compatseq {
+ push(@seq, @_);
+ my %seq;
+ for (@seq) {
+ my $key = $_->[0].'-'.$_->[1];
+ if ($seq{$key}) {
+ carp "In ZincDebug module, several bindings on <$key> sequence exit. ".
+ "Only the last created will work\n";
+ return 0;
+ }
+ $seq{$key} = 1;
+ }
+ return 1;
+
+
+} # end compatkey
+
+
+
+# display in a toplevel the result of search ; a new toplevel destroyes the
+# previous one
sub showresult {
+ print "*** showresult\n";
my ($label, $zinc, @items) = @_;
- $result_fm->destroy if Tk::Exists($result_fm);
+ # toplevel (re-)creation
+ $result_tl->destroy if Tk::Exists($result_tl);
+ $result_tl = $zinc->Toplevel();
+ my $title = "Zinc Debug";
+ $title .= " - $label" if $label;
+ $result_tl->title($title);
+ $result_tl->geometry('+10+20');
+ $result_tl->Button(-text => 'Close',
+ -command => sub {
+ $result_tl->destroy;
+ $zinc->remove($rectangle_id, $text_id);
+ })->pack(-side => 'bottom');
+ # scrolled pane creation
+ my $heightmax = 500;
+ my $height = 100 + 50*@items;
+ $height = $heightmax if $height > $heightmax;
$result_fm = $result_tl->Scrolled('Pane',
-scrollbars => 'se',
-width => scalar $result_tl->screenwidth,
- -height => 500,
+ -height => $height,
);
-
$result_fm->pack(-padx => 10, -pady => 10,
-ipadx => 10,
-fill => 'both',
-expand => 1,
);
+ # attributes display
&showattributes($result_fm, \@items);
- $result_tl->deiconify;
- $result_tl->update;
-}
+
+} # end showresult
-# display in a toplevel the value of other options
+# display in a toplevel the values of other options
sub showotheroptions {
my ($zinc, $item) = @_;
my $tl = $zinc->Toplevel;
@@ -138,10 +521,12 @@ sub showotheroptions {
$i++;
}
$tl->Button(-text => 'Close',
- -command => sub {$tl->destroy})->pack;
+ -command => sub {$tl->destroy})->pack;
-}
+} # end showotheroptions
+
+# display in a toplevel group's attributes
sub showgroupattributes {
my ($zinc, $item) = @_;
my $tl = $zinc->Toplevel;
@@ -243,139 +628,123 @@ sub showgroupattributes {
$tl->Button(-text => 'Close',
-command => sub {$tl->destroy})->pack;
-}
+} # end showgroupattributes
# display in a toplevel the content of a group item
sub showgroupcontent {
my ($zinc, $group) = @_;
my $tl = $zinc->Toplevel;
+ my @items = $zinc->find('withtag', $group.".");
+ my $heightmax = 500;
+ my $height = 100 + 50*@items;
+ $height = $heightmax if $height > $heightmax;
my $title = "Content of group $group";
$tl->title($title);
- my $fm = $tl->Scrolled('Pane',
+ my $fm = $tl->Scrolled('Pane',
-scrollbars => 'se',
-width => scalar $result_tl->screenwidth,
- -height => 200,
+ -height => $height,
-label => $title,
)->pack(-padx => 10, -pady => 10,
-ipadx => 10,
-expand => 1,
-fill => 'both');
- my @items = $zinc->find('withtag', $group.".");
&showattributes($fm, \@items);
$tl->Button(-text => 'Close',
-command => sub {$tl->destroy})->pack;
-}
+
+} # end showgroupcontent
+
# highlight an item (by cloning it and hiding other found items)
# why cloning? because we can't simply make visible an item which
# belongs to an invisible group.
sub highlightitem {
- my ($btn, $zinc, $item) = @_;
+ my ($btn, $zinc, $item, $level) = @_;
return if $showitemflag;
$showitemflag = 1;
- my @itemstohide = ();
- my @visibility = ();
- for ($zinc->find('overlapping', $zinc->coords($rectangle_id))) {
- push (@itemstohide, $_) unless $_ == $rectangle_id or $_ == $text_id;
+ &surrounditem($zinc, $item);
+
+ # make parent groups invisible
+ my $group;
+ my $visibility;
+ if ($level == 2) {
+ my $group1 = $zinc->group($item);
+ if ($group1 == 1) {
+ $group = undef;
+ } else {
+ my $group2 = $zinc->group($group1);
+ if ($group2 == 1) {
+ $group = $group1;
+ } else {
+ $group = $group2;
+ }
+ }
+ } elsif ($level == 1) {
+ my $group1 = $zinc->group($item);
+ if ($group1 == 1) {
+ $group = undef;
+ } else {
+ $group = $group1;
+ }
}
- for (@itemstohide) {
- push(@visibility, scalar $zinc->itemcget($_, -visible));
- $zinc->itemconfigure($_, -visible => 0);
+ if ($group) {
+ $visibility = $zinc->itemcget($group, -visible);
+ $zinc->itemconfigure($group, -visible => 0);
}
+
+ $btn->bind('<ButtonRelease>', [\&undohighlightitem, $zinc, 'zincdebug',
+ $group, $visibility]) if $btn;
+
+} # end highlightitem
+
+
+
+sub surrounditem {
+ my ($zinc, $item) = @_;
+ $zinc->remove("zincdebug");
my @coords = $zinc->coords($item);
- my $clone = $zinc->clone($item, -visible => 1);
+ # cloning
+ my $clone = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']);
+ # move in group 1
$zinc->chggroup($clone, 1);
$zinc->coords($clone, [$zinc->transform(scalar $zinc->group($item), 1, [@coords])]);
- $zinc->raise($clone);
- $btn->bind('<ButtonRelease>', [\&undohighlightitem, $zinc, $clone,
- \@itemstohide, \@visibility]);
+ # apply transformation
+ #$zinc->tsave($item, "trans");
+ ##$zinc->trestore($clone, "trans");
+ # create a rectangle around
+ my @bbox = $zinc->bbox($clone);
+ if (scalar @bbox == 4) {
+ my $i = 0;
+ for ('white', 'red', 'white') {
+ $zinc->add('rectangle', 1, [$bbox[0] - 5 - 2*$i , $bbox[1] - 5 - 2*$i,
+ $bbox[2] + 5 + 2*$i, $bbox[3] + 5 + 2*$i],
+ -linecolor => $_,
+ -linewidth => 1,
+ -tags => ['zincdebug']);
+ $i++;
+ }
+ }
+ # raise
+ $zinc->raise('zincdebug');
+
+} # end surrounditem
-}
sub undohighlightitem {
- my ($btn, $zinc, $clone, $itemstohide, $visibility) = @_;
+ my ($btn, $zinc, $items2delete, $group, $visibility) = @_;
$btn->bind('ReleaseButton', '');
- for (my $i=0; $i < @$itemstohide; $i++) {
- $zinc->itemconfigure($itemstohide->[$i], -visible => $visibility->[$i]);
- }
- $zinc->remove($clone);
+ $zinc->itemconfigure($group, -visible => $visibility) if $group;
+ $zinc->remove($items2delete);
$showitemflag = 0;
-}
+} # end undohighlightitem
-# print a zinc window in png format
-sub printWindow {
- exit if $saving;
- $saving = 1;
- my ($zinc,$basename,$verbosity) = @_;
- my $id = $zinc->id;
- my $filename = $basename . $imagecounter . ".png";
- $imagecounter++;
- my $original_cursor = ($zinc->configure(-cursor))[3];
- $zinc->configure(-cursor => 'watch');
- $zinc->update;
- my $res = system("import", -window, $id, $filename);
- $zinc->configure(-cursor => $original_cursor);
-
- $saving = 0;
- if ($res) {
- &showErrorWhilePrinting($res)
- }
- else {
- my $dir = `pwd`; chomp ($dir);
- print "ZincDebug: Zinc window snapshot saved in $dir". "/$filename\n" if $verbosity;
- }
-}
-
-# display complete help screen
-sub showErrorWhilePrinting {
- my ($res) = @_;
- my $dir = `pwd`; chomp ($dir);
- $help_print->destroy if $help_print and Tk::Exists($help_print);
- $help_print = $zinc->Dialog(-title => 'Zinc Print info',
- -text =>
- "To acquire a TkZinc window snapshot, you must " .
- "have access to the import command, which is ".
- "part of imageMagic package\n\n".
- "You must also have the rights to write ".
- "in the current dir : $dir",
- -bitmap => 'warning',
- );
- $help_print->after(300, sub {$help_print->grabRelease});
- $help_print->Show();
-}
-# display complete help screen
-sub showhelp {
- my ($w, $ekb, $okb, $pkb) = @_;
- my $eseq = $ekb->[0]."-Button".$ekb->[1];
- my $oseq = $okb->[0]."-Button".$okb->[1];
- my $pseq = $pkb->[0]."-Button".$pkb->[1];
- $help_tl->destroy if $help_tl and Tk::Exists($help_tl);
- $help_tl = $zinc->Dialog(-title => 'Zinc Debug info',
- -text =>
- "With <".$oseq."> sequence, create ".
- "a rectangular area to search items ".
- "which overlap it.\n\n".
- "With <".$eseq."> sequence, create ".
- "a rectangular area to search items ".
- "which are enclosed in it.\n\n".
- "With <".$pseq."> you can acquire a " .
- "snapshot of the full zinc window. ".
- "It will be saved in the current directory ".
- "with the name zincsnapshot<n>.png ".
- "The ImageMagic package must be installed.\n\n".
- "Strike <Escape> key to display this help ".
- "message again.",
- -bitmap => 'info',
- );
- $help_tl->after(300, sub {$help_tl->grabRelease});
- $help_tl->Show();
-}
sub showbanner {
my $fm = shift;
@@ -403,23 +772,56 @@ sub showbanner {
->grid(-row => $i, -col => 10, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
$fm->Label()->grid(-row => 1, -col => 11, -pady => 10);
-}
+} # end showbanner
+
# display in a grid the values of most important attributes
sub showattributes {
my ($fm, $items) = @_;
my $bgcolor = 'ivory';
my $i = 1;
+ # help text
+ my $font = $zinc->cget(-font);
+ my $text = $fm->Text(-height => 5,
+ -relief => 'flat',
+ -font => $font,
+ -wrap => 'word',
+ -foreground => 'gray30',
+ )->grid(-sticky => 'nswe',
+ -columnspan => 10,
+ -row => $i++,
+ -col => 1);
+ $text->tagConfigure('keyword', -foreground => 'black');
+ $text->insert('end',
+ "First column contains items identifiers buttons you can press to ".
+ "highlight corresponding items in the application. ");
+ $text->insert('end', "By default, using ");
+ $text->insert('end', "left mouse button", "keyword");
+ $text->insert('end', ", highlighting is done by raising selected item and drawing ".
+ "a rectangle arround. ");
+ $text->insert('end', "If you use ");
+ $text->insert('end', "center mouse button", "keyword");
+ $text->insert('end', ", other items contained in the selected item's group are ".
+ "hidden too. ");
+ $text->insert('end', "And if you use ");
+ $text->insert('end', "right mouse button", "keyword");
+ $text->insert('end', ", members of the selected item's parent group are hidden ".
+ "too.\n");
+ $text->insert('end', "Third column contains groups identifiers buttons you can ".
+ "press to display groups content and attributes.");
&showbanner($fm, $i++);
for my $item (@$items) {
+ my $type = $zinc->type($item);
# id
my $idbtn =
$fm->Button(-text => $item,
-foreground => 'red'
- )->grid(-row => $i, -col => 1, -sticky => 'nswe', -ipadx => 5);
- $idbtn->bind('<1>', [\&highlightitem, $zinc, $item]);
+ )->grid(-row => $i, -col => 1, -sticky => 'nswe',
+ -ipadx => 5);
+ $idbtn->bind('<1>', [\&highlightitem, $zinc, $item, 0]);
+ $idbtn->bind('<2>', [\&highlightitem, $zinc, $item, 1]);
+ $idbtn->bind('<3>', [\&highlightitem, $zinc, $item, 2]);
# type
- my $type = $zinc->type($item);
if ($type eq 'group') {
$fm->Button(-text => $type,
-command => [\&showgroupcontent, $zinc, $item])
@@ -506,91 +908,109 @@ sub showattributes {
$i++;
&showbanner($fm, $i++) if ($i % 15 == 0);
}
-}
-
-# begin to draw rectangular area for search
-sub startrectangle {
- my ($widget, $style, $text, $color) = @_;
- if (not $result_tl or not Tk::Exists($result_tl)) {
- $result_tl = $zinc->Toplevel();
- $result_tl->title("Zinc Debug");
- $result_tl->geometry('+10+10');
- $result_tl->Button(-text => 'Close',
- -command => sub {
- $result_tl->destroy;
- $zinc->remove($rectangle_id, $text_id);
- })->pack(-side => 'bottom');
- }
- $zinc->remove($rectangle_id, $text_id);
- $result_tl->iconify;
- my $ev = $zinc->XEvent;
- ($x0, $y0) = ($ev->x, $ev->y);
- $rectangle_id = $zinc->add('rectangle', 1, [$x0, $y0, $x0, $y0],
- -linecolor => $color,
- -linewidth => 2,
- -linestyle => $style,
- );
- $text_id = $zinc->add('text', 1,
- -color => $color,
- -font => '7x13',
- -position => [$x0+5, $y0-15],
- -text => $text,
- );
-
-}
+
+} # end showattributes
-# resize the rectangular area for search
-sub resizerectangle {
- my $ev = $zinc->XEvent;
- my ($x, $y) = ($ev->x, $ev->y);
- return unless ($zinc->find('withtag', $rectangle_id));
+#---------------------------------------------------------------------------
+#
+# SNAPSHOT FUNCTIONS
+#
+#---------------------------------------------------------------------------
- $zinc->coords($rectangle_id, 1, 1, [$x, $y]);
- if ($x < $x0) {
- if ($y < $y0) {
- $zinc->coords($text_id, [$x+5, $y-15]);
- } else {
- $zinc->coords($text_id, [$x+5, $y0-15]);
- }
- } else {
- if ($y < $y0) {
- $zinc->coords($text_id, [$x0+5, $y-15]);
- } else {
- $zinc->coords($text_id, [$x0+5, $y0-15]);
+# print a zinc window in png format
+sub printWindow {
+ exit if $saving;
+ $saving = 1;
+ my ($zinc,$basename,$verbosity) = @_;
+ my $id = $zinc->id;
+ my $filename = $basename . $imagecounter . ".png";
+ $imagecounter++;
+ my $original_cursor = ($zinc->configure(-cursor))[3];
+ $zinc->configure(-cursor => 'watch');
+ $zinc->update;
+ my $res = system("import", -window, $id, $filename);
+ $zinc->configure(-cursor => $original_cursor);
+
+ $saving = 0;
+ if ($res) {
+ &showErrorWhilePrinting($res)
}
+ else {
+ my $dir = `pwd`; chomp ($dir);
+ print "ZincDebug: Zinc window snapshot saved in $dir". "/$filename\n"
+ if $verbosity;
}
- $zinc->raise($rectangle_id);
- $zinc->raise($text_id);
-}
+} # end printWindow
-# stop drawing rectangular area for search
-sub stoprectangle {
- my ($widget, $searchtype, $text) = @_;
- return unless ($zinc->find('withtag', $rectangle_id));
- # in order to avoid find problems with group atomicity, we set all -atomic
- # attributes to 0
- my @groups = $zinc->find('withtype', 'group');
- my @atomicgroups;
- for my $group (@groups) {
- if ($zinc->itemcget($group, -atomic)) {
- push(@atomicgroups, $group);
- $zinc->itemconfigure($group, -atomic => 0);
- }
+# display complete help screen
+sub showErrorWhilePrinting {
+ my ($res) = @_;
+ my $dir = `pwd`; chomp ($dir);
+ $help_print->destroy if $help_print and Tk::Exists($help_print);
+ $help_print = $zinc->Dialog(-title => 'Zinc Print info',
+ -text =>
+ "To acquire a TkZinc window snapshot, you must " .
+ "have access to the import command, which is ".
+ "part of imageMagic package\n\n".
+ "You must also have the rights to write ".
+ "in the current dir : $dir",
+ -bitmap => 'warning',
+ );
+ $help_print->after(300, sub {$help_print->grabRelease});
+ $help_print->Show();
+
+} # end showErrorWhilePrinting
+
+#---------------------------------------------------------------------------
+#
+# HELP FUNCTION
+#
+#---------------------------------------------------------------------------
+# display complete help screen
+sub showhelp {
+ my $text;
+ if ($enclosedModBtn) {
+ my $eseq = $enclosedModBtn->[0]."-Button".$enclosedModBtn->[1];
+ my $oseq = $overlapModBtn->[0]."-Button".$overlapModBtn->[1];
+ $text .= "With <".$oseq."> sequence, create ".
+ "a rectangular area to search items ".
+ "which overlap it.\n".
+ "With <".$eseq."> sequence, create ".
+ "a rectangular area to search items ".
+ "which are enclosed in it.\n".
+ "With <".$searchKey."> sequence, search a specific ".
+ "item id using an entry field.\n\n";
}
- my @coords = $zinc->coords($rectangle_id);
- my @items;
- for my $item ($zinc->find($searchtype, @coords, 1, 1)) {
- push (@items, $item) if $item != $rectangle_id and
- $item != $text_id;
+ if ($treeKey) {
+ my $tseq = $treeModBtn->[0]."-Button".$treeModBtn->[1];
+ $text .= "With <".$treeKey."> sequence, you build and display ".
+ "the items tree.\n".
+ "With <".$tseq."> sequence, select a particular item ".
+ "in the application window and see its position in the".
+ "tree.\n\n";
}
- for my $group (@atomicgroups) {
- $zinc->itemconfigure($group, -atomic => 1);
+ if ($snapKey) {
+ $text .= "With <".$snapKey."> sequence you can acquire " .
+ "a snapshot of the full zinc window. ".
+ "It will be saved in the current directory ".
+ "with the name zincsnapshot<n>.png ".
+ "The ImageMagic package must be installed.\n\n";
}
- &showresult($text, $zinc, @items);
+ $text .= "Strike <Escape> key to display this help message again.";
+
+ $help_tl->destroy if $help_tl and Tk::Exists($help_tl);
+ $help_tl = $zinc->Dialog(-title => 'Zinc Debug info',
+ -text => $text,
+ -bitmap => 'info',
+ );
+ $help_tl->after(300, sub {$help_tl->grabRelease});
+ $help_tl->Show();
+
+} # end showhelp
+
-}
1;
@@ -607,14 +1027,20 @@ ZincDebug - a perl module for analysing a Zinc application.
use ZincDebug;
my $zinc = MainWindow->new()->Zinc()->pack;
finditems($zinc);
+ tree($zinc);
+ snapshot($zinc);
=head1 DESCRIPTION
ZincDebug provides an interface to help developers to debug or analyse Zinc applications.
-With B<finditems> function, you are able to scan all items which are enclosed in a rectangular area you have first drawn by drag & drop, or all items which overlap it. Result is a Tk table which presents details (options, coordinates, ...) about found items; you can also highlight a particular item, even if it's not visible, by clicking on its corresponding button in the table.
+With B<finditems> function, you are able to scan all items which are enclosed in a rectangular area you have first drawn by drag & drop, or all items which overlap it. Result is a Tk table which presents details (options, coordinates, ...) about found items; you can also highlight a particular item, even if it's not visible, by clicking on its corresponding button in the table. You can also display particular item's features by entering this id in dedicated entry field
-Press Escape key in the main window of the application to have some help about available input sequences.
+B<tree> function displays item's hierarchy. You can find a particular item's position in the tree and you can highlight items and see their features as described above.
+
+With B<snapshot> function, you are able to snapshot the application window, in order to illustrate a graphical bug for example.
+
+Press B<Escape> key in the main window of the application to have some help about available input sequences.
=head1 FUNCTIONS
@@ -640,17 +1066,46 @@ Defines input sequence used to process "enclosed" search. Default to ['Control',
Defines input sequence used to process "overlap" search. Default to ['Shift', 3].
-=item E<32>E<32>E<32>B<-snapshotModBtn> => [Mod, Btn]
+=item E<32>E<32>E<32>B<-searchKey> => key
+
+Defines input key used to process particular search. Default to 'Control-f'.
+
+=back
+
+=item B<tree>($zinc, ?option => value, ...?)
+
+This function creates required Tk bindings to build items tree. You can specify the following options :
+
+=over
+
+=item E<32>E<32>E<32>B<-key> => key
+
+Defines input sequence used to build and display items tree. Default to 'Control-t'.
-Defines input sequence used to process a snapshot of the zinc window. Default to ['Control-Shift', 2].
+=item E<32>E<32>E<32>B<-itemModBtn> => [Mod, Btn]
-=item E<32>E<32>E<32>B<-snapshotVerbosity> => boolean
+Defines input sequence used to select an item in the application window in order to display its position in the item's tree. Default to ['Control', 2].
+
+=back
+
+
+=item B<snapshot>($zinc, ?option => value, ...?)
+
+This function creates required Tk binding to snapshot the application window. You can specify the following options :
+
+=over
+
+=item E<32>E<32>E<32>B<-key> => key
+
+Defines input key used to process a snapshot of the zinc window. Default to ['Control-s'].
+
+=item E<32>E<32>E<32>B<-verbosity> => boolean
Defines if snapshot should print a message on the terminal. Default to true.
-=item E<32>E<32>E<32>B<-snapshotBasename> => "a_string"
+=item E<32>E<32>E<32>B<-basename> => "a_string"
-Defines the basename used for the file containing the snaphshot. The filename will be <currentdir>/basename<n>.png Defaulted to zincsnapshot.
+Defines the basename used for the file containing the snaphshot. The filename will be <currentdir>/basename<n>.png Defaulted to zincsnapshot.
=back
@@ -660,3 +1115,5 @@ Defines the basename used for the file containing the snaphshot. The filename wi
=head1 AUTEURS
Daniel Etienne <etienne@cena.fr>
+
+Christophe Mertz <mertz@cena.fr>
generated by cgit v1.1 at 2024-11-08 02:21:47 +0000