initial release

1 files changed, 392 insertions, 0 deletions

diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
new file mode 100644
index 0000000..3dde2ee
--- /dev/null
+++ b/Perl/t/test-no-crash.pl
@@ -0,0 +1,392 @@
+#!/usr/bin/perl -w
+# $Id$
+# This simple demo has been developped by C. Mertz <mertz@cena.fr>
+
+use Tk;
+use Tk::Zinc;
+use Getopt::Long;
+
+use strict;
+
+# les variables positionnées en fonction des options de la ligne de commande
+my $opt_log = 0;
+my $opt_trace = "";
+my $opt_render = 0;
+my $opt_type = 0;
+
+# on récupère les options
+Getopt::Long::Configure('pass_through');
+my $optstatus = GetOptions('log=i' => \$opt_log,
+			   'trace=s' => \$opt_trace,
+			   'render=i' => \$opt_render,
+			   'type=s' => \$opt_type,
+			   );
+
+
+my $mw = MainWindow->new();
+
+# The explanation displayed when running this demo
+my $label=$mw->Label(-text => "This is a non-regression test, testing that
+zinc is not core-dumping!",
+		     -justify => 'left')->pack(-padx => 10, -pady => 10);
+
+
+# Creating the zinc widget
+my $zinc = $mw->Zinc(-width => 500, -height => 500,
+		     -font => "10x20", # usually fonts are sets in resources
+		                       # but for this example it is set in the code!
+		     -borderwidth => 0, -relief => 'sunken',
+		     -render => $opt_render,
+		     )->pack;
+
+
+my %itemtypes;
+my @itemtypes = qw(arc tabular track waypoint
+		   bezier curve rectangle triangles
+		   group icon map reticle text window
+		   );
+
+if ($opt_type) { @itemtypes = ($opt_type); }
+
+
+
+$zinc->add('group', 1);
+$zinc->add('group', 1);
+$zinc->add('icon', 1);
+$zinc->add('map', 1);
+$zinc->add('reticle', 1);
+$zinc->add('text', 1,  -position => [300,120], -text => "hello world1");
+$zinc->add('text', 1,  -position => [400,220], -text => "hello world2");
+$zinc->add('text', 1,  -position => [400,220], -text => "hello world3");
+$zinc->add('window', 1);
+$zinc->add('track', 1, 5, -position => [100,20]);
+$zinc->add('waypoint', 1, 5, -position => [100,20]);
+$zinc->add('tabular', 1, 5, -position => [100,20]);
+$zinc->add('tabular', 1, 5, -position => [100,20]);
+$zinc->add('group', 1);
+$zinc->add('group', 1);
+
+#$zinc->itemconfigure ('tabular', -labelformat => "200x10");
+#$zinc->update;
+
+
+
+$zinc->add('arc', 1, [10,10 , 50,50]);
+$zinc->add('bezier', 1, [10,10 , 50,50, 100,10, 10,200, 150,40]);
+$zinc->add('curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140]);
+$zinc->add('rectangle', 1, [400,400 , 450,220]);
+$zinc->add('triangles', 1, [200,200 , 300,200 , 300,300, 200,300],
+ 	   -colors => ["blue:50", "red:20", "green:80"]);
+
+
+my %options;
+my %types;
+
+foreach my $itemType (@itemtypes) {
+    my $anItem = $zinc->find('withtype', $itemType);
+    if (!defined $anItem) { print "no item $itemType\n"; next;};
+    my @options = $zinc->itemconfigure($anItem);
+    for my $elem (@options) {
+	my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem;
+	$options{$itemType}{$optionName} = [$optionType, $readOnly, $empty, $optionValue];
+	$types{$optionType} = 1;
+    }
+}
+
+foreach my $type (sort keys %types) {
+#    print "$type\n";
+}
+
+
+$zinc->mapinfo('mapinfo1', 'create');
+$zinc->mapinfo('mapinfo2', 'create');
+$zinc->mapinfo('mapinfo3', 'create');
+
+my %typesValues =
+    ('justify' => ['left', 'right', 'center'],
+     'alpha' => [0, 50, 100, 23],
+     'anchor' => ['n', 's', 'e', 'w', 'nw', 'ne', 'sw', 'se', 'center'],
+     'angle' => [0, 90, 180, 270, 360, 12, 93, 178, 272, 359],
+     'autoalignment' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc',
+			 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc',
+			 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc',
+			 '-',],
+     'boolean' => [0..1],
+#     'bitmap' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple7', 'AlphaStipple11', 'AlphaStipple14'], ####?!
+     'pattern' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ####?!
+     'patterns' => [['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ['AlphaStipple0']], ##TBC
+     'capstyle' => ['butt', 'projecting', 'round'],
+#     'color' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], #TBC
+     'gradient' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], ## TBC
+     'gradients' => [['green'], ['LemonChiffon'], ['#c84'], ['#4488cc'], ['#888ccc444'],
+		     ['red', 'green'], ['red', 'green', 'blue'],
+		     ['red:50', 'green:50', 'blue:50'],
+		     ['blue:0', 'green:50', 'red:90'],
+		     ], ## TBC
+     'dimension' => [0..5, 10, 50, 100, 0.0, 5.5, 100.5, 4.5],  ## and floats ?!
+     'edgelist' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations!
+     'font' => ['10x20', '6x10', '6x12', '6x13'],
+#     'gradientcolor' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444'], ## TBC
+     'image' => [], ## TBC
+     'integer' => [-10000, -100, -1, 0, 1, 10, 10000], ## pour quoi?
+     'item' => [],
+     'joinstyle' => ['bevel', 'miter', 'round'],
+     'labelformat' => [
+		       "200x10", ## BUG BUG
+#		       "200x100 x100x20+0+0 x100x20+0+20 x200x40+100+20"
+		       ],
+     'leaderanchors' => [], # [ "%10%30", "% 40 % 20", "% 67 % 21" ], ## TBC
+     'lineend' => [ [10,10,10], [10,100,10], [100,10,10], [10,10,100], [100,10,100] ],
+     'lineshape' => ['straight', 'rightlightning', 'leftlightning', 'rightcorner', 'leftcorner', 'doublerightcorner', 'doubleleftcorner'],
+     'linestyle' => ['dotted', 'simple', 'dashed', 'mixed', 'dotted'],
+     'mapinfo' => ['mapinfo1','mapinfo2','mapinfo3'], ## TBC
+     'number' => [2.3, 1.0, 5.6, 2.1],
+     'point' => [ [0,0] , [10,10], [20,20], [30,30], [20,20], [0,0] , [10,10] ],
+     'priority' => [ 1, 10, 50, 1000, 10000 ],  # positif ou nul
+     'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken',
+		  'roundraised', 'roundsunken', 'roundgroove',
+		  'roundridge', 'sunkenrule', 'raisedrule'],
+     'text' => ['teststring', 'short', 'veryverylongstring'],
+#     'taglist' => [], ## TBC
+     'tags' => [ [1], [1..2], ['a','b'], ['tag1','tag2','tag3']],
+     'unsignedint' => [ 0..5 , 10, 20, 30, 100 ],
+     'window' => [], ## TBC
+     );
+
+# the following valid value associated to types should be all different from
+# default value and from value initiated when creating items (see up...)
+my %typesNonStandardValues = 
+    ('justify' => 'right',
+     'alpha' => 50,
+     'anchor' => 'w',
+     'angle' => 45,
+     'autoalignment' => 'llc',
+     'pattern' => 'AlphaStipple14',
+     'patterns' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'],
+     'capstyle' => 'butt',
+     'gradient' => 'LemonChiffon',
+     'gradients' => ['red:50', 'green:50', 'blue:50'],
+     'dimension' => 45,
+     'edgelist' => 'contour',
+     'font' => '6x10',
+     'image' => [], ## TBC
+     'integer' => 7,
+     'item' => [],
+     'joinstyle' => 'miter',
+     'labelformat' => "200x30", ## BUG BUG
+     'leaderanchors' => "%10x60", ## BUG BUG
+     'lineend' => [13,7,20],
+     'lineshape' => 'rightlightning',
+     'linestyle' => 'dotted',
+     'mapinfo' => 'mapinfo2', ## TBC
+     'number' => 7.6,
+     'point' => [100,100],
+     'priority' => 50,
+     'relief' => 'groove',
+     'text' => 'notsoshort',
+     'tags' => ['tag1','tag11','tag111'],
+     'unsignedint' => 22,
+     'window' => undef, ## TBC
+ );
+    
+my %typesFalseValues =
+    ('alpha' => [0..100],
+     'anchor' => ['n', 's', 'e', 'w'], ##TBC
+     'angle' => [0..360],
+     'boolean' => [0..1],
+     'capstyle' => [],
+     'dimension' => [0..100],
+     'font' => ['10x20', '6x10', '6x12', '6x13'],
+     'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken',
+		  'roundraised', 'roundsunken', 'roundgroove',
+		  'roundridge', 'sunkenrule', 'raisedrule'],
+     );
+
+
+$mw->Button(-text => "Test options",
+	    -command => sub {&test_options},
+	    )->pack(-pady => 4);   
+
+$mw->Button(-text => "Test cloning",
+	    -command => sub {&test_cloning},
+	    )->pack(-pady => 4);   
+
+    
+
+
+
+sub test_attributes {
+    foreach my $type (@itemtypes) {
+	my @items = $zinc->find('withtype', $type);
+	print "---------testing ", (1+$#items), " ",$type,"(s) ----------------\n";
+	if ($#items == -1) { print "*** no such item: $type\n"; next;};
+	my %theoptions = %{$options{$type}};
+	foreach my $item (@items) {
+	    ## il faudrait tester les options selon un ordre défini à l'avance
+	    ## en passant par plusieurs occurences pour les options et en forçant
+	    ## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
+	    my @boolean_attributes;
+	    my %boolean_attributes;
+	    foreach my $option (sort keys %theoptions) {
+		my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
+		if ($optionType eq 'boolean') {
+		    next if $option eq -composerotation;
+		    next if $option eq -composescale;
+		    next if $option =~ /-\w+sensitive/ ;   # to get rid of many track options!
+		    next if $option =~ /-filled\w+/ ;      # to get rid of many track options!
+		    next if $option =~ /-speed\w+/ ;      # to get rid of many track options!
+		    next if $option =~ /-\w+history/ ;      # to get rid of many track options!
+		    push @boolean_attributes, $option;
+		    $boolean_attributes{$option}=1;
+		}
+	    }
+	    print $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n");
+	    foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) {
+		my $format = "%0" . ($#{boolean_attributes} +1) . "b";
+		my $binary = sprintf ($format,$i);
+		print $i, "/", (2**(1+$#boolean_attributes)), "  $binary\n";
+		my @binary = split (//,$binary);
+		foreach my $j (0 .. $#boolean_attributes) {
+		    $zinc->itemconfigure( $item, $boolean_attributes[$j] => $binary[$j] );
+		    print "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n";
+		}
+		foreach my $option (sort keys %theoptions) {
+		    next if ($option eq -numfields);
+		    next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested
+
+		    my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
+		    my $typeValues = $typesValues{$optionType};
+		    if (!defined $typeValues) {print "*** no values for type $optionType (option $option)\n";next;}
+		    my @values = @{$typeValues};
+
+		    if (!@values) {print "*** no values for type $optionType (option $option)\n";next;}
+			
+
+		    my $valueRef = ref ($values[0]);
+		    my $previous_val;
+		    my @previous_val;
+
+		    if ($valueRef eq '') {
+			$previous_val = $zinc->itemcget($item, $option);
+		    }
+		    else {
+			@previous_val = $zinc->itemcget($item, $option);
+		    }
+		    print "\$zinc->itemconfigure($item ($type), $option => ",join (", ",@values),"\n"
+			if ($opt_log == 1);
+		    foreach my $value (@values) {
+#			next unless $optionType eq "gradient";
+			print "\$zinc->itemconfigure($item ($type), $option => $value)\n"
+			    if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
+			$zinc->itemconfigure($item, $option => $value);
+			$zinc->update;
+			$zinc->after(10);
+		    }
+		    
+		    if ($valueRef eq '') {
+			$zinc->itemconfigure($item, $option => $previous_val);
+		    }
+		    else {
+			$zinc->itemconfigure($item, $option => \@previous_val);
+		    }
+		    
+		}
+#		print "end of sub_test_option\n";
+	    }
+	}
+    }
+    print "End of test_option\n";
+}
+
+
+# test2: configurer les fields des track / waypoint / tabular
+#        jouer avec les labelformats
+
+# test3: tester toutes les fonctions aléatoirement selon les signatures
+
+
+# test4: tester qu'ne clonant ont obtient bien une copie de tous les attributs
+
+sub test_cloning {
+    foreach my $type (@itemtypes) {
+	my $item = $zinc->find('withtype', $type);
+	print "---------cloning and testing item ",$type,"(s) ----------------\n";
+	if (!defined $item) { print "*** no such item: $type\n"; next;};
+	my $clone = $zinc->clone($item);
+	my %theoptions = %{$options{$type}};
+	## il faudrait tester les options selon un ordre défini à l'avance
+	## en passant par plusieurs occurences pour les options et en forçant
+	## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
+	foreach my $option (sort keys %theoptions) {
+	    next if ($option eq -numfields);
+	    my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
+	    my $value = $typesNonStandardValues{$optionType};
+#	    if ($optionType ne 'boolean' && !defined $value) {print "*** no values for type $optionType (option $option)\n";next;}
+
+	    my $valueRef = ref ($value);
+	    my $previous_val;
+	    my @previous_val;
+
+	    # memoryzing previous value of the clone 
+	    if ($valueRef eq '') {
+		$previous_val = $zinc->itemcget($clone, $option);
+	    }
+	    else {
+		@previous_val = $zinc->itemcget($clone, $option);
+	    }
+
+	    # in the case of boolean, we must always take the not value:
+	    if ($optionType eq 'boolean') { $value = !$previous_val }
+
+	    print "\$zinc->itemconfigure(clone $clone of $item ($type), $option => $value)\n"
+		if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
+	    $zinc->itemconfigure($clone, $option => $value);
+	    $zinc->update;
+#	    $zinc->after(10);
+	    if ($valueRef eq '') {
+		my $original_value = $zinc->itemcget($item, $option);
+		my $clone_value = $zinc->itemcget($clone, $option);
+#		print "original = $original_value\n";
+#		print "clone    = $clone_value\n";
+		if (defined $original_value && $original_value eq $clone_value) {
+		    print "*** Cloned $type gets the same $option (type $optionType) ($original_value ?= $previous_val)\n";
+		}
+	    }
+	    else {  # the value is a list
+	    print "option $option is waiting a list $valueRef\n";		
+	    }
+
+	    # setting back the previous value
+	    if ($valueRef eq '') { $zinc->itemconfigure($clone, $option => $previous_val) }
+	    else { $zinc->itemconfigure($clone, $option => \@previous_val) }
+	    
+	}
+    }
+    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
+    # tester le closest avec le centre de la bbox
+    
+    # faire la même chose que juste avant, mais en interchangeant clone et original
+    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
+    # tester le closest avec le centre de la bbox
+    
+    # supprimer l'item original
+
+    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
+    # tester le closest avec le centre de la bbox
+
+    # modifier tous les attributs du clone
+    # supprimer le clone
+
+    # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
+    # tester le closest avec le centre de la bbox
+     
+    print "End of test_cloning\n";
+}
+    
+
+# &test_mapitems; # should be done before really testing map items attributes
+# &test_labelcontent; # should be done before really testing track/waypoint/tabular items attributes
+
+&test_attributes; # on peut configurer toutes les attributs
+&test_cloning; # le clonage fonctionne correctement !
+MainLoop();