From 5bdb20ff19a28dafbf07e6ed98de62411947f667 Mon Sep 17 00:00:00 2001 From: etienne Date: Wed, 4 Jun 2003 14:18:45 +0000 Subject: 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 --- Perl/Zinc/Trace.pm | 93 ++++++-------------------------------------- Perl/Zinc/TraceErrors.pm | 82 ++++++++++++++++++++++++++++++++++++++ Perl/debug/ZincTraceUtils.pm | 90 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 184 insertions(+), 81 deletions(-) create mode 100644 Perl/Zinc/TraceErrors.pm create mode 100644 Perl/debug/ZincTraceUtils.pm 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 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; + + + -- cgit v1.1