diff options
| -rw-r--r-- | Perl/t/test-no-crash.pl | 176 |
1 files changed, 12 insertions, 164 deletions
diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl index 45db8ec..d74c86f 100644 --- a/Perl/t/test-no-crash.pl +++ b/Perl/t/test-no-crash.pl @@ -5,8 +5,7 @@ use Tk; use Tk::Zinc; use Getopt::Long; -use IO::Handle; # for autoflushing the logs -use Carp; +use TestLog; use strict; @@ -65,18 +64,7 @@ unless ($opt_render==0 or $opt_render==1 or $opt_render==2) { $outfile = "no-crash-$Tk::Zinc::VERSION.log" if (!defined $outfile); -if ( open LOG, "$outfile.prev" ) { - close LOG; - unlink "$outfile.prev"; -} -if ( open LOG, $outfile ) { - close LOG; - link $outfile, "$outfile.prev"; - unlink "$outfile"; -} - -open LOG,">$outfile"; -autoflush LOG 1; +&openLog($outfile, $opt_log); sub usage { my ($text) = @_; @@ -122,6 +110,8 @@ my $zinc = $mw->Zinc(-width => 500, -height => 500, -render => $opt_render, )->pack; +&setZincLog($zinc); + my %itemtypes; my @itemtypes = qw(arc tabular track waypoint @@ -365,96 +355,6 @@ $mw->Button(-text => "Test fields attributes", -command => sub {&test_every_field_attributes}, )->pack(-pady => 4); -### print log information to the logfile -### if $level is <= than opt_log (def = 0) then print log on the stdout -### - a loglevel of -100 means an error to be logged with %%% prefix -### - a loglevel of -10 means an error in the test (data missing?) -### - a loglevel of 0 means an message to be usually printed (and logged in any case) -### - a loglevel greater than 1 is for trace only - - -sub log { - my ($loglevel, @strgs) = @_; - if ($loglevel <= $opt_log) { - print "%%%% " if $loglevel == -100; - print "%% " if $loglevel == -10; - print @strgs; - } - print LOG "%%%% " if $loglevel == -100; - print LOG "%% " if $loglevel == -10; - print LOG @strgs; -} # end log - -my %method_with_tagOrId = - ("anchorxy" => 1, "bbox" => 1, "bind" => 1, "chggroup" => 1, - "clone" => 1, "contour" => 1, "coords"=> 1, "cursor" => 1, - "dchars" => 1, "dtag" => 1, "focus" => 1, "gettags" => 1, - "group" => 1, # blabla... to complete - "itemcget" => 1, "itemconfigure" => 1, # blabla... to complete - "remove" => 1, - ); - - -### - a loglevel of -100 means an error to be loggued with %%% prefix -### - a loglevel of -10 means an error in the test (data missing?) -### - a loglevel of of 0 or greater is for trace only if an error occured -sub test_eval { - my ($loglevel, $method, @args) = @_; - - my @strs; - my $start_index = 0; - if (scalar @args) { - if ($method_with_tagOrId{$method} and $args[0] =~ /\d+/) { - my $item = $args[0]; - @strs = $item . " (" . $zinc->type($item) . ")"; - $start_index = 1; - } - foreach my $arg (@args[$start_index..$#args]) { - push @strs, &printable ($arg); - } - } - my $string2log = "\$zinc->$method (" . join (", ", @strs) . ")"; - if ($method eq 'itemcget' or $method eq 'get') { - $string2log .= " := " ; - } - else { - $string2log .= "\n"; - } - &log ($loglevel, $string2log); - - my (@res, $res); - if (wantarray()) { - @res = eval { $zinc->$method (@args) } ; - if ($method eq 'itemcget' or $method eq 'get') { - &log ($loglevel, printables(@res) . "\n" ); - } - } - else { - $res = eval { $zinc->$method (@args) } ; - if ($method eq 'itemcget' or $method eq 'get') { - &log ($loglevel, &printable($res) . "\n"); - } - } - - - if ($@) { # in case of error, logging! - &log (-100, "Error while evaluating: $string2log"); - &log (-100, $@); - my $msgl = &Carp::longmess; - my ($msg2) = $msgl =~ /.*?( at .*)/s ; - &log (-100, "\t$msg2"); - return (ERROR); - } - else { - if (wantarray()) { - return @res; - } - else { - return $res; - } - } -} # end of test_eval - sub test_attributes { &log (0, "---- Start of test_attributes ----\n"); foreach my $type (@itemtypes) { @@ -660,7 +560,7 @@ sub test_a_clone { if ($valueRef eq 'ARRAY') { # the value is a list my @original_value = &test_eval (2, "itemcget", $original, $option); my @clone_value = &test_eval (1, "itemcget", $clone, $option); - if ( &equal_arrays (\@original_value, \@clone_value) ) { + if ( &equal_flat_arrays (\@original_value, \@clone_value) ) { &log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printables(@original_value) . "\n"); } } @@ -795,65 +695,6 @@ sub test_every_field_attributes { } # end test_every_field_attributes - -### to print something -sub printable { - my ($value) = @_; - my $ref = ref($value); - if ($ref eq 'ARRAY') { - return printables ( @{$value} ); - } - elsif ($ref eq 'Tk::Photo') { - return "Tk::Photo(\"". $value->cget(-file) . "\)"; - } - elsif ($ref eq '') { # scalar - if (defined $value) { - if ($value eq '') { - return "''"; - } - else { - return $value; - } - } - else { - return "undef"; - } - } - else { # some class instance - return $value; - } -} # end printable - -### to print an array of something -sub printables { - my (@values) = @_; - if (! scalar @values) { - return "[]"; - } - else { # the arry is not empty - my @res; - foreach my $value (@values) { - push @res, &printable($value); - } - return ("[ " . join (', ', @res) . " ]") ; - } -} # end printables - -## return 1 if arrays have the same length and every items are eq -sub equal_arrays { - my ($refArray1, $refArray2) = @_; - my @array1 = @{$refArray1}; - my @array2 = @{$refArray2}; - - return 0 if ($#array1 != $#array2); - - for my $i (0..$#array1) { - return 0 if ($array1[$i] ne $array2[$i]); - } - return 1; -} # equal_arrays - - sub createMapInfo { my ($name, $N,$deltaN, $radius, $centerX,$centerY) = @_; &test_eval (1, "mapinfo", $name, 'create'); @@ -975,6 +816,13 @@ if ($tests{5}) { # #### &test_path_tags; # #### &test_illegal_tags; +# #### &test_illegal_call +# for example: +# calling a methode for an non-existing item +# getting coords, contours, fields, etc... of non-existing index +# +# cloning, deleting topgroup +# &log (0, "---- End of test_no_crash ----\n"); |