aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Perl/Zinc/Debug.pm235
1 files changed, 160 insertions, 75 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index 19adf50..d086e63 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -33,7 +33,7 @@ my $coords_tl;
my $devicecoords_tl;
my ($text_id, $rectangle_id);
my ($x0, $y0);
-my ($help_print, $imagecounter, $saving) = (0,0);
+my ($help_print, $imagecounter, $saving) = (0, 0, 0);
my $searchEntryValue;
my $searchTreeEntryValue;
my $tree_tl;
@@ -48,10 +48,11 @@ my $tree;
my @keys;
my @seq;
my $helptree_tl;
-my $wwidth;
-my $wheight;
+my $wwidth = 0;
+my $wheight = 0;
my $preload;
my %run;
+my %defaultoptions;
sub BEGIN {
# test if ZincDebug is loaded using the -M perl option
@@ -63,6 +64,7 @@ sub BEGIN {
sub Tk::Zinc::InitObject {
Tk::Widget::InitObject(@_);
return unless $preload;
+ return if $zinc;
$zinc = $_[0];
&tree($zinc);
&finditems($zinc);
@@ -250,21 +252,20 @@ sub showtree {
-command => sub {
my $path = shift;
my $item = (split(/\./, $path))[-1];
- $zinc->remove("zincdebug");
&showresult("", $zinc, $item);
+ $zinc->after(100, sub {$zinc->remove("zincdebug")});
},
);
$tree->bind('<1>', [sub {
my $path = $tree->nearest($_[1]);
my $item = (split(/\./, $path))[-1];
- print "item=$item\n";
&highlightitem($tree, $zinc, $item, 0);
}, Ev('y')]);
$tree->bind('<2>', [sub {
my $path = $tree->nearest($_[1]);
- return if $path == 1;
+ return if $path eq 1;
$tree->selectionClear;
$tree->selectionSet($path);
$tree->anchorSet($path);
@@ -275,7 +276,7 @@ sub showtree {
$tree->bind('<3>', [sub {
my $path = $tree->nearest($_[1]);
- return if $path == 1;
+ return if $path eq 1;
$tree->selectionClear;
$tree->selectionSet($path);
$tree->anchorSet($path);
@@ -447,7 +448,7 @@ sub scangroup {
#---------------------------------------------------------------------------
#
-# FIND PRIVATE FUNCTIONS
+# AREA SEARCH PRIVATE FUNCTIONS
#
#---------------------------------------------------------------------------
# begin to draw rectangular area for search
@@ -594,9 +595,6 @@ sub setwidget {
} else {
$zinc = $widget;
}
- $zinc->update;
- my $geom = $zinc->geometry =~ /(\d+)x(\d+)+/=~ /(\d+)x(\d+)+/;
- ($wwidth, $wheight) = ($1, $2);
# binding for help screen
$zinc->toplevel->Tk::bind('<Key-Escape>', \&showgeneralhelp);
@@ -640,6 +638,11 @@ sub compatseq {
} # end compatkey
+#---------------------------------------------------------------------------
+#
+# RESULTS DISPLAY PRIVATE FUNCTIONS
+#
+#---------------------------------------------------------------------------
# display in a toplevel the result of search ; a new toplevel destroyes the
# previous one
@@ -699,14 +702,24 @@ sub showotheroptions {
)->pack(-padx => 10, -pady => 10,
-ipadx => 10,
-fill => 'both');
+ my $btn1 = $fm->Button(-text => 'Show Item',)
+ ->grid(-row => 1, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+ $btn1->bind('<1>', [\&highlightitem, $zinc, $item, 0]);
+ $btn1->bind('<2>', [\&highlightitem, $zinc, $item, 1]);
+ $btn1->bind('<3>', [\&highlightitem, $zinc, $item, 2]);
+ my $btn2 = $fm->Button(-text => 'Bounding Box')
+ ->grid(-row => 1, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+ $btn2->bind("<1>", [\&showbbox, $zinc, $item]);
+ $btn2->bind("<ButtonRelease-1>", [\&hidebbox, $zinc]);
+
my $bgcolor = 'ivory';
$fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge')
- ->grid(-row => 1, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+ ->grid(-row => 2, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
$fm->Label(-text => 'Value', -background => $bgcolor, -relief => 'ridge')
- ->grid(-row => 1, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+ ->grid(-row => 2, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
my @options = $zinc->itemconfigure($item);
- my $i = 2;
+ my $i = 3;
for my $elem (@options) {
my ($option, $type, $value) = (@$elem)[0,1,4];
#print "option=$option type=$type\n";
@@ -719,7 +732,7 @@ sub showotheroptions {
}
$fm->Label(-text => $option, -relief => 'ridge')
->grid(-row => $i, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
- $fm->Label(-text => $value, -relief => 'ridge')
+ &entryoption($fm, $item, $zinc, $option)
->grid(-row => $i, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
$i++;
}
@@ -733,7 +746,7 @@ sub showdevicecoords {
my ($zinc, $item) = @_;
&showcoords($zinc, $item, 1);
-}
+} # end showdevicecoords
sub showcoords {
@@ -811,7 +824,8 @@ sub showcoords {
$coords->[0] =~ s/\.(\d\d).*/\.$1/;
$coords->[1] =~ s/\.(\d\d).*/\.$1/;
my $pointtype = (defined $coords->[2]) ? " ".$coords->[2] : "";
- $coords_fm->Label(-text => sprintf('%s, %s%s', $coords->[0], $coords->[1],$pointtype),
+ $coords_fm->Label(-text => sprintf('%s, %s%s', $coords->[0], $coords->[1],
+ $pointtype),
-width => 15,
-relief => 'ridge')->grid(-row => $row,
-ipadx => 5,
@@ -839,8 +853,15 @@ sub showgroupattributes {
my $r = 1;
# content
$fm->Button(-command => [\&showgroupcontent, $zinc, $item],
+ -height => 2,
-text => 'Content',
- )->grid(-row => $r++, -col => 1, -columnspan => 2, -sticky => 'nswe');
+ )->grid(-row => $r, -col => 1, -sticky => 'nswe');
+ my $btn = $fm->Button(-height => 2,
+ -text => 'Bounding Box',
+ )->grid(-row => $r++, -col => 2, -sticky => 'nswe');
+ $btn->bind("<1>", [\&showbbox, $zinc, $item]);
+ $btn->bind("<ButtonRelease-1>", [\&hidebbox, $zinc]);
+
# parent group
$fm->Label(-text => 'Parent group', -relief => 'ridge')
->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
@@ -919,13 +940,17 @@ sub showgroupattributes {
my ($option, $value) = (@$elem)[0,4];
$fm->Label(-text => $option, -relief => 'ridge')
->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+ my $w;
if ($option and $option eq '-tags') {
$value = join("\n", @$value);
+ $w = $fm->Label(-text => $value, -relief => 'ridge');
} elsif ($option and $option eq '-clip' and $value and $value > 0) {
$value .= " (". $zinc->type($value) .")";
+ $w = $fm->Label(-text => $value, -relief => 'ridge');
+ } else {
+ $w = &entryoption($fm, $item, $zinc, $option);
}
- $fm->Label(-text => $value, -relief => 'ridge')
- ->grid(-row => $r, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+ $w->grid(-row => $r, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
$r++;
}
$tl->Button(-text => 'Close',
@@ -967,6 +992,36 @@ sub showgroupcontent {
} # end showgroupcontent
+# display the bbox of a group item
+sub showbbox {
+ my ($btn, $zinc, $item) = @_;
+ my @bbox = $zinc->bbox($item);
+ if (scalar @bbox == 4) {
+ # If item is visible, rectangle is drawm surround it.
+ # Else, a warning is displayed.
+ unless (&itemisoutside(@bbox)) {
+ my $i = 0;
+ for ('white', 'blue', '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 => ['zincdebugbbox']);
+ $i++;
+ }
+ }
+ }
+ $zinc->raise('zincdebugbbox');
+
+} # end showgroupbbox
+
+
+sub hidebbox {
+ my ($btn, $zinc) = @_;
+ $zinc->remove("zincdebugbbox");
+
+} # end hidegroupbbox
# highlight an item (by cloning it and hiding other found items)
@@ -986,6 +1041,7 @@ sub highlightitem {
sub itemisoutside {
my @bbox = @_;
my $outflag;
+ $WARNING = 0;
if ($bbox[2] < 0) {
if ($bbox[1] > $wheight) {
$outflag = 'left+bottom';
@@ -1097,7 +1153,7 @@ sub surrounditem {
# If item is visible, rectangle is drawm surround it.
# Else, a warning is displayed.
unless (&itemisoutside(@bbox0)) {
- if ($level > 0) {
+ if (defined($level) and $level > 0) {
my $r = $zinc->add('Rectangle', $topgroup,
[$bbox[0] - 10, $bbox[1] - 10,
$bbox[2] + 10, $bbox[3] + 10],
@@ -1167,6 +1223,11 @@ sub showbanner {
# display in a grid the values of most important attributes
sub showattributes {
my ($fm, $items) = @_;
+ unless ($wwidth > 1) {
+ $zinc->update;
+ my $geom = $zinc->geometry =~ /(\d+)x(\d+)+/=~ /(\d+)x(\d+)+/;
+ ($wwidth, $wheight) = ($1, $2);
+ }
my $bgcolor = 'ivory';
my $i = 1;
&showbanner($fm, $i++);
@@ -1196,16 +1257,13 @@ sub showattributes {
-command => [\&showgroupattributes, $zinc, $group])
->grid(-row => $i, -col => 3, -sticky => 'nswe', -ipadx => 5);
# priority
- $fm->Label(-text => scalar $zinc->itemcget($item, -priority),
- -relief => 'ridge')
+ &entryoption($fm, $item, $zinc, -priority)
->grid(-row => $i, -col => 4, -sticky => 'nswe', -ipadx => 5);
# sensitiveness
- $fm->Label(-text => scalar $zinc->itemcget($item, -sensitive),
- -relief => 'ridge')
+ &entryoption($fm, $item, $zinc, -sensitive)
->grid(-row => $i, -col => 5, -sticky => 'nswe', -ipadx => 5);
# visibility
- $fm->Label(-text => scalar $zinc->itemcget($item, -visible),
- -relief => 'ridge')
+ &entryoption($fm, $item, $zinc, -visible)
->grid(-row => $i, -col => 6, -sticky => 'nswe', -ipadx => 5);
# coords
my @coords = $zinc->coords($item);
@@ -1266,9 +1324,11 @@ sub showattributes {
}
# bounding box
my @bbox = $zinc->bbox($item);
- $fm->Label(-text => "($bbox[0], $bbox[1]), ($bbox[2], $bbox[3])",
- -relief => 'ridge')
+ my $btn = $fm->Button(-text => "($bbox[0], $bbox[1]), ($bbox[2], $bbox[3])")
->grid(-row => $i, -col => 9, -sticky => 'nswe', -ipadx => 5);
+ $btn->bind('<1>', [\&showbbox, $zinc, $item]);
+ $btn->bind('<ButtonRelease-1>', [\&hidebbox, $zinc]) ;
+
# tags
my @tags = $zinc->gettags($item);
$fm->Label(-text => join("\n", @tags),
@@ -1339,7 +1399,7 @@ sub showErrorWhilePrinting {
#---------------------------------------------------------------------------
#
-# HELP FUNCTION
+# HELP FUNCTIONS
#
#---------------------------------------------------------------------------
# display complete help screen
@@ -1417,48 +1477,6 @@ sub showgeneralhelp {
} # end showgeneralhelp
-sub showgeneralhelp_old {
- 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";
- }
- 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";
- }
- 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";
- }
- $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 showgeneralhelp
-
-
# display help about tree
sub showHelpAboutTree {
$helptree_tl->destroy if $helptree_tl and Tk::Exists($helptree_tl);
@@ -1515,14 +1533,26 @@ sub showHelpAboutAttributes {
-foreground => 'gray10',
);
$text->tagConfigure('keyword', -foreground => 'darkblue');
+ $text->tagConfigure('title', -foreground => 'ivory',
+ -background => 'gray60');
+ $text->insert('end', " To highlight a specific item\n", 'title');
$text->insert('end',
- "First column contains items identifiers buttons you can press to ".
+ "\nFirst column contains items identifiers buttons you can press to ".
"highlight corresponding items in the application.\n");
&infoAboutHighlighting($text);
$text->insert('end', "\n\nThird column contains groups identifiers buttons you can ".
- "press to display groups content and attributes.");
+ "press to display groups content and attributes.\n\n");
+ $text->insert('end', " To display the bounding box of an item\n", 'title');
+ $text->insert('end', "\nUse the buttons of the column labeled ".
+ "'Bounding Box'.\n\n");
+ $text->insert('end', " To change the value of attributes\n", 'title');
+ $text->insert('end', "\nMost of information fields are editable. A simple ".
+ "colored feedback shows which attributes have changed. Use <");
+ $text->insert('end', "Control-z", "keyword");
+ $text->insert('end', "> sequence to restore the initial value\n");
+
$text->configure(-state => 'disabled');
$helptree_tl->Button(-command => sub {$helptree_tl->destroy},
@@ -1550,6 +1580,61 @@ sub infoAboutHighlighting {
} # end infoAboutHighlighting
+#---------------------------------------------------------------------------
+#
+# EDITION FUNCTION
+#
+#---------------------------------------------------------------------------
+sub entryoption {
+ my ($fm, $item, $zinc, $option) = @_;
+ my $def = $zinc->itemcget($item, $option);
+ my $i0;
+ my $e;
+ if ($def =~ /\n/) {
+ $e = $fm->Text(-height => 1, -width => 1, -wrap => 'word');
+ $i0 = '0.0';
+ } else {
+ $e = $fm->Entry();
+ $i0 = 0;
+ }
+ my $len = length($def);
+ $len = 50 if $len > 50;
+ $e->configure(-width => $len);
+ if ($defaultoptions{$item}->{$option} and
+ $def ne $defaultoptions{$item}->{$option}) {
+ $e->configure(-foreground => 'blue');
+ }
+
+ $e->insert($i0, $def);
+ $e->bind('<Control-z>', sub {
+ return unless $defaultoptions{$item}->{$option};
+ my $bg = $e->cget(-background);
+ $zinc->itemconfigure($item, $option => $defaultoptions{$item}->{$option});
+ $e->delete($i0, 'end');
+ $e->insert($i0, $defaultoptions{$item}->{$option});
+ $e->configure(-background => 'ivory');
+ $e->after(80, sub {$e->configure(-background => $bg, -foreground => 'black')});
+ });
+ $e->bind('<Key-Return>',
+ sub {my $val = $e->get;
+ my $bg = $e->cget(-background);
+ $e->configure(-background => 'ivory');
+ if ($def ne $val) {
+ $defaultoptions{$item}->{$option} = $def
+ unless $defaultoptions{$item}->{$option};
+ }
+ my $fg = ($val ne $defaultoptions{$item}->{$option}) ?
+ 'blue' : 'black';
+ $e->after(80, sub {
+ $e->configure(-background => $bg, -foreground => $fg);
+ });
+ $zinc->itemconfigure($item, $option => $val);
+ });
+
+ return $e;
+
+} # end entryoption
+
1;
@@ -1588,7 +1673,7 @@ B<zincdebug()> function invokes all the previous specific functions with default
Press B<Escape> key in the main window of the application to have some help about available input sequences.
-If you load ZincDebug using the -M perl option, nothing needs to be added to your code. In this mode, all the previous specific functions are invoked with default options.
+B<If you load ZincDebug using the -M perl option, nothing needs to be added to your code>. In this mode, all the previous specific functions are invoked with default options.
=head1 FUNCTIONS