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

1 files changed, 12 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;