diff options
Diffstat (limited to 'Perl/Zinc')
-rw-r--r-- | Perl/Zinc/Trace.pm | 93 | ||||
-rw-r--r-- | Perl/Zinc/TraceErrors.pm | 82 |
2 files changed, 94 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 = "[1m"; +my $_bold = "[m"; + +BEGIN { + my $bold = "[1m"; + my $_bold = "[m"; + + 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; + + + |