Ajout du module ZincTraceErrors qui trappe les erreurs Zinc et affiche

pour chaque erreur l'instruction et le message d'erreur.
Factorisation de code dans ZincTraceUtils.pm

3 files changed, 184 insertions, 81 deletions

diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm
index ad0015f..0a2b7c4 100644
--- a/Perl/Zinc/Trace.pm
+++ b/Perl/Zinc/Trace.pm
@@ -14,9 +14,10 @@
 # This package overloads the Tk::Methods function in order to trace
 # every Tk::Zinc method call in your application.
 #
-# This may be very usefull when your application segfaults or encounters
-# errors such as "blabla...bla at /usr/lib/perl5/Tk.pm line 228" and
-# when you have no idea where this happens in your code  
+# This may be very usefull when your application segfaults and
+# when you have no idea where this happens in your code.
+#
+# To trap Tk::Zinc errors, use rather the ZincTraceErrors package.
 #
 # for using this file do some thing like :
 # perl -MZincTrace myappli.pl
@@ -25,14 +26,17 @@ package ZincTrace;
 
 use Tk;
 use strict;
-use Tk::Font;
-use Tk::Photo;
-
-use Carp;
+use ZincTraceUtils;
 
 my $WidgetMethodfunction;
 BEGIN {
+    if ($ZincTraceErrors::on == 1) {
+	print STDERR "ZincTrace: incompatible package ZincTraceErrors is already ".
+	    "loaded (exit 1)\n";
+	exit 1;
+    }
     print "ZincTrace is ON\n";
+    $ZincTrace::on = 1;
     select STDOUT; $|=1; ## for flushing the trace output
     # save current Tk::Zinc::InitObject function; it will be invoked in
     # overloaded one (see below)
@@ -49,7 +53,7 @@ sub Tk::Zinc::WidgetMethod {
     $filename="" unless defined $filename;
     $line="" unless defined $line;
     print "TRACE: $filename line $line $name";
-    &printList (@args);
+    &printList(@args);
     # invoke function possibly overloaded in other modules
     if (wantarray()) {
 	my @res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;
@@ -66,79 +70,6 @@ sub Tk::Zinc::WidgetMethod {
     }
 }
     
-    
-
-### to print something
-sub printItem {
-    my ($value) = @_;
-    my $ref = ref($value);
-#    print "VALUE=$value REF=$ref\n";
-    if ($ref eq 'ARRAY') {
-	printArray ( @{$value} );
-    }
-    elsif ($ref eq 'CODE') {
-	print "{CODE}";
-    }
-    elsif ($ref eq 'Tk::Photo') {
-#	print " **** $value ***** ";
-	print "Tk::Photo(\"". scalar $value->cget('-file') . "\")";
-    }
-    elsif ($ref eq 'Tk::Font') {
-	print "'$value'";
-    }
-    elsif ($ref eq '') {  # scalar 
-	if (defined $value) {
-	    if ($value eq '') {
-		print  "''";
-	    } elsif ($value =~ /\s/
-		     or $value =~ /^[a-zA-Z]/
-		     or $value =~ /^[\W]$/ ) {
-		print "'$value'";
-	    }  else {
-		print $value;
-	    }
-	}
-	else {
-	    print "undef";
-	}
-    }
-    else { # some  class instance
-	return $value;
-    }
-} # end printitem
-
-### to print a list of something
-sub printArray {
-    my (@values) = @_;
-    if (! scalar @values) {
-	print "[]";
-    }
-    else {  # the list is not empty
-	my @res;
-	print "[";
-	while (@values) {
-	    my $value = shift @values;
-	    &printItem ($value);
-	    print ", " if (@values);
-	}
-	print "]" ;
-    }
-} # end printarray
-
-sub printList {
-    print "(";
-    while (@_) {
-	my $v = shift @_;
-	printItem $v;
-	if ($v =~ /^-\w+/) {
-	    print " => ";
-	} elsif (@_) {
-	    print ", ";
-	}
-    }
-    print ")";
-} # end printList
-
 1;
 
 
diff --git a/Perl/Zinc/TraceErrors.pm b/Perl/Zinc/TraceErrors.pm
new file mode 100644
index 0000000..f5d1069
--- /dev/null
+++ b/Perl/Zinc/TraceErrors.pm
@@ -0,0 +1,82 @@
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in Tk/license.terms due to partial
+# derivation from Tk8.0 sources.
+#
+# Copyright (c) 2003 CENA, D.Etienne <etienne@cena.fr> to trace all
+# Tk::Zinc errors.
+#
+# This package overloads the Tk::Zinc::WidgetMethods function in order to
+# to trap errors by calling every Tk::Zinc method in an eval() block.
+#
+# This may be very usefull when your application encounters errors such as
+# "error .... at /usr/lib/perl5/Tk.pm line 228". With ZincTraceErrors, the
+# module name, the line number and the complete error messages are reported
+# for each error.
+#
+# When you have no idea where this happens in your code or when your
+# application segfaults, use the ZincTrace package which traces every
+# Tk::Zinc method call.
+#
+# for using this file do some thing like :
+# perl -MZincTraceErrors myappli.pl
+
+package ZincTraceErrors;
+
+use Tk;
+use strict;
+use ZincTraceUtils;
+
+my $WidgetMethodfunction;
+my $bold = "";
+my $_bold = "";
+
+BEGIN {
+    my $bold = "";
+    my $_bold = "";
+    
+    if ($ZincTrace::on == 1) {
+	print STDERR $bold."ZincTraceErrors: incompatible package ZincTrace is already ".
+	    "loaded".$_bold." (exit 1)\n";
+	exit 1;
+    }
+    print $bold."ZincTraceErrors is ON".$_bold."\n";
+    $ZincTraceErrors::on = 1;
+    select STDOUT; $|=1; ## for flushing the trace output
+    # save current Tk::Zinc::InitObject function; it will be invoked in
+    # overloaded one (see below)
+    use Tk;
+    use Tk::Zinc;
+    $WidgetMethodfunction = Tk::Zinc->can('WidgetMethod');
+    
+}
+
+sub Tk::Zinc::WidgetMethod {
+    my ($zinc, $name, @args) = @_;
+    my ($package, $filename, $line) = caller(1);
+    $package="" unless defined $package;
+    $filename="" unless defined $filename;
+    $line="" unless defined $line;
+    # invoke function possibly overloaded in other modules
+    my $res;
+    eval {$res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;};
+    if ($@) {
+	print $bold."error:".$_bold." $filename line $line $name";
+	&printList (@args);
+	my $msg = $@;
+	$msg =~ s/at .*//g;
+	print " ".$bold."returns".$_bold." $msg\n";
+    }
+    return $res;
+}
+    
+    
+
+1;
+
+
+
diff --git a/Perl/debug/ZincTraceUtils.pm b/Perl/debug/ZincTraceUtils.pm
new file mode 100644
index 0000000..60628a8
--- /dev/null
+++ b/Perl/debug/ZincTraceUtils.pm
@@ -0,0 +1,90 @@
+package ZincTraceUtils;
+
+use Tk;
+use strict;
+use Tk::Font;
+use Tk::Photo;
+use vars qw(@EXPORT);
+@EXPORT = qw(printItem printArray printList);
+
+
+### to print something
+sub printItem {
+    my ($value) = @_;
+    my $ref = ref($value);
+#    print "VALUE=$value REF=$ref\n";
+    if ($ref eq 'ARRAY') {
+	printArray ( @{$value} );
+    }
+    elsif ($ref eq 'CODE') {
+	print "{CODE}";
+    }
+    elsif ($ref eq 'Tk::Photo') {
+#	print " **** $value ***** ";
+	print "Tk::Photo(\"". scalar $value->cget('-file') . "\")";
+    }
+    elsif ($ref eq 'Tk::Font') {
+	print "'$value'";
+    }
+    elsif ($ref eq '') {  # scalar 
+	if (defined $value) {
+	    if ($value eq '') {
+		print  "''";
+	    } elsif ($value =~ /\s/
+		     or $value =~ /^[a-zA-Z]/
+		     or $value =~ /^[\W]$/ ) {
+		print "'$value'";
+	    }  else {
+		print $value;
+	    }
+	}
+	else {
+	    print "undef";
+	}
+    }
+    else { # some  class instance
+	return $value;
+    }
+    
+} # end printitem
+
+
+### to print a list of something
+sub printArray {
+    my (@values) = @_;
+    if (! scalar @values) {
+	print "[]";
+    }
+    else {  # the list is not empty
+	my @res;
+	print "[";
+	while (@values) {
+	    my $value = shift @values;
+	    &printItem ($value);
+	    print ", " if (@values);
+	}
+	print "]" ;
+    }
+    
+} # end printArray
+
+
+sub printList {
+    print "(";
+    while (@_) {
+	my $v = shift @_;
+	printItem $v;
+	if ($v =~ /^-\w+/) {
+	    print " => ";
+	} elsif (@_) {
+	    print ", ";
+	}
+    }
+    print ")";
+    
+} # end printList
+
+1;
+
+
+