From 2cf1a84fa1d536d55e92ba79a1d6aa2fe962c8ab Mon Sep 17 00:00:00 2001 From: etienne Date: Wed, 23 Jan 2002 16:44:18 +0000 Subject: *** empty log message *** --- Perl/Zinc/Debug.pm | 562 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 562 insertions(+) create mode 100644 Perl/Zinc/Debug.pm (limited to 'Perl/Zinc/Debug.pm') diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm new file mode 100644 index 0000000..937653c --- /dev/null +++ b/Perl/Zinc/Debug.pm @@ -0,0 +1,562 @@ +# ZincDebug Perl Module : +# +# For debugging/analysing a Zinc application +# +# Author : Daniel Etienne +# +# $Id$ +#--------------------------------------------------------------------------- +package ZincDebug; + + +use strict 'vars'; +use vars qw(@ISA @EXPORT); +use Carp; +require Exporter; +use File::Basename; +use Tk::Zinc; +use Tk::LabFrame; +use Tk::Pane; +use Tk::Dialog; + +@ISA = qw(Exporter); +@EXPORT = qw(finditems); + +my ($help_tl0, $help_tl, $result_tl, $result_fm, $showitemflag); +my ($text_id, $rectangle_id); +my ($x0, $y0); +my $zinc; + +sub finditems { + $zinc = shift; + # options + my %options = @_; + for my $opt (keys(%options)) { + carp "in ZincDebug module, finditems function, unknown option $opt\n" + unless ($opt eq '-color' or $opt eq '-enclosedModBtn' or + $opt eq '-overlapModBtn' ); + } + my $color = ($options{-color}) ? $options{-color} : 'sienna'; + my $ekb = ($options{-enclosedModBtn}) ? $options{-enclosedModBtn} : ['Control', 3]; + my $okb = ($options{-overlapModBtn}) ? $options{-overlapModBtn} : ['Shift', 3]; + carp "in ZincDebug module, finditems function, enclosed search won't work because ". + "both search process use the same sequence [$ekb->[0], $ekb->[1]]\n" if + $ekb->[0] eq $okb->[0] and $ekb->[1] eq $okb->[1]; + # + # binding for help screen + # + $zinc->toplevel->Tk::bind('', [\&showhelp, $ekb, $okb]); + # + # bindings for Enclosed search + # + $zinc->Tk::bind("<".$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>", + [\&stoprectangle, 'enclosed', 'Enclosed search']); + # + # bindings for Overlap search + # + $zinc->Tk::bind("<".$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>", + [\&stoprectangle, 'overlapping', 'Overlap search']); +} + +#------------------------------------------------------------------------------------ +# display in a toplevel the result of search +sub showresult { + my ($label, $zinc, @items) = @_; + $result_fm->destroy if Tk::Exists($result_fm); + $result_fm = $result_tl->Scrolled('Pane', + -scrollbars => 'se', + -width => scalar $result_tl->screenwidth, + -height => 500, + ); + + $result_fm->pack(-padx => 10, -pady => 10, + -ipadx => 10, + -fill => 'both', + -expand => 1, + ); + &showattributes($result_fm, \@items); + $result_tl->deiconify; + $result_tl->update; +} + + +# display in a toplevel the value of other options +sub showotheroptions { + my ($zinc, $item) = @_; + my $tl = MainWindow->new()->toplevel; + my $title = "Other options of item $item"; + $tl->title($title); + my $fm = $tl->LabFrame(-labelside => 'acrosstop', + -label => $title, + )->pack(-padx => 10, -pady => 10, + -ipadx => 10, + -fill => 'both'); + my $bgcolor = 'ivory'; + $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => 1, -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'); + + my @options = $zinc->itemconfigure($item); + my $i = 2; + for my $elem (@options) { + my ($option, $value) = (@$elem)[0,4]; + next if ($option eq '-visible' or $option eq '-sensitive' or + $option eq '-tags' or $option eq '-position' or + $option eq '-priority'); + $fm->Label(-text => $option, -relief => 'ridge') + ->grid(-row => $i, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => $value, -relief => 'ridge') + ->grid(-row => $i, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $i++; + } + $tl->Button(-text => 'Close', + -command => sub {$tl->destroy})->pack; + +} + +sub showgroupattributes { + my ($zinc, $item) = @_; + my $tl = MainWindow->new()->toplevel; + my $title = "About group $item"; + $tl->title($title); + my $fm = $tl->LabFrame(-labelside => 'acrosstop', + -label => $title, + )->pack(-padx => 10, -pady => 10, + -ipadx => 10, + -fill => 'both'); + my $r = 1; + # parent group + $fm->Label(-text => 'Parent group', -relief => 'ridge') + ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + my $gr = $zinc->group($item); + $fm->Button(-text => $gr, + -command => [\&showgroupattributes, $zinc, $gr]) + ->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + my $bgcolor = 'ivory'; + # coords + $fm->Label(-text => 'Coordinates', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $r++, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe', + -columnspan => 2); # coords + $fm->Label(-text => 'Coords', -relief => 'ridge') + ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + my @coords = $zinc->coords($item); + my $coords; + if (@coords == 2) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + $coords = "($x0, $y0)"; + } elsif (@coords == 4) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $x1 = int($coords[2]); + my $y1 = int($coords[3]); + $coords = "($x0, $y0, $x1, $y1)"; + } else { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $xn = int($coords[$#coords-1]); + my $yn = int($coords[$#coords]); + my $n = @coords/2 - 1; + $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + } + $fm->Label(-text => $coords, -relief => 'ridge') + ->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + # device coords + $fm->Label(-text => 'Device coords', -relief => 'ridge') + ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + @coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords]); + if (@coords == 2) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + $coords = "($x0, $y0)"; + } elsif (@coords == 4) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $x1 = int($coords[2]); + my $y1 = int($coords[3]); + $coords = "($x0, $y0, $x1, $y1)"; + } else { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $xn = int($coords[$#coords-1]); + my $yn = int($coords[$#coords]); + my $n = @coords/2 - 1; + $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + } + $fm->Label(-text => $coords, -relief => 'ridge') + ->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + + # options + $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Value', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + + my @options = $zinc->itemconfigure($item); + for my $elem (@options) { + my ($option, $value) = (@$elem)[0,4]; + $fm->Label(-text => $option, -relief => 'ridge') + ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + if ($option eq '-tags') { + $value = join("\n", @$value); + } elsif ($option eq '-clip' and $value > 0) { + $value .= " (". $zinc->type($value) .")"; + } + $fm->Label(-text => $value, -relief => 'ridge') + ->grid(-row => $r, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $r++; + } + $tl->Button(-text => 'Close', + -command => sub {$tl->destroy})->pack; + +} + + +# display in a toplevel the content of a group item +sub showgroupcontent { + my ($zinc, $group) = @_; + my $tl = MainWindow->new()->toplevel; + my $title = "Content of group $group"; + $tl->title($title); + my $fm = $tl->LabFrame(-labelside => 'acrosstop', + -label => $title, + )->pack(-padx => 10, -pady => 10, + -ipadx => 10, + -fill => 'both'); + my @items = $zinc->find('all', $group); + &showattributes($fm, \@items); + $tl->Button(-text => 'Close', + -command => sub {$tl->destroy})->pack; +} + +# highlight an item (by hiding other found items) +sub highlightitem { + my ($zinc, $item) = @_; + return if $showitemflag; + $showitemflag = 1; + my @visibility; + + my @itemstohide; + for ($zinc->find('overlap', $zinc->coords($rectangle_id))) { + push (@itemstohide, $_) unless $_ == $rectangle_id or $_ == $text_id; + } + for (@itemstohide) { + push(@visibility, scalar $zinc->itemcget($_, -visible)); + $zinc->itemconfigure($_, -visible => 0); + } + my @coords = $zinc->coords($item); + my $clone = $zinc->clone($item, -visible => 1); + $zinc->chggroup($clone, 1); + $zinc->coords($clone, [$zinc->transform(scalar $zinc->group($item), 1, [@coords])]); + $zinc->raise($clone); + + $zinc->after(500, sub { + for (my $i=0; $i < @itemstohide; $i++) { + $zinc->itemconfigure($itemstohide[$i], -visible => $visibility[$i]); + } + $zinc->remove($clone); + $showitemflag = 0; + }); +} + +# highlight an item (by hiding other found items) +# here, item's option -visible is set to 1 and others items are +# hidden; but, if item belongs to a invisible group, we can't +# see it! +sub highlightitem_old { + my ($zinc, $item, $items) = @_; + return if $showitemflag; + $showitemflag = 1; + my @visibility; + for (@$items) { + push(@visibility, scalar $zinc->itemcget($_, -visible)); + $zinc->itemconfigure($_, -visible => 0); + } + $zinc->itemconfigure($item, -visible => 1); + + $zinc->after(500, sub { + for (my $i=0; $i < @$items; $i++) { + $zinc->itemconfigure($items->[$i], -visible => $visibility[$i]); + } + $showitemflag = 0; + }); +} + +# display complete help screen +sub showhelp { + my ($w, $ekb, $okb) = @_; + my $eseq = $ekb->[0]."-Button".$ekb->[1]; + my $oseq = $okb->[0]."-Button".$okb->[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". + "Strike 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; + my $i = shift; + my $bgcolor = 'ivory'; + $fm->Label(-text => 'Id', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Type', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Group', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 3, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Priority', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 4, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Sensitive', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 5, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Visible', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 6, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Coords', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 7, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Device coords', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 8, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Bounding box', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 9, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label(-text => 'Tags', -background => $bgcolor, -relief => 'ridge') + ->grid(-row => $i, -col => 10, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); + $fm->Label()->grid(-row => 1, -col => 11, -pady => 10); + +} + +# display in a grid the values of most important attributes +sub showattributes { + my ($fm, $items) = @_; + my $bgcolor = 'ivory'; + my $i = 1; + &showbanner($fm, $i++); + for my $item (@$items) { + # id + $fm->Button(-text => $item, + -foreground => 'red', + -command => [\&highlightitem, $zinc, $item]) + ->grid(-row => $i, -col => 1, -sticky => 'nswe', -ipadx => 5); + # type + my $type = $zinc->type($item); + if ($type eq 'group') { + $fm->Button(-text => $type, + -command => [\&showgroupcontent, $zinc, $item]) + ->grid(-row => $i, -col => 2, -sticky => 'nswe', -ipadx => 5); + } else { + $fm->Label(-text => $type, -relief => 'ridge') + ->grid(-row => $i, -col => 2, -sticky => 'nswe', -ipadx => 5); + } + # group + my $group = $zinc->group($item); + $fm->Button(-text => $group, + -command => [\&showgroupattributes, $zinc, $group]) + ->grid(-row => $i, -col => 3, -sticky => 'nswe', -ipadx => 5); + # priority + $fm->Label(-text => scalar $zinc->itemcget($item, -priority), + -relief => 'ridge') + ->grid(-row => $i, -col => 4, -sticky => 'nswe', -ipadx => 5); + # sensitiveness + $fm->Label(-text => scalar $zinc->itemcget($item, -sensitive), + -relief => 'ridge') + ->grid(-row => $i, -col => 5, -sticky => 'nswe', -ipadx => 5); + # visibility + $fm->Label(-text => scalar $zinc->itemcget($item, -visible), + -relief => 'ridge') + ->grid(-row => $i, -col => 6, -sticky => 'nswe', -ipadx => 5); + # coords + my @coords = $zinc->coords($item); + my $coords; + if (@coords == 2) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + $coords = "($x0, $y0)"; + } elsif (@coords == 4) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $x1 = int($coords[2]); + my $y1 = int($coords[3]); + $coords = "($x0, $y0, $x1, $y1)"; + } else { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $xn = int($coords[$#coords-1]); + my $yn = int($coords[$#coords]); + my $n = @coords/2 - 1; + $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + } + $fm->Label(-text => $coords, -relief => 'ridge') + ->grid(-row => $i, -col => 7, -sticky => 'nswe', -ipadx => 5); + # device coords + @coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords]); + if (@coords == 2) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + $coords = "($x0, $y0)"; + } elsif (@coords == 4) { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $x1 = int($coords[2]); + my $y1 = int($coords[3]); + $coords = "($x0, $y0, $x1, $y1)"; + } else { + my $x0 = int($coords[0]); + my $y0 = int($coords[1]); + my $xn = int($coords[$#coords-1]); + my $yn = int($coords[$#coords]); + my $n = @coords/2 - 1; + $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + } + $fm->Label(-text => $coords, -relief => 'ridge') + ->grid(-row => $i, -col => 8, -sticky => 'nswe', -ipadx => 5); + # bounding box + my @bbox = $zinc->bbox($item); + $fm->Label(-text => "($bbox[0], $bbox[1]), ($bbox[2], $bbox[3])", + -relief => 'ridge') + ->grid(-row => $i, -col => 9, -sticky => 'nswe', -ipadx => 5); + # tags + my @tags = $zinc->gettags($item); + $fm->Label(-text => join("\n", @tags), + -relief => 'ridge') + ->grid(-row => $i, -col => 10, -sticky => 'nswe', -ipadx => 5); + $fm->Button(-text => 'Other options', + -command => [\&showotheroptions, $zinc, $item]) + ->grid(-row => $i, -col => 11, -sticky => 'nswe', -ipadx => 5); + $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 = MainWindow->new()->toplevel(); + $result_tl->title("Zinc Debug"); + $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, + ); + +} + +# resize the rectangular area for search +sub resizerectangle { + my $ev = $zinc->XEvent; + my ($x, $y) = ($ev->x, $ev->y); + $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); +} + +# stop drawing rectangular area for search +sub stoprectangle { + my ($widget, $searchtype, $text) = @_; + my @coords = $zinc->coords($rectangle_id); + my @items; + for my $item ($zinc->find($searchtype, @coords)) { + push (@items, $item) if $item != $rectangle_id and + $item != $text_id; + } + &showresult($text, $zinc, @items); + +} + +1; + +__END__ + + +=head1 NAME + +ZincDebug - a perl module for analysing a Zinc application. + + +=head1 SYNOPSIS + + use ZincDebug; + my $zinc = MainWindow->new()->Zinc()->pack; + finditems($zinc); + +=head1 DESCRIPTION + +ZincDebug provides an interface to help developers to debug or analyse Zinc applications. + +With B function, you are able to scan all items which are enclosed in a rectangular area you have first drawn, 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. + + +=head1 FUNCTIONS + + +=over + +=item B($zinc, ?option => value, ...?) + +This function creates required Tk bindings to permit items search. You can specify the following options : + +=over + +=item E<32>E<32>E<32>B<-color> => color + +Defines color of search area contour. Default to 'sienna'. + +=item E<32>E<32>E<32>B<-enclosedModBtn> => [Mod, Btn] + +Defines input sequence used to process "enclosed" search. Default to ['Control', 3]. + +=item E<32>E<32>E<32>B<-overlapModBtn> => [Mod, Btn] + +Defines input sequence used to process "overlap" search. Default to ['Shift', 3]. + + +=back + +=back + +=head1 AUTEURS + +Daniel Etienne -- cgit v1.1