aboutsummaryrefslogtreecommitdiff
path: root/Perl/Zinc/Debug.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Perl/Zinc/Debug.pm')
-rw-r--r--Perl/Zinc/Debug.pm127
1 files changed, 119 insertions, 8 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index b50acf0..f831c58 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -15,8 +15,6 @@ use Carp;
use English;
require Exporter;
use File::Basename;
-use Tk;
-use Tk::Zinc;
use Tk::LabFrame;
use Tk::Pane;
use Tk::Dialog;
@@ -27,9 +25,9 @@ use Tk::ItemStyle;
@EXPORT = qw(finditems snapshot tree);
@EXPORT_OK = qw(finditems snapshot tree);
-my ($itemstyle, $groupstyle);
+my ($itemstyle, $groupstyle, $step);
my (%help_tl, $result_tl, $result_fm, $search_tl, $helptree_tl, $coords_tl,
- $searchtree_tl, $tree_tl, $tree);
+ $searchtree_tl, $tree_tl, $tree, $transfo_tl);
my $showitemflag;
my ($x0, $y0);
my ($help_print, $imagecounter, $saving) = (0, 0, 0);
@@ -53,6 +51,7 @@ my @instances;
my %cmdoptions;
my $initobjectfunction;
+
sub BEGIN {
# test if ZincDebug is loaded using the -M perl option
$preload = 1 if (caller(2))[2] == 0;
@@ -67,10 +66,13 @@ sub BEGIN {
);
# save current Tk::Zinc::InitObject function; it will be invoked in
# overloaded one (see below)
+ use Tk;
+ use Tk::Zinc;
$initobjectfunction = Tk::Zinc->can('InitObject');
}
+
# Hack to capture the instance of zinc. ZincDebug functions are invoked here.
# Note that created bindings might be overloaded by the application.
sub Tk::Zinc::InitObject {
@@ -103,9 +105,11 @@ sub Tk::Zinc::InitObject {
push (@options, -verbosity => $cmdoptions{verbosity}) if $cmdoptions{verbosity};
push (@options, -basename => $cmdoptions{basename}) if $cmdoptions{basename};
&snapshot($zinc, @options);
+
}
+
#---------------------------------------------------------------------------
# tree : display items hierarchy
#---------------------------------------------------------------------------
@@ -810,6 +814,7 @@ sub showotheroptions {
} # end showotheroptions
+
sub showdevicecoords {
my ($zinc, $item) = @_;
&showcoords($zinc, $item, 1);
@@ -934,11 +939,18 @@ sub showgroupattributes {
-height => 2,
-text => 'Content',
)->grid(-row => $r, -col => 1, -sticky => 'nswe');
+ # bounding box
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]);
+ # transformations
+ my $btn = $fm->Button(-text => "treset")
+ ->grid(-row => $r++, -col => 1, -sticky => 'nswe', -columnspan => 2);
+ $btn->bind('<1>', [\&showtransfo, $zinc, $item, 0]);
+ $btn->bind('<2>', [\&showtransfo, $zinc, $item, 1]);
+ $btn->bind('<3>', [\&showtransfo, $zinc, $item, 2]);
# parent group
$fm->Label(-text => 'Parent group', -relief => 'ridge')
@@ -1068,7 +1080,7 @@ sub showgroupcontent {
-ipadx => 10,
-expand => 1,
-fill => 'both');
- &showattributes($zinc, $fm, \@items);
+ &showattributes($zinc, $fm, [@items]);
} # end showgroupcontent
@@ -1083,10 +1095,8 @@ sub showbbox {
my $i = -2;
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],
[$bbox[0] + $i, $bbox[1] + $i,
- $bbox[2] - $i, $bbox[3] + $i],
+ $bbox[2] - $i, $bbox[3] - $i],
-linecolor => $_,
-linewidth => 1,
-tags => ['zincdebugbbox']);
@@ -1120,6 +1130,19 @@ sub highlightitem {
} # end highlightitem
+
+sub showtransfo {
+ my ($btn, $zinc, $item, $level) = @_;
+
+ my $anim = &highlighttransfo($zinc, $item, $level);
+
+ $btn->bind('<ButtonRelease>', [\&undohighlighttransfo, $zinc, $anim]) if $btn;
+
+} # end showtransfo
+
+
+
+
sub itemisoutside {
my $zinc = shift;
my @bbox = @_;
@@ -1207,6 +1230,86 @@ sub itemisoutside {
} # end itemisoutside
+sub highlighttransfo {
+ my ($zinc, $item, $level) = @_;
+ $zinc->remove("zincdebug");
+ my $g = $zinc->add('group', 1);
+ my $g0 = $zinc->add('group', $g, -alpha => 0);
+ my $g1 = $zinc->add('group', $g);
+ # clone item and reset its transformation
+ my $clone0 = $zinc->clone($item, -visible => 1, -tags =>['zincdebug']);
+ $zinc->treset($clone0);
+ # clone item and preserve its transformation
+ my $clone1 = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']);
+ # move clones is dedicated group
+ $zinc->chggroup($clone0, $g0, 1);
+ $zinc->chggroup($clone1, $g1, 1);
+ # create a rectangle around
+ my @bbox0 = $zinc->bbox($g);
+ if (scalar @bbox0 == 4) {
+ my @bbox = $zinc->transform(1, $g, [@bbox0]);
+ # If item is visible, rectangle is drawm surround it.
+ # Else, a warning is displayed.
+ unless (&itemisoutside($zinc, @bbox0)) {
+ my $r = $zinc->add('Rectangle', $g,
+ [$bbox[0] - 10, $bbox[1] - 10,
+ $bbox[2] + 10, $bbox[3] + 10],
+ -filled => 1,
+ -linewidth => 0,
+ -tags => ['zincdebug'],
+ -fillcolor => "gray90");
+ $zinc->itemconfigure($r, -fillcolor => "gray50") if $level == 1;
+ $zinc->itemconfigure($r, -fillcolor => "gray20") if $level == 2;
+ my $i = 0;
+ for ('white', 'green', 'white') {
+ $zinc->add('rectangle', $g,
+ [$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($clone0);
+ $zinc->raise($clone1);
+ # animation
+ my $anim;
+ if ($zinc->cget(-render) == 0) {
+ $anim = $zinc->after(150, [sub {
+ $zinc->itemconfigure($g1, -visible => 0);
+ $zinc->itemconfigure($g0, -visible => 1);
+ }]);
+ } else {
+ my $maxsteps = 5;
+ $step = $maxsteps;
+ $anim = $zinc->repeat(150, [sub {
+ return if $step < 0;
+ $zinc->itemconfigure($g1, -alpha => ($step)*100/$maxsteps);
+ $zinc->itemconfigure($g0, -alpha => ($maxsteps-$step)*100/$maxsteps);
+ $zinc->update;
+ $step--;
+ }]);
+
+
+ }
+ return $anim;
+
+} # end highlighttransfo
+
+
+sub undohighlighttransfo {
+ my ($btn, $zinc, $anim) = @_;
+ $btn->bind('ReleaseButton', '');
+ $zinc->remove('zincdebug');
+ $zinc->afterCancel($anim);
+
+} # end undohighlightitem
+
+
# draw a rectangle arround the selected item
sub surrounditem {
my ($zinc, $item, $level) = @_;
@@ -1241,6 +1344,7 @@ sub surrounditem {
my $r = $zinc->add('Rectangle', $topgroup,
[$bbox[0] - 10, $bbox[1] - 10,
$bbox[2] + 10, $bbox[3] + 10],
+ -linewidth => 0,
-filled => 1,
-tags => ['zincdebug'],
-fillcolor => "gray20");
@@ -1317,6 +1421,12 @@ sub showattributes {
&showbanner($fm, $i++);
for my $item (@$items) {
my $type = $zinc->type($item);
+ # transformations
+ my $btn = $fm->Button(-text => 'treset')
+ ->grid(-row => $i, -col => 0, -sticky => 'nswe', -ipadx => 5);
+ $btn->bind('<1>', [\&showtransfo, $zinc, $item, 0]);
+ $btn->bind('<2>', [\&showtransfo, $zinc, $item, 1]);
+ $btn->bind('<3>', [\&showtransfo, $zinc, $item, 2]);
# id
my $idbtn =
$fm->Button(-text => $item,
@@ -1422,6 +1532,7 @@ sub showattributes {
$fm->Label(-text => join("\n", @tags),
-relief => 'ridge')
->grid(-row => $i, -col => 10, -sticky => 'nswe', -ipadx => 5);
+ # other options
$fm->Button(-text => 'Other options',
-command => [\&showotheroptions, $zinc, $item, $fm])
->grid(-row => $i, -col => 11, -sticky => 'nswe', -ipadx => 5);