From b707327fd3eaa1a2445379240aaace3e8e05d7fe Mon Sep 17 00:00:00 2001 From: etienne Date: Tue, 5 Nov 2002 17:54:53 +0000 Subject: * Modification concernant la fonction tree() : Possibilit� d'afficher, pour chaque item de l'arbre, la valeur d'un ou de plusieurs de ses attributs; utiliser les options -optionsToDisplay et -optionsFormat. M�canisme de recherche de chaine de caract�res. Feedback pour signaler qu'un item s�lectionn� dans l'arbre n'est pas visible car en dehors de la fen�tre. --- Perl/Zinc/Debug.pm | 329 ++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 290 insertions(+), 39 deletions(-) (limited to 'Perl/Zinc/Debug.pm') diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm index 32309d4..6f7f75b 100644 --- a/Perl/Zinc/Debug.pm +++ b/Perl/Zinc/Debug.pm @@ -9,8 +9,9 @@ package ZincDebug; use strict 'vars'; -use vars qw(@ISA @EXPORT); +use vars qw(@ISA @EXPORT $WARNING); use Carp; +use English; require Exporter; use File::Basename; use Tk; @@ -19,17 +20,20 @@ use Tk::LabFrame; use Tk::Pane; use Tk::Dialog; use Tk::Tree; +use Tk::ItemStyle; @ISA = qw(Exporter); @EXPORT = qw(finditems snapshot tree); -my ($help_tl0, $help_tl, $result_tl, $result_fm, $search_tl, $showitemflag); +my ($help_tl0, $help_tl, $result_tl, $result_fm, $search_tl, + $searchtree_tl, $showitemflag); my $coords_tl; my $devicecoords_tl; my ($text_id, $rectangle_id); my ($x0, $y0); my ($help_print, $imagecounter, $saving) = (0,0); my $searchEntryValue; +my $searchTreeEntryValue; my $tree_tl; my $zinc; my $enclosedModBtn; @@ -42,21 +46,33 @@ my $tree; my @keys; my @seq; my $helptree_tl; +my $wwidth; +my $wheight; sub tree { &setwidget(shift); return unless $zinc; + # styles definition + $zinc->ItemStyle('text', -stylename => "item", -foreground => 'black'); + $zinc->ItemStyle('text', -stylename => "group", -foreground => 'black'); # 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'); + unless ($opt eq '-itemModBtn' or $opt eq '-key' or + $opt eq '-optionsToDisplay' or $opt eq '-optionsFormat'); } $treeKey = ($options{-key}) ? $options{-key} : 'Control-t'; $treeModBtn = ($options{-itemModBtn}) ? $options{-itemModBtn} : ['Control', 2]; return unless &compatseq($treeModBtn); return unless &compatkey($treeKey); + $options{-optionsFormat} = 'column' unless $options{-optionsFormat}; + if ($options{-optionsFormat} ne 'row' and $options{-optionsFormat} ne 'column') { + carp "in ZincDebug module, tree() function, expected values for ". + "-optionsFormat are 'row' or 'column'. Option is set to 'column'\n"; + $options{-optionsFormat} = 'column'; + } # # binding for help screen # @@ -64,12 +80,16 @@ sub tree { # # binding for building tree # - $zinc->toplevel->Tk::bind('<'.$treeKey.'>', \&showtree); + $zinc->toplevel->Tk::bind('<'.$treeKey.'>', + [\&showtree, $options{-optionsToDisplay}, + $options{-optionsFormat}]); # # binding for displaying item in tree # my $tkb = $treeModBtn; - $zinc->Tk::bind('<'.$tkb->[0]."-".$tkb->[1].'>', \&findintree); + $zinc->Tk::bind('<'.$tkb->[0]."-".$tkb->[1].'>', + [\&findintree, $options{-optionsToDisplay}, + $options{-optionsFormat}]); } # end tree @@ -159,8 +179,10 @@ sub snapshot { # #--------------------------------------------------------------------------- sub findintree { + my $optionstodisplay = $_[1]; + my $optionsFormat = $_[2]; if (not Tk::Exists($tree_tl)) { - &showtree; + &showtree(undef, $optionstodisplay, $optionsFormat); } my $ev = $zinc->XEvent; ($x0, $y0) = ($ev->x, $ev->y); @@ -182,8 +204,14 @@ sub findintree { sub showtree { + my $optionstodisplay = $_[1]; + my $optionsFormat = $_[2]; + $WARNING = 0; + my @optionstodisplay = split(/,/, $optionstodisplay); + $WARNING = 1; $tree_tl->destroy if $tree_tl and Tk::Exists($search_tl); $tree_tl = $zinc->Toplevel; + $tree_tl->minsize(280, 200); $tree_tl->title("Zinc Items Tree"); $tree = $tree_tl->Scrolled('Tree', -scrollbars => 'se', @@ -229,21 +257,25 @@ sub showtree { }, Ev('y')]); $tree->add("1", -text => "Group(1)", -state => 'disabled'); - &scangroup($tree, 1, "1",); + &scangroup($tree, 1, "1", $optionsFormat, @optionstodisplay); $tree->autosetmode; # control buttons frame my $tree_butt_fm = $tree_tl->Frame(-height => 40)->pack(-side => 'bottom', - -expand => 1, - -fill => 'both'); + -fill => 'y'); $tree_butt_fm->Button(-text => 'Help', -command => \&showHelpAboutTree, )->pack(-side => 'left', -pady => 10, -padx => 30, -fill => 'both'); + $tree_butt_fm->Button(-text => 'Search', + -command => \&searchInTree, + )->pack(-side => 'left', -pady => 10, + -padx => 30, -fill => 'both'); + $tree_butt_fm->Button(-text => 'Close', -command => sub {$zinc->remove("zincdebug"); $tree_tl->destroy}, - )->pack(-side => 'right', -pady => 10, + )->pack(-side => 'left', -pady => 10, -padx => 30, -fill => 'both'); # pack tree $tree->pack(-padx => 10, -pady => 10, @@ -256,17 +288,129 @@ sub showtree { } # end showtree +sub searchInTree { + $searchtree_tl->destroy if $searchtree_tl and Tk::Exists($searchtree_tl); + $searchtree_tl = $zinc->Toplevel; + $searchtree_tl->title("Find in tree"); + my $fm = $searchtree_tl->Frame->pack(-side => 'top'); + $fm->Label(-text => "Find : ", + )->pack(-side => 'left', -padx => 10, -pady => 10); + my $entry = $fm->Entry(-width => 20)->pack(-side => 'left', + -padx => 10, -pady => 10); + my $status = $searchtree_tl->Label(-foreground => 'sienna', + )->pack(-side => 'top'); + my $ep = 1; + my $searchfunc = sub { + my $side = shift; + my $found = 0; + #print "ep=$ep side=$side\n"; + $status->configure(-text => ""); + $status->update; + $searchTreeEntryValue = $entry->get(); + $searchTreeEntryValue = quotemeta($searchTreeEntryValue); + my $text; + while ($ep) { + $ep = $tree->info($side, $ep); + unless ($ep) { + $ep = 1; + $found = 1; + last; + } + $text = $tree->entrycget($ep, -text); + if ($text =~ /$searchTreeEntryValue/) { + $tree->see($ep); + $tree->selectionClear; + $tree->anchorSet($ep); + $tree->selectionSet($ep); + $found = 1; + last; + } + } + $status->configure(-text => "Search string not found") unless $found; + }; + + my $fm2 = $searchtree_tl->Frame->pack(-side => 'top'); + $fm2->Button(-text => 'Prev', + -command => sub {&$searchfunc('prev');}, + )->pack(-side => 'left', -pady => 10); + $fm2->Button(-text => 'Next', + -command => sub {&$searchfunc('next');}, + )->pack(-side => 'left', -pady => 10); + $fm2->Button(-text => 'Close', + -command => sub {$searchtree_tl->destroy}, + )->pack(-side => 'right', -pady => 10); + $entry->focus; + $entry->delete(0, 'end'); + $entry->insert(0, $searchTreeEntryValue) if $searchTreeEntryValue; + $entry->bind('', sub {&$searchfunc('next');}); + +} # end searchInTree + +sub extractinfo { + my $item = shift; + my $format = shift; + my $option = shift; + my $titleflag = shift; + $option =~ s/^\s+//; + $option =~ s/\s+$//; + #print "option=[$option]\n"; + my @info; + $WARNING = 0; + eval {@info = $zinc->itemcget($item, $option)}; + #print "eval $option = (@info) $@\n"; + return if $@; + return if @info == 0; + my $info; + my $sep = ($format eq 'column') ? "\n " : ", "; + if ($titleflag) { + $info = $sep."[$option] ".$info[0]; + } else { + $info = $sep.$info[0]; + } + if (@info > 1) { + shift(@info); + for (@info) { + if ($format eq 'column') { + if (length($info." ".$_) > 40) { + if ($titleflag) { + $info .= $sep."[$option] ".$_; + } else { + $info .= $sep.$_; + } + } else { + $info .= ", $_"; + } + } else { + $info .= $sep.$_; + } + } + } + $WARNING = 1; + return $info; +} sub scangroup { - my ($tree, $group, $path) = @_; + my ($tree, $group, $path, $format, @optionstodisplay) = @_; 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)"); + my $info = " "; + if (@optionstodisplay == 1) { + $info .= &extractinfo($item, $format, $optionstodisplay[0]); + } elsif (@optionstodisplay > 1) { + for my $opt (@optionstodisplay) { + $info .= &extractinfo($item, $format, $opt, 1); + } + } if ($type eq "Group") { - &scangroup($tree, $item, $path.".".$item); + $tree->add($path.".".$item, + -text => "$type($item)$info", + -style => 'group'); + &scangroup($tree, $item, $path.".".$item, $format, @optionstodisplay); + } else { + $tree->add($path.".".$item, + -text => "$type($item)$info", + -style => 'item'); } } @@ -421,6 +565,9 @@ sub setwidget { } else { $zinc = $widget; } + $zinc->update; + my $geom = $zinc->geometry =~ /(\d+)x(\d+)+/=~ /(\d+)x(\d+)+/; + ($wwidth, $wheight) = ($1, $2); } # end setwidget @@ -487,10 +634,13 @@ sub showresult { # scrolled pane creation my $heightmax = 500; my $height = 100 + 50*@items; + my $width = $result_tl->screenwidth; + $width = 1200 if $width > 1200; $height = $heightmax if $height > $heightmax; $result_fm = $result_tl->Scrolled('Pane', - -scrollbars => 'se', - -width => scalar $result_tl->screenwidth, + -scrollbars => 'soeo', + -gridded => 'xy', + -width => $width, -height => $height, ); $result_fm->pack(-padx => 10, -pady => 10, @@ -501,6 +651,7 @@ sub showresult { # attributes display &showattributes($result_fm, \@items); + } # end showresult @@ -785,6 +936,91 @@ sub highlightitem { } # end highlightitem +sub itemisoutside { + my @bbox = @_; + my $outflag; + if ($bbox[2] < 0) { + if ($bbox[1] > $wheight) { + $outflag = 'left+bottom'; + } elsif ($bbox[3] < 0) { + $outflag = 'left+top'; + } else { + $outflag = 'left'; + } + } elsif ($bbox[0] > $wwidth) { + if ($bbox[1] > $wheight) { + $outflag = 'right+bottom'; + } elsif ($bbox[3] < 0) { + $outflag = 'right+top'; + } else { + $outflag = 'right'; + } + } elsif ($bbox[3] < 0) { + $outflag = 'top'; + } elsif ($bbox[1] > $wheight) { + $outflag = 'bottom'; + } + #print "outflag=$outflag bbox=@bbox\n"; + return 0 unless $outflag; + my $g = $zinc->add('group', 1); + my $hw = 110; + my $hh = 80; + my $r = 5; + $zinc->add('rectangle', $g, [-$hw, -$hh, $hw, $hh], + -filled => 1, + -linecolor => 'sienna', + -linewidth => 3, + -tags => ['zincdebug'], + -fillcolor => 'bisque', + -priority => 1, + ); + $zinc->add('text', $g, + -position => [0, 0], + -color => 'sienna', + -font => '-b&h-lucida-bold-i-normal-sans-34-240-*-*-p-*-iso8859-1', + -anchor => 'center', + -tags => ['zincdebug'], + -priority => 2, + -text => "Item is\noutside\nwindow\n"); + my ($x, $y); + if ($outflag eq 'bottom') { + $x = $bbox[0] + ($bbox[2]-$bbox[0])/2; + $x = $hw + 10 if $x < $hw + 10; + $x = $wwidth - $hw - 10 if $x > $wwidth - $hw - 10; + $y = $wheight - $hh - 10; + } elsif ($outflag eq 'top') { + $x = $bbox[0] + ($bbox[2]-$bbox[0])/2; + $x = $hw + 10 if $x < $hw + 10; + $x = $wwidth - $hw - 10if $x > $wwidth - $hw - 10; + $y = $hh + 10; + } elsif ($outflag eq 'left') { + $x = $hw + 10; + $y = $bbox[1] + ($bbox[3]-$bbox[1])/2; + $y = $hh + 10 if $y < $hh + 10; + $y = $wheight - $hh - 10 if $y > $wheight - $hh - 10; + } elsif ($outflag eq 'right') { + $x = $wwidth - $hw - 10; + $y = $bbox[1] + ($bbox[3]-$bbox[1])/2; + $y = $hh + 10 if $y < $hh + 10; + $y = $wheight - $hh - 10 if $y > $wheight - $hh - 10; + } elsif ($outflag eq 'left+top') { + $x = $hw + 10; + $y = $hh + 10; + } elsif ($outflag eq 'left+bottom') { + $x = $hw + 10; + $y = $wheight - $hh - 10; + } elsif ($outflag eq 'right+top') { + $x = $wwidth - $hw - 10; + $y = $hh + 10; + } elsif ($outflag eq 'right+bottom') { + $x = $wwidth - $hw - 10; + $y = $wheight - $hh - 10; + } + $zinc->coords($g, [$x, $y]); + $zinc->raise('zincdebug'); + +} # end itemisoutside + # draw a rectangle arround the selected item sub surrounditem { @@ -811,32 +1047,36 @@ sub surrounditem { # move in topgroup $zinc->chggroup($clone, $topgroup); # create a rectangle around - my @bbox = $zinc->bbox($clone); - if (scalar @bbox == 4) { - @bbox = $zinc->transform(1, $topgroup, [@bbox]); - if ($level > 0) { - my $r = $zinc->add('Rectangle', $topgroup, - [$bbox[0] - 10, $bbox[1] - 10, - $bbox[2] + 10, $bbox[3] + 10], - -filled => 1, - -tags => ['zincdebug'], - -fillcolor => "gray20"); - $zinc->itemconfigure($r, -fillcolor => "gray80") if $level == 1; - } - my $i = 0; - for ('white', 'red', 'white') { - $zinc->add('rectangle', $topgroup, - [$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++; + my @bbox0 = $zinc->bbox($clone); + if (scalar @bbox0 == 4) { + my @bbox = $zinc->transform(1, $topgroup, [@bbox0]); + # If item is visible, rectangle is drawm surround it. + # Else, a warning is displayed. + unless (&itemisoutside(@bbox0)) { + if ($level > 0) { + my $r = $zinc->add('Rectangle', $topgroup, + [$bbox[0] - 10, $bbox[1] - 10, + $bbox[2] + 10, $bbox[3] + 10], + -filled => 1, + -tags => ['zincdebug'], + -fillcolor => "gray20"); + $zinc->itemconfigure($r, -fillcolor => "gray80") if $level == 1; + } + my $i = 0; + for ('white', 'red', 'white') { + $zinc->add('rectangle', $topgroup, + [$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'); - $zinc->raise($clone); + $zinc->raise($clone); } # end surrounditem @@ -996,6 +1236,8 @@ sub showattributes { $i++; &showbanner($fm, $i++) if ($i % 15 == 0); } + $fm->update; + return ($fm->width, $fm->height); } # end showattributes @@ -1264,6 +1506,15 @@ Defines input sequence used to build and display items tree. Default to 'Control 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]. +=item E<32>E<32>E<32>B<-optionsToDisplay> => opt1[,..,optN] + +Used to display some option's values associated to items of tree. Expected argument is a string of commas separated options. + + +=item E<32>E<32>E<32>B<-optionsFormat> => row | column + +Defines the display format of option's values. Default is 'column'. + =back -- cgit v1.1