log files are now very similar to perl code;

This should ease cut-and-paste of part of this file to perl
scripts to reproduce bugs in simpler scripts

1 files changed, 111 insertions, 46 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) {