aboutsummaryrefslogtreecommitdiff
path: root/Perl/ZincDebug.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Perl/ZincDebug.pm')
-rw-r--r--Perl/ZincDebug.pm563
1 files changed, 0 insertions, 563 deletions
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 <etienne@cena.fr>
-#
-# $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('<Key-Escape>', [\&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 <Escape> 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<finditems> 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<finditems>($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 <etienne@cena.fr>
generated by cgit v1.1 at 2024-11-03 02:21:28 +0000