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/ZincDebug.pm | 563 ------------------------------------------------------ 1 file changed, 563 deletions(-) delete mode 100644 Perl/ZincDebug.pm (limited to 'Perl/ZincDebug.pm') diff --git a/Perl/ZincDebug.pm b/Perl/ZincDebug.pm deleted file mode 100644 index 25b3fb1..0000000 --- a/Perl/ZincDebug.pm +++ /dev/null @@ -1,563 +0,0 @@ -# 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. - -More comments please... - -=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