aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/t/TestLog.pm157
-rw-r--r--Perl/t/test-no-crash.pl70
2 files changed, 146 insertions, 81 deletions
diff --git a/Perl/t/TestLog.pm b/Perl/t/TestLog.pm
index 55f40c0..9488dcd 100644
--- a/Perl/t/TestLog.pm
+++ b/Perl/t/TestLog.pm
@@ -10,7 +10,7 @@ use strict;
use vars qw( $VERSION @ISA @EXPORT );
($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/);
-@EXPORT = qw( openLog setZincLog log test_eval printable printables
+@EXPORT = qw( openLog setZincLog log test_eval test_no_eval printableItem printableArray printableList
equal_flat_arrays nequal_cplx_arrays);
use constant ERROR => '--an error--';
@@ -39,8 +39,8 @@ sub openLog {
### 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 -100 means an error to be logged with #### prefix
+### - a loglevel of -10 means an error in the test to be logged with ## prefix
### - 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
@@ -48,12 +48,12 @@ sub openLog {
sub log {
my ($loglevel, @strgs) = @_;
if ($loglevel <= $opt_log) {
- print "%%%% " if $loglevel == -100;
- print "%% " if $loglevel == -10;
+ print "#### " if $loglevel == -100;
+ print "## " if $loglevel == -10;
print @strgs;
}
- print LOG "%%%% " if $loglevel == -100;
- print LOG "%% " if $loglevel == -10;
+ print LOG "#### " if $loglevel == -100;
+ print LOG "## " if $loglevel == -10;
print LOG @strgs;
} # end log
@@ -73,30 +73,34 @@ my %method_with_tagOrId =
"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
+### evaluate $zinc->$method(@args); and verifies that NO ERROR occurs
+### - a loglevel of -100 means an error to be logged with #### prefix
+### - a loglevel of -10 means an error in the test, to be logged with ##
+### - a loglevel of of 0 or greater is for trace only (usefull when an error occurs)
sub test_eval {
my ($loglevel, $method, @args) = @_;
my @strs;
my $start_index = 0;
+ my $string2log = "\$zinc->$method (";
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);
- }
+ if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) {
+ my $type = $zinc->type($args[0]);
+ $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")";
+ } else {
+ $string2log .= &printableItem($args[0]) ;
+ }
+ $string2log .= ", " if $#args > 0 ;
+ my $rest = &printableList(@args[1..$#args]);
+ $rest =~ s/^\(//; ### suppressing the first ( char
+ $string2log .= $rest;
+ } else {
+ $string2log .= ")";
}
- my $string2log = "\$zinc->$method (" . join (", ", @strs) . ")";
if ($method eq 'itemcget' or $method eq 'get') {
- $string2log .= " := " ;
- }
- else {
- $string2log .= "\n";
+ $string2log .= "; # := " ;
+ } else {
+ $string2log .= ";\n";
}
&log ($loglevel, $string2log);
@@ -104,26 +108,23 @@ sub test_eval {
if (wantarray()) {
@res = eval { $zinc->$method (@args) } ;
if ($method eq 'itemcget' or $method eq 'get') {
- &log ($loglevel, printables(@res) . "\n" );
+ &log ($loglevel, printableList(@res) . "\n" );
}
- }
- else {
+ } else {
$res = eval { $zinc->$method (@args) } ;
if ($method eq 'itemcget' or $method eq 'get') {
- &log ($loglevel, &printable($res) . "\n");
+ &log ($loglevel, &printableItem($res) . "\n");
}
}
-
if ($@) { # in case of error, logging!
- &log (-100, "Error while evaluating: $string2log");
+ &log (-100, "Error while evaluating: $string2log;");
&log (-100, $@);
my $msgl = &Carp::longmess;
my ($msg2) = $msgl =~ /.*?( at .*)/s ;
&log (-100, "\t$msg2");
return (ERROR);
- }
- else {
+ } else {
if (wantarray()) {
return @res;
}
@@ -133,13 +134,51 @@ sub test_eval {
}
} # end of test_eval
+### evaluate $zinc->$method(@args); and verifies that AN ERROR occurs
+### - a loglevel of -100 means an NO error to be loggued with #### prefix
+### - a loglevel of -10 means NO error in the test to be loggued with ## prefix
+### - a loglevel of of 0 or greater is for trace only if NO error occured
+sub test_no_eval {
+ my ($reason, $loglevel, $method, @args) = @_;
+
+ my @strs;
+ my $start_index = 0;
+ my $string2log = "\$zinc->$method (";
+ if (scalar @args) {
+ if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) {
+ my $type = $zinc->type($args[0]);
+ $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")";
+ } else {
+ $string2log .= &printableItem($args[0]) ;
+ }
+ $string2log .= ", " if $#args > 0 ;
+ my $rest = &printableList(@args[1..$#args]);
+ $rest =~ s/^\(//; ### suppressing the first ( char
+ $string2log .= $rest;
+ } else {
+ $string2log .= ")";
+ }
+
+ eval { $zinc->$method (@args) } ;
+
+ # in case of NO error, logging!
+ if ($@) {
+# print "errormsg=$@";
+ my ($error_msg) = $@ =~ /(.*)\s*at \/usr\//;
+ $error_msg = $@ if !defined $error_msg ;
+ &log ($loglevel, " # When $reason : $string2log;\n # the error msg is: $error_msg\n");
+ } else {
+ &log (-100, "An error SHOULD have occured while evaluating:\n####\t$string2log;\n####\tbecause $reason\n");
+ }
+} # end of test_no_eval
+
-### to print something in a readable form
-sub printable {
+### return a printable string of something in a readable form
+sub printableItem {
my ($value) = @_;
my $ref = ref($value);
if ($ref eq 'ARRAY') {
- return printables ( @{$value} );
+ return printableArray ( @{$value} );
}
elsif ($ref eq 'Tk::Photo') {
return "Tk::Photo(\"". $value->cget(-file) . "\)";
@@ -147,9 +186,12 @@ sub printable {
elsif ($ref eq '') { # scalar
if (defined $value) {
if ($value eq '') {
- return "''";
- }
- else {
+ return "''";
+ } elsif ($value =~ /\s/
+ or $value =~ /^[a-zA-Z]/
+ or $value =~ /^[\W]$/ ) {
+ return "'$value'";
+ } else {
return $value;
}
}
@@ -160,22 +202,45 @@ sub printable {
else { # some class instance
return $value;
}
-} # end printable
+} # end printableItem
### to print an array of something
-sub printables {
+sub printableArray {
my (@values) = @_;
if (! scalar @values) {
return "[]";
}
- else { # the arry is not empty
- my @res;
- foreach my $value (@values) {
- push @res, &printable($value);
+ else { # the array is not empty
+ my $res = "[ ";
+ while (@values) {
+ my $value = shift @values;
+ $res .= &printableItem($value);
+ next unless (@values);
+ if ($value =~ /^-\w+/) {
+ $res .= " => ";
+ } elsif (@_) {
+ $res .= ", ";
+ }
+
}
- return ("[ " . join (', ', @res) . " ]") ;
+ return ($res . " ]") ;
}
-} # end printables
+} # end printableArray
+
+sub printableList {
+ my $res = "(";
+ while (@_) {
+ my $v = shift @_;
+ $res .= &printableItem($v);
+ if (defined $v and $v =~ /^-\w+/) {
+ $res .= " => ";
+ } elsif (@_) {
+ $res .= ", ";
+ }
+ }
+ return $res . ")";
+} # end printableList
+
## return 1 if arrays of scalars have the same length and every items are eq
sub equal_flat_arrays {
@@ -201,7 +266,7 @@ sub nequal_cplx_arrays {
my @array1 = @{$refArray1};
my @array2 = @{$refArray2};
-# print "array1=", &printables(@array1), "\narray2=",&printables(@array2),"\n";
+# print "array1=", &printableArray(@array1), "\narray2=",&printableArray(@array2),"\n";
return 'length' if ($#array1 != $#array2);
for my $i (0..$#array1) {
diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
index d74c86f..dda953b 100644
--- a/Perl/t/test-no-crash.pl
+++ b/Perl/t/test-no-crash.pl
@@ -87,7 +87,7 @@ sub usage {
my $mw = MainWindow->new();
-&log (0, "testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n");
+&log (0, "#testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n");
## must be done after the LOG file is open
my @tests = &parseTestsOpt($opt_tests);
@@ -356,10 +356,10 @@ $mw->Button(-text => "Test fields attributes",
)->pack(-pady => 4);
sub test_attributes {
- &log (0, "---- Start of test_attributes ----\n");
+ &log (0, "#---- Start of test_attributes ----\n");
foreach my $type (@itemtypes) {
my @items = $zinc->find('withtype', $type);
- &log (0, "--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n");
+ &log (0, "#--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n");
if ($#items == -1) {
&log (-100, "No such item: $type\n");
next;
@@ -384,11 +384,11 @@ sub test_attributes {
$boolean_attributes{$option}=1;
}
}
- &log (0, $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
+ &log (0, "# $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);
- &log (0, $i, "/", (2**(1+$#boolean_attributes)), " $binary\n");
+ &log (0, "# $i/", (2**(1+$#boolean_attributes)), " $binary\n");
my @binary = split (//,$binary);
foreach my $j (0 .. $#boolean_attributes) {
&test_eval (0, "itemconfigure", $item, $boolean_attributes[$j] => $binary[$j] );
@@ -417,7 +417,7 @@ sub test_attributes {
else {
@previous_val = $zinc->itemcget($item, $option);
}
- &log (1, "** itemconfigure of $item ($type), $option => ",&printables (@values),"\n");
+ &log (1, "#** itemconfigure of $item ($type), $option => ",&printableList (@values),"\n");
my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ;
foreach my $value (@values) {
&test_eval ($log_lev, "itemconfigure", $item, $option => $value);
@@ -436,7 +436,7 @@ sub test_attributes {
}
}
}
- &log (0, "---- End of test_attributes ----\n");
+ &log (0, "#---- End of test_attributes ----\n");
} # end test_attributes
@@ -449,26 +449,26 @@ sub test_attributes {
# test4: tester qu'en clonant on obtient bien une copie de tous les attributs
sub test_cloning {
- &log (0, "---- Start of test_cloning ----\n");
+ &log (0, "#---- Start of test_cloning ----\n");
&creating_items;
foreach my $type (@itemtypes) {
my $item = $zinc->find('withtype', $type);
- &log (0, "--------- Cloning and testing item ",$type," ----------------\n");
+ &log (0, "#--------- Cloning and testing item ",$type," ----------------\n");
if (!defined $item) { &log (-10, "No such item: $type\n"); next;};
my $clone = &test_eval(1, "clone", $item);
- &log (0, "---- Modifying the clone $clone\n");
+ &log (0, "#---- Modifying the clone $clone\n");
&test_a_clone ($type, $item, $clone);
&test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item));
&test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone));
- &log (0, "---- Modifying the original\n");
+ &log (0, "#---- Modifying the original\n");
&test_a_clone ($type, $clone, $item);
&test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item));
&test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone));
- &log (0, "---- Deleting the original\n");
+ &log (0, "#---- Deleting the original\n");
&test_eval (1, "remove", $item);
&test_every_attributes_once($type,$clone);
- &log (0, "---- Deleting the clone\n");
+ &log (0, "#---- Deleting the clone\n");
&test_eval (1, "remove", $clone);
}
# tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
@@ -489,7 +489,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
@@ -561,7 +561,7 @@ sub test_a_clone {
my @original_value = &test_eval (2, "itemcget", $original, $option);
my @clone_value = &test_eval (1, "itemcget", $clone, $option);
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");
+ &log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printableArray(@original_value) . "\n");
}
}
else { # the value is either a scalar or a class instance
@@ -570,8 +570,8 @@ sub test_a_clone {
if (defined $original_value && $original_value eq $clone_value) {
# print "ORIGIN = ",$original_value, " $original_value CLONE = ",$clone_value,"\n";
&log (-100, "Modified cloned $type gets the same value for $option (type $optionType) " .
- "(original=cloned: " . &printable($original_value) .
- "?=" . &printable($previous_val) .
+ "(original=cloned: " . &printableItem($original_value) .
+ "?=" . &printableItem($previous_val) .
" :previous)\n");
}
}
@@ -610,12 +610,12 @@ sub test_every_attributes_once {
sub test_every_field_attributes {
- &log (0, "---- Start of test_every_field_attributes ----\n");
+ &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 field attributes of ", (1+$#items), " ",$type,"(s) ----------------\n");
+ &log (0, "#--------- Testing field attributes of ", (1+$#items), " ",$type,"(s) ----------------\n");
if ($#items == -1) {
&log (-100, "No such item: $type\n");
next;
@@ -637,14 +637,14 @@ sub test_every_field_attributes {
$boolean_attributes{$option}=1;
}
}
- &log (0, $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
+ &log (0, "# $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);
- &log (0, $i, "/", (2**(1+$#boolean_attributes)), " $binary\n");
+ &log (0, "# $i/", (2**(1+$#boolean_attributes)), " $binary\n");
my @binary = split (//,$binary);
foreach my $j (0 .. $#boolean_attributes) {
- &log (0, "setting $type ($item) field 0..",$zinc->itemcget($item, -numfields)-1, " ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
+ &log (0, "# setting $type ($item) field 0..",$zinc->itemcget($item, -numfields)-1, " ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) {
&test_eval (1, "itemconfigure", $item, $field, $boolean_attributes[$j] => $binary[$j] );
}
@@ -672,7 +672,7 @@ sub test_every_field_attributes {
else {
@previous_val = &test_eval (1, "itemcget", $item, $field, $option);
}
- &log (1, "** itemconfigure ($item ($type), $field, $option => ",&printables (@values),"\n");
+ &log (1, "#** itemconfigure ($item ($type), $field, $option => ",&printableList (@values),"\n");
foreach my $value (@values) {
my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
&test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value);
@@ -691,7 +691,7 @@ sub test_every_field_attributes {
}
}
}
- &log (0, "---- End of test_every_field_attributes ----\n");
+ &log (0, "#---- End of test_every_field_attributes ----\n");
} # end test_every_field_attributes
@@ -713,7 +713,7 @@ sub createMapInfo {
sub test_mapitems {
my @mapinfoNames = @_;
- &log (0, "---- Start of test_mapitems ----\n");
+ &log (0, "#---- Start of test_mapitems ----\n");
my @maps = $zinc->find('withtype', 'map');
my $counter=0;
foreach my $map (@maps) {
@@ -721,12 +721,12 @@ sub test_mapitems {
if ($counter == $#maps) { $counter=0 }
$counter++;
}
- &log (0, "---- End of test_mapitems ----\n");
+ &log (0, "#---- End of test_mapitems ----\n");
} # end test_mapitems
## testing the returned value of coords
sub test_coords {
- &log (0, "---- Start of test_coords ----\n");
+ &log (0, "#---- Start of test_coords ----\n");
foreach my $it ($zinc->find('withtag','*')) {
$zinc->remove($it);
}
@@ -736,16 +736,16 @@ sub test_coords {
next if $type eq 'map'; ## map item does not support coords method
my $it = $zinc->find('withtype',$type);
my @coordsAll= &test_eval (1, "coords", $it);
- my $coordsAll = &printables(@coordsAll);
+ my $coordsAll = &printableArray(@coordsAll);
&log (1, "=> $coordsAll\n");
my @coordsContour= &test_eval (1, "coords", $it,0); # all items have 1 contour
- my $coordsContour = &printables(@coordsContour);
+ my $coordsContour = &printableArray(@coordsContour);
&log (1,"=> $coordsContour\n");
my @coordsPoint= &test_eval (1, "coords", $it,0,0); # all items have 1 contour with at least one point
- my $coordsPoint = &printables(@coordsPoint);
+ my $coordsPoint = &printableArray(@coordsPoint);
&log (1,"=> $coordsPoint\n");
}
- &log (0, "---- End of test_coords ----\n");
+ &log (0, "#---- End of test_coords ----\n");
}
sub parseTestsOpt {
@@ -760,7 +760,7 @@ sub parseTestsOpt {
}
exit;
} elsif ( $opt eq 'all' ) { ## default!
- &log (0, "all tests will be passed through\n");
+ &log (0, "# all tests will be passed through\n");
@tests = sort keys %testsHash;
} elsif ( $opt =~ /^\d+(,\d+)*$/ ) {
@tests = split (/,/ , $opt);
@@ -768,9 +768,9 @@ sub parseTestsOpt {
foreach my $test (@tests) {
die "tests num must not exceed $testnumb" if $test > $testnumb;
}
- &log(0, "Test to be done:\n");
+ &log(0, "# Tests to be done:\n");
foreach my $test (@tests) {
- &log(0, "\t$test => " . $testsHash{$test} . "\n");
+ &log(0, "\t# $test => " . $testsHash{$test} . "\n");
}
} else {
print "bad -tests value. Must be a list of integer separated by ,\n";
@@ -824,6 +824,6 @@ if ($tests{5}) {
# cloning, deleting topgroup
#
-&log (0, "---- End of test_no_crash ----\n");
+&log (0, "#---- End of test_no_crash ----\n");
MainLoop();
generated by cgit v1.1 at 2024-11-02 22:38:46 +0000