diff options
| -rw-r--r-- | Perl/Zinc/Debug.pm | 235 |
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 |