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, 82 insertions, 0 deletions

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;
+
+
+