From 7512b62fbaad9fc4a4b5753fd7bdbd18cb297f62 Mon Sep 17 00:00:00 2001 From: mertz Date: Fri, 26 Apr 2002 12:55:24 +0000 Subject: initial release --- Perl/t/test-no-crash.pl | 392 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 392 insertions(+) create mode 100644 Perl/t/test-no-crash.pl 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 + +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(); -- cgit v1.1