From 938b499c721a0ce0d3ef098c26ad1a5e2569463a Mon Sep 17 00:00:00 2001
From: etienne
Date: Wed, 26 Jun 2002 10:55:27 +0000
Subject: *** empty log message ***

---
 Perl/Zinc/Debug.pm | 54 ++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 36 insertions(+), 18 deletions(-)

(limited to 'Perl/Zinc')

diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index 0dc6ca0..dd792a1 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -44,9 +44,12 @@ sub finditems {
     my $ekb = ($options{-enclosedModBtn}) ? $options{-enclosedModBtn} :	['Control', 3];
     my $okb = ($options{-overlapModBtn}) ? $options{-overlapModBtn} : ['Shift', 3];
     my $pkb = ($options{-printModBtn}) ? $options{-printModBtn} : ['Control-Shift', 2];
-    my $snapshotVerbosity = (defined $options{-snapshotVerbosity}) ? $options{-snapshotVerbosity} : 1;
-    my $snapshotBasename = ($options{-snapshotBasename}) ? $options{-snapshotBasename} : "zincsnapshot";
-    carp "in ZincDebug module, finditems function, enclosed search and zinc snapshot won't work because ".
+    my $snapshotVerbosity = (defined $options{-snapshotVerbosity}) ?
+	$options{-snapshotVerbosity} : 1;
+    my $snapshotBasename = ($options{-snapshotBasename}) ?
+	$options{-snapshotBasename} : "zincsnapshot";
+    carp "in ZincDebug module, finditems function, enclosed search and ".
+	"zinc snapshot won't work because ".
 	"two of them use the same sequence.\n" .
 	    "enclose : [$ekb->[0], $ekb->[1]]\n" .
 		"overlap [$okb->[0], $okb->[1]]\n" .
@@ -78,7 +81,8 @@ sub finditems {
 		    [\&stoprectangle, 'overlapping', 'Overlap search']);
     #
     # binding for printing a full zinc window
-    $zinc->Tk::bind("<".$pkb->[0]."-B".$pkb->[1]."-ButtonRelease>", [\&printWindow , $snapshotBasename, $snapshotVerbosity]);
+    $zinc->Tk::bind("<".$pkb->[0]."-B".$pkb->[1]."-ButtonRelease>",
+		    [\&printWindow , $snapshotBasename, $snapshotVerbosity]);
 }
 
 #------------------------------------------------------------------------------------
@@ -106,7 +110,7 @@ sub showresult {
 # display in a toplevel the value of other options
 sub showotheroptions {
     my ($zinc, $item) = @_;
-    my $tl = MainWindow->new()->toplevel;
+    my $tl = $zinc->Toplevel;
     my $title = "Other options of item $item";
     $tl->title($title);
     my $fm = $tl->LabFrame(-labelside => 'acrosstop',
@@ -140,7 +144,7 @@ sub showotheroptions {
 
 sub showgroupattributes {
     my ($zinc, $item) = @_;
-    my $tl = MainWindow->new()->toplevel;
+    my $tl = $zinc->Toplevel;
     my $title = "About group $item";
     $tl->title($title);
     my $fm = $tl->LabFrame(-labelside => 'acrosstop',
@@ -149,13 +153,19 @@ sub showgroupattributes {
 				   -ipadx => 10,
 				   -fill => 'both');
     my $r = 1;
+    # content
+    $fm->Button(-command => [\&showgroupcontent, $zinc, $item],
+		-text => 'Content',
+		)->grid(-row => $r++, -col => 1, -columnspan => 2, -sticky => 'nswe');
     # 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])
+    my $bpg = $fm->Button(-text => $gr,
+			  -command => [\&showgroupattributes, $zinc, $gr])
 	->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
+    $bpg->configure(-disabledforeground => scalar $bpg->cget(-foreground),
+		    -state => 'disabled') if $gr == $item;
     my $bgcolor = 'ivory';
     # coords
     $fm->Label(-text => 'Coordinates', -background => $bgcolor, -relief => 'ridge')
@@ -239,20 +249,25 @@ sub showgroupattributes {
 # display in a toplevel the content of a group item
 sub showgroupcontent {
     my ($zinc, $group) = @_;
-    my $tl = MainWindow->new()->toplevel;
+    my $tl = $zinc->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);
+      my $fm = $tl->Scrolled('Pane',
+  			   -scrollbars => 'se',
+  			   -width => scalar $result_tl->screenwidth,
+  			   -height => 200,
+  			   -label => $title,
+  			   )->pack(-padx => 10, -pady => 10,
+  				   -ipadx => 10,
+				   -expand => 1,
+  				   -fill => 'both');
+    my @items = $zinc->find('withtag', $group.".");
     &showattributes($fm, \@items);
     $tl->Button(-text => 'Close',
 		-command => sub {$tl->destroy})->pack;    
 }
 
+
 # highlight an item (by cloning it and hiding other found items)
 # why cloning? because we can't simply make visible an item which
 # belongs to an invisible group.
@@ -263,7 +278,7 @@ sub highlightitem {
 
     my @itemstohide = ();
     my @visibility = ();
-    for ($zinc->find('overlap', $zinc->coords($rectangle_id))) {
+    for ($zinc->find('overlapping', $zinc->coords($rectangle_id))) {
 	push (@itemstohide, $_) unless $_ == $rectangle_id or $_ == $text_id;
     }
     for (@itemstohide) {
@@ -276,10 +291,11 @@ sub highlightitem {
     $zinc->coords($clone, [$zinc->transform(scalar $zinc->group($item), 1, [@coords])]);
     $zinc->raise($clone);
     $btn->bind('<ButtonRelease>', [\&undohighlightitem, $zinc, $clone,
-				 \@itemstohide, \@visibility]);
+  				 \@itemstohide, \@visibility]);
 
 }
 
+
 sub undohighlightitem {
     my ($btn, $zinc, $clone, $itemstohide, $visibility) = @_;
     $btn->bind('ReleaseButton', '');
@@ -290,6 +306,7 @@ sub undohighlightitem {
     $showitemflag = 0;
 }
 
+
 # print a zinc window in png format
 sub printWindow {
     exit if $saving;
@@ -495,8 +512,9 @@ sub showattributes {
 sub startrectangle {
     my ($widget, $style, $text, $color) = @_;
     if (not $result_tl or not Tk::Exists($result_tl)) {
-	$result_tl = MainWindow->new()->toplevel();
+	$result_tl = $zinc->Toplevel();
 	$result_tl->title("Zinc Debug");
+	$result_tl->geometry('+10+10');
 	$result_tl->Button(-text => 'Close',
 			   -command => sub {
 			       $result_tl->destroy;
-- 
cgit v1.1