diff options
Diffstat (limited to 'Perl/t/test-no-crash.pl')
| -rw-r--r-- | Perl/t/test-no-crash.pl | 164 |
1 files changed, 101 insertions, 63 deletions
diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl index 0399778..6f60f21 100644 --- a/Perl/t/test-no-crash.pl +++ b/Perl/t/test-no-crash.pl @@ -20,29 +20,48 @@ my $opt_log = 0; my $opt_trace = ""; my $opt_render = 0; my $opt_type = 0; +my $outfile; # on récupère les options Getopt::Long::Configure('pass_through'); my $optstatus = GetOptions('log=i' => \$opt_log, + 'out=s' => \$outfile, 'trace=s' => \$opt_trace, 'render=i' => \$opt_render, 'type=s' => \$opt_type, + 'help' => \&usage, ); -if ( open LOG, "no-crash.log.prev" ) { +$outfile = "no-crash-$Tk::Zinc::VERSION.log" if (!defined $outfile); + +if ( open LOG, "$outfile.prev" ) { close LOG; - unlink "no-crash.log.prev"; + unlink "$outfile.prev"; } -if ( open LOG, "no-crash.log" ) { +if ( open LOG, $outfile ) { close LOG; - link "no-crash.log", "no-crash.log.prev"; - unlink "no-crash.log"; + link $outfile, "$outfile.prev"; + unlink "$outfile"; } -open LOG,">no-crash.log"; +open LOG,">$outfile"; autoflush LOG 1; - +sub usage { + my ($text) = @_; + print $text,"\n" if (defined $text); + print "test-no-crash [options]\n"; + print " A non-regression test suite for zinc.\n"; + print " Some exhaustive test of zinc. Of course everything is not tested yet\n"; + print " options are:\n"; + print " -log <n> trace level, defaulted to 0; higher level trace more infos\n"; + print " -out filename the log filename. defaulted to no-crash.log\n"; + print " NB: the previous log file is always renamed with a .prev suffix\n"; + print " -trace <an_item_option> to better trace usage of an option\n"; + print " -render 0|1|2 to select the render option of zinc\n"; + print " -help to print this short help\n"; + exit; +} my $mw = MainWindow->new(); @@ -72,6 +91,7 @@ my @itemtypes = qw(arc tabular track waypoint if ($opt_type) { @itemtypes = ($opt_type); } +foreach my $type (@itemtypes) { $itemtypes{$type}=1 } #### some global variables needed as attributes values my ($text1, $text2, $text3, $text4); @@ -93,6 +113,7 @@ sub creating_items { &test_eval (1, "add", 'group', 1); &test_eval (1, "add", 'icon', 1); &test_eval (1, "add", 'map', 1); + &test_eval (1, "add", 'map', 1); &test_eval (1, "add", 'reticle', 1); $text1 = &test_eval (1, "add", 'text', 1, -position => [300,120], -text => "hello world1"); $text2 = &test_eval (1, "add", 'text', 1, -position => [350,170], -text => "hello world2"); @@ -147,27 +168,6 @@ sub verifying_item_completion { foreach my $type (sort keys %created_item_types) { &log(-100, "This tested item type \"$type\" is supposed not to exist in Zinc!\n"); } -} # end verifying_item_completion - -# verifies that we create an item of every existing type -sub verifying_item_completion { - my @all_types = $zinc->add(); ## this use of add is not documented yet XXX! - my @all_items = $zinc->find ('withtag', 'all'); - my %created_item_types; - foreach my $item (@all_items) { - $created_item_types{$zinc->type($item)} = 1; - } - foreach my $type (@all_types) { - if (defined $created_item_types{$type}) { - delete $created_item_types{$type}; - } - else { - &log(-100, "item type \"type\" which exist in Zinc is not tested!\n"); - } - } - foreach my $type (sort keys %created_item_types) { - &log(-100, "This tested item type \"$type\" is supposed not to exist in Zinc!\n"); - } } @@ -417,6 +417,7 @@ sub test_eval { } # end of test_eval sub test_attributes { + &log (0, "---- End of test_attributes ----\n"); foreach my $type (@itemtypes) { my @items = $zinc->find('withtype', $type); &log (0, "--------- Testing ", (1+$#items), " ",$type," ----------------\n"); @@ -497,7 +498,7 @@ sub test_attributes { } } } - &log (0, "End of test_attributes\n"); + &log (0, "---- End of test_attributes ----\n"); } # end test_attributes @@ -510,6 +511,7 @@ sub test_attributes { # test4: tester qu'en clonant on obtient bien une copie de tous les attributs sub test_cloning { + &log (0, "---- End of test_cloning ----\n"); &creating_items; foreach my $type (@itemtypes) { my $item = $zinc->find('withtype', $type); @@ -547,7 +549,7 @@ sub test_cloning { # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox # tester le closest avec le centre de la bbox - &log (0, "End of test_cloning\n"); + &log (0, "---- End of test_cloning ----\n"); } # end test_cloning ## teste le find enclosed / overlapping avec un rectangle un peu plus grand @@ -669,7 +671,9 @@ sub test_every_attributes_once { sub test_every_field_attributes { + &log (0, "---- Start of test_every_field_attributes ----\n"); foreach my $type qw(waypoint track tabular) { + next unless $itemtypes{$type}; my %theoptions = %fieldOptions; my @items = $zinc->find('withtype', $type); &log (0, "--------- Testing fields of ", (1+$#items), " ",$type,"(s) ----------------\n"); @@ -707,48 +711,49 @@ sub test_every_field_attributes { } } foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) { - foreach my $option (sort keys %theoptions) { + foreach my $option (sort keys %theoptions) { next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested - + my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - my $typeValues = $typesValues{$optionType}; - if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;} - my @values = @{$typeValues}; - if (!@values) {&log (-100, "No values for type $optionType (option $option)\n");next;} + my $typeValues = $typesValues{$optionType}; + if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;} + my @values = @{$typeValues}; + + if (!@values) {&log (-100, "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 = &test_eval (1, "itemcget", $item, $field, $option); - } - else { - @previous_val = &test_eval (1, "itemcget", $item, $field, $option); - } - &log (1, "\$zinc->itemconfigure($item ($type), $field, $option => ",&printables ($valueRef,@values),"\n"); - foreach my $value (@values) { - my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ; + my $valueRef = ref ($values[0]); + my $previous_val; + my @previous_val; + + if ($valueRef eq '') { + $previous_val = &test_eval (1, "itemcget", $item, $field, $option); + } + else { + @previous_val = &test_eval (1, "itemcget", $item, $field, $option); + } + &log (1, "\$zinc->itemconfigure ($item ($type), $field, $option => ",&printables ($valueRef,@values),"\n"); + foreach my $value (@values) { + my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ; # &log ( $log_lev, "\$zinc->itemconfigure($item ($type), $field, $option => $value)\n"); - &test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value); - $zinc->update; - $zinc->after(10); - } - - if ($valueRef eq '') { - &test_eval (1, "itemconfigure", $item, $field, $option => $previous_val); - } - else { - &test_eval (1, "itemconfigure", $item, $field, $option => \@previous_val); - } + &test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value); + $zinc->update; + $zinc->after(10); + } + + if ($valueRef eq '') { + &test_eval (1, "itemconfigure", $item, $field, $option => $previous_val); + } + else { + &test_eval (1, "itemconfigure", $item, $field, $option => \@previous_val); + } }} } } } - &log (0, "End of test_every_field_attributes\n"); + &log (0, "---- End of test_every_field_attributes ----\n"); } # end test_every_field_attributes sub printable { @@ -796,15 +801,48 @@ sub equal_arrays { } # equal_arrays -# #### &test_mapitems; # should be done before really testing map items attributes +sub createMapInfo { + my ($name, $N,$deltaN, $radius, $centerX,$centerY) = @_; + &test_eval (1, "mapinfo", $name, 'create'); + + my @lineTypes=(qw/simple dashed dotted mixed marked/), + my $deltaAngle=6.283/$N; + for (my $i = 0; $i < $N; $i++) { + my $x1 = $centerX + $radius * sin($i * $deltaAngle); + my $y1 = $centerY + $radius * cos($i * $deltaAngle); + my $x2 = $centerX+ $radius * sin( ($i + $deltaN) * $deltaAngle); + my $y2 = $centerY + $radius * cos( ($i + $deltaN)* $deltaAngle); + my $linetype = $lineTypes[$i%5]; + $mw->mapinfo($name, 'add', 'line', $linetype, 1+$i%3, +$x1,$y1,$x2,$y2); + } +} # end of createMapInfo + +sub test_mapitems { + my @mapinfoNames = @_; + &log (0, "---- Start of test_mapitems ----\n"); + my @maps = $zinc->find('withtype', 'map'); + my $counter=0; + foreach my $map (@maps) { + &test_eval (1, "itemconfigure", $map, -mapinfo => $mapinfoNames[$counter]); + if ($counter == $#maps) { $counter=0 } + $counter++; + } + &log (0, "---- End of test_mapitems ----\n"); +} # end test_mapitems + + +&createMapInfo ('firstmap', 50, 20, 200, 200, 300); +&createMapInfo ('secondmap', 12, 3, 200, 300, 50); +&test_mapitems ('firstmap', 'secondmap'); # should be done before really testing map items attributes # #### &test_labelcontent; # should be done before really testing track/waypoint/tabular items attributes &test_every_field_attributes; -&test_attributes; # on peut configurer toutes les attributs +&test_attributes; # on peut configurer tous les attributs &test_cloning; # le clonage fonctionne correctement ! # #### &test_path_tags; # #### &test_illegal_tags; +&log (0, "---- End of test_no_crash ----\n"); MainLoop(); |