Possibilit� de g�n�rer du code perl � partir de l'arbre des items,

en s�lectionnant une branche ou une feuille.
Mise � jour du man.
Mise � jour de l'aide en ligne

1 files changed, 210 insertions, 18 deletions

diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index 439290a..09d0ae9 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -10,7 +10,7 @@
 package ZincDebug;
 
 use strict 'vars';
-use vars qw(@ISA @EXPORT @EXPORT_OK $WARNING);
+use vars qw(@ISA @EXPORT @EXPORT_OK $WARNING $endoptions);
 use Carp;
 use English;
 require Exporter;
@@ -20,6 +20,7 @@ use Tk::Dialog;
 use Tk::Tree;
 use Tk::ItemStyle;
 use Tk::Pane;
+use Tk::FBox;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(finditems snapshot tree);
@@ -51,7 +52,6 @@ my @instances;
 my %cmdoptions;
 my $initobjectfunction;
 
-
 BEGIN {
     # test if ZincDebug is loaded using the -M perl option
     $preload = 1 if (caller(2))[2] == 0;
@@ -69,14 +69,13 @@ BEGIN {
     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 {
-    Tk::Widget::InitObject(@_);
     print "ZincDebug is ON\n";
     # invoke function possibly overloaded in other modules
     &$initobjectfunction(@_) if $initobjectfunction;
@@ -105,7 +104,6 @@ sub Tk::Zinc::InitObject {
     push (@options, -verbosity => $cmdoptions{verbosity}) if $cmdoptions{verbosity};
     push (@options, -basename => $cmdoptions{basename}) if $cmdoptions{basename};
     &snapshot($zinc, @options);
-      
 }
 
 
@@ -416,6 +414,11 @@ sub showtree {
 			  -command => [\&searchInTree, $zinc],
 			  )->pack(-side => 'left', -pady => 10,
 				  -padx => 30, -fill => 'both');
+    $tree_butt_fm->Button(-text => "Build\ncode",
+			  -command => [\&buildCode, $zinc, $tree],
+			  )->pack(-side => 'left', -pady => 10,
+				  -padx => 30, -fill => 'both');
+    
 
     $tree_butt_fm->Button(-text => 'Close',
 			  -command => sub {$zinc->remove("zincdebug");
@@ -434,6 +437,176 @@ sub showtree {
 } # end showtree
 
 
+sub buildCode {
+    my $zinc = shift;
+    my $tree = shift;
+    my @code;
+    push(@code, 'use Tk;');
+    push(@code, 'use Tk::Zinc;');
+    push(@code, 'my $mw = MainWindow->new();');
+    push(@code, 'my $zinc = $mw->Zinc(-render => '.$zinc->cget(-render).
+	 ')->pack(-expand => 1, -fill => both);');
+    push(@code, '# hash %items : keys are original items ID, values are built items ID');
+    push(@code, 'my %items;');
+    push(@code, '');
+    my $path = $tree->selectionGet;
+    $path = 1 unless $path;
+    my $item = (split(/\./, $path))[-1];
+    $endoptions = [];
+    if ($zinc->type($item) eq 'group') {
+	push(@code, &buildGroup($zinc, $item, 1));
+	for(@$endoptions) {
+	    my ($item, $option, $value) = @$_;
+	    push(@code,
+		 '$zinc->itemconfigure('.$item.', '.$option.' => '.$value.');');
+	}
+    } else {
+	push(@code, &buildItem($zinc, $item, 1));
+    }
+    push(@code, 'MainLoop;');
+    
+    my $file = $zinc->getSaveFile(-filetypes => [['Perl Files',   '.pl'],
+                                               ['All Files',   '*']],
+				  -initialfile => 'zincdebug.pl',
+				  -title => 'Save code',
+				  );
+    $zinc->Busy;
+    open (OUT, ">$file");
+    for (@code) {
+	print OUT $_."\n";
+    }
+    close(OUT);
+    $zinc->Unbusy;
+    
+} # end buildCode
+
+
+
+sub buildGroup {
+    my $zinc = shift;
+    my $item = shift;
+    my $group = shift;
+    my @code;
+    push(@code, '$items{'.$item.'}=$zinc->add("group", '.$group.', ');
+    # options
+    push(@code, &buildOptions($zinc, $item));
+    push(@code, ');');
+    push(@code, '');
+    push(@code, '$zinc->coords($items{'.$item.'}, ['.
+	 join(',', $zinc->coords($item)).']);');
+    my @items = $zinc->find('withtag', "$item.");
+    for my $it (reverse(@items)) {
+	if ($zinc->type($it) eq 'group') {
+	    push(@code, &buildGroup($zinc, $it, '$items{'.$item.'}'));
+	} else {
+	    push(@code, &buildItem($zinc, $it, '$items{'.$item.'}'));
+	}
+    }
+    return @code;
+
+} # end buildGroup
+
+
+sub buildItem {
+    my $zinc = shift;
+    my $item = shift;
+    my $group = shift;
+    my $type = $zinc->type($item);
+    my @code;
+    my $numfields = 0;
+    # type group and initargs
+    my $initstring = '$items{'.$item.'}=$zinc->add('.$type.', '.$group.', ';
+    if ($type eq 'tabular' or $type eq 'track' or $type eq 'waypoint') {
+	$numfields = $zinc->itemcget($item, -numfields);
+	$initstring .= $numfields.' ,';
+    } elsif ($type eq 'curve' or $type eq 'triangles' or
+	     $type eq 'arc' or $type eq 'rectangle') {
+	$initstring .= "[ ";
+	my (@coords) = $zinc->coords($item);
+	if (ref($coords[0]) eq 'ARRAY') {
+	    my @coords2;
+	    for my $c (@coords) {
+		if (@$c > 2) {
+		     push(@coords2, '['.$c->[0].', '.$c->[1].', "'.$c->[2].'"]');
+		} else {
+		     push(@coords2, '['.$c->[0].', '.$c->[1].']');
+		    
+		}
+	    }
+	    $initstring .= join(', ', @coords2);
+	} else {
+	    $initstring .= join(', ', @coords);
+	}
+	$initstring .= " ], ";
+    } 
+    push(@code, $initstring);
+    # options
+    push(@code, &buildOptions($zinc, $item));
+    push(@code, ');');
+    push(@code, '');
+    if ($numfields > 0) {
+    	for (my $i=0; $i < $numfields; $i++) {
+	    push(@code, &buildField($zinc, $item, $i));
+	}
+    }
+    return @code;
+
+} # end buildItem
+
+
+sub buildField {
+    my $zinc = shift;
+    my $item = shift;
+    my $field = shift;
+    my @code;
+    # type group and initargs
+    push(@code, '$zinc->itemconfigure($items{'.$item.'}, '.$field.', ');
+    # options
+    push(@code, &buildOptions($zinc, $item, $field));
+    push(@code, ');');
+    push(@code, '');
+    return @code;
+
+} # end buildField
+
+
+sub buildOptions {
+    my $zinc = shift;
+    my $item = shift;
+    my $field = shift;
+    my @code;
+    my @args = defined($field) ? ($item, $field) : ($item);
+    my @options = $zinc->itemconfigure(@args);
+    for my $elem (@options) {
+	my ($option, $type, $readonly, $value) = (@$elem)[0, 1, 2, 4];
+	next if $value eq '';
+	next if $readonly;
+	if ($type eq 'point') {
+	    push(@code, "           ".$option." => [".join(',', @$value)."], ");
+	    
+	} elsif (($type eq 'bitmap' or $type eq 'image') and $value !~ /^AtcSymbol/
+	    and $value !~ /^AlphaStipple/) {
+	    push(@code, "#           ".$option." => '".$value."', ");
+	    
+	} elsif ($type eq 'item') {
+	    $endoptions->[@$endoptions] =
+		['$items{'.$item.'}', $option, '$items{'.$value.'}'];
+	    
+	} elsif ($option eq '-text') {
+	    $value =~ s/\"/\\"/;       # comment for emacs legibility => "
+	    push(@code, "           ".$option.' => "'.$value.'", ');
+
+	} elsif (ref($value) eq 'ARRAY') {
+	    push(@code, "           ".$option." => [qw(".join(',', @$value).")], ");
+
+	} else {
+	    push(@code, "           ".$option." => '".$value."', ");
+	}
+    }
+    return @code;
+
+} # end buildOptions
+
 
 sub searchInTree {
     my $zinc = shift;
@@ -546,7 +719,7 @@ sub scangroup {
     my ($zinc, $tree, $group, $path, $format, @optionstodisplay) = @_;
     my @items = $zinc->find('withtag', "$group.");
     for my $item (@items) {
-	my $type = ucfirst($zinc->type($item));
+	my $Type = ucfirst($zinc->type($item));
 	my $info = " ";
 	if (@optionstodisplay == 1) {
 	    $info .= &extractinfo($zinc, $item, $format, $optionstodisplay[0]);
@@ -555,14 +728,14 @@ sub scangroup {
 		$info .= &extractinfo($zinc, $item, $format, $opt, 1);
 	    }
 	}
-	if ($type eq "Group") {
+	if ($Type eq "Group") {
 	    $tree->add($path.".".$item,
-		       -text => "$type($item)$info",
+		       -text => "$Type($item)$info",
 		       -style => 'group');
 	    &scangroup($zinc, $tree, $item, $path.".".$item, $format, @optionstodisplay);
 	} else {
 	    $tree->add($path.".".$item,
-		       -text => "$type($item)$info",
+		       -text => "$Type($item)$info",
 		       -style => 'item');
 	}
     }
@@ -1286,7 +1459,7 @@ sub highlighttransfo {
 	# If item is visible, rectangle is drawm surround it.
 	# Else, a warning is displayed.
 	unless (&itemisoutside($zinc, @bbox0)) {
-	    my $r = $zinc->add('Rectangle', $g,
+	    my $r = $zinc->add('rectangle', $g,
 			       [$bbox[0] - 10, $bbox[1] - 10,
 				$bbox[2] + 10, $bbox[3] + 10],
 			       -filled => 1,
@@ -1377,7 +1550,7 @@ sub surrounditem {
 	# Else, a warning is displayed.
 	unless (&itemisoutside($zinc, @bbox0)) {
 	    if (defined($level) and $level > 0) {
-		my $r = $zinc->add('Rectangle', $topgroup,
+		my $r = $zinc->add('rectangle', $topgroup,
 				   [$bbox[0] - 10, $bbox[1] - 10,
 				    $bbox[2] + 10, $bbox[3] + 10],
 				   -linewidth => 0,
@@ -1728,6 +1901,15 @@ sub showinstancehelp {
 	$text->insert('end', "\nUse the <");
 	$text->insert('end', $treeKey{$zinc}, 'keyword');
 	$text->insert('end', "> sequence.\n\n");
+
+	$text->insert('end', " To generate perl code\n", 'title');
+	$text->insert('end', "\nUse the <");
+	$text->insert('end', $treeKey{$zinc}, 'keyword');
+	$text->insert('end', "> sequence. Then select a branch of the tree ");
+	$text->insert('end', "and press on the ");
+	$text->insert('end', "Build code", 'keyword');
+	$text->insert('end', " button.\n\n");
+	
     }
     if ($enclosedModBtn{$zinc}) {
 	my $eseq = $enclosedModBtn{$zinc}->[0]."-Button".$enclosedModBtn{$zinc}->[1];
@@ -1801,10 +1983,12 @@ sub showHelpAboutTree {
     $helptree_tl = $tree_tl->Toplevel;
     $helptree_tl->title("Help about Tree");
 
-    my $text = $helptree_tl->Text(-font => scalar $zinc->cget(-font),
-				  -wrap => 'word',
-				  -foreground => 'gray10',
-				  );
+    my $text = $helptree_tl->Scrolled('Text',
+					-font => scalar $zinc->cget(-font),
+					-wrap => 'word',
+					-foreground => 'gray10',
+					-scrollbars => 'osoe',
+					);
     $text->tagConfigure('keyword', -foreground => 'darkblue');
     $text->insert('end', "\nNAVIGATION IN TREE\n\n");
     $text->insert('end', "<Up>", "keyword");
@@ -1828,9 +2012,15 @@ sub showHelpAboutTree {
     $text->insert('end', " key.\n\n");
     $text->insert('end', "To highlight item in the application, simply ");
     $text->insert('end', "click", "keyword");
-    $text->insert('end', " on it. ");
+    $text->insert('end', " on it.");
     &infoAboutHighlighting($text);
-    $text->configure(-state => 'disabled');
+    $text->insert('end', "\n\n\nBUILDING CODE\n\n");
+    $text->insert('end', "To build perl code, select a branch or a leaf ".
+		  "and click on the ");
+    $text->insert('end', "Build code", "keyword");
+    $text->insert('end', " button. Then select an output file with the ".
+		  "file selector.\n\n");
+     $text->configure(-state => 'disabled');
     
     $helptree_tl->Button(-command => sub {$helptree_tl->destroy},
 			 -text => 'Close')->pack(-side => 'bottom',
@@ -2036,7 +2226,7 @@ ZincDebug provides an interface to help developers to debug or analyse Zinc appl
 
 With B<finditems()> function, you are able to scan all items which are enclosed in a rectangular area you have first drawn by drag & drop, 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, by clicking on its corresponding button in the table. You can also display particular item's features by entering this id in dedicated entry field
 
-B<tree()> function displays items hierarchy. You can find a particular item's position in the tree and you can highlight items and see their features as described above.
+B<tree()> function displays items hierarchy. You can find a particular item's position in the tree and you can highlight items and see their features as described above. You can also generate the perl code corresponding to a selected branch. However there are some limitations : transformations and images can't be reproduced.
 
 With B<snapshot()> function, you are able to snapshot the application window, in order to illustrate a graphical bug for example.
     
@@ -2133,6 +2323,8 @@ Daniel Etienne <etienne@cena.fr>
     
 =head1 HISTORY
 
+May 20 2003 : perl code can be generated from the items tree, with some limitations concerning transformations and images.
+
 Mar 11 2003 : ZincDebug can manage several instances of Zinc widget. Options of ZincDebug functions can be set on the command line. 
 
 Jan 20 2003 : item's attributes can be edited.