diff options
| -rw-r--r-- | Perl/Zinc/Trace.pm | 130 |
1 files changed, 130 insertions, 0 deletions
diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm new file mode 100644 index 0000000..77d3460 --- /dev/null +++ b/Perl/Zinc/Trace.pm @@ -0,0 +1,130 @@ +# +# 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) 2002 CENA, C.Mertz <mert@cena.fr> to trace all +# Tk::Zinc methods calls as well as the args in a human readable +# form. Updated by D.Etienne. +# +# 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 +# +# for using this file do some thing like : +# perl -MZincTrace myappli.pl + +package ZincTrace; + +use Tk; +use strict; + +use Carp; + + +my ($lastMethod, $package, $filename, $line); +sub Tk::Methods +{ + my ($package) = caller; + no strict 'refs'; + foreach my $meth (@_) + { + my $name = $meth; + *{$package."::$meth"} = sub { $lastMethod=$package."::$meth"; + ($package, $filename, $line) = caller; + $package="" unless defined $package; + $filename="" unless defined $filename; + $line="" unless defined $line; + my $obj = shift; + if ($obj =~ /^Tk::Zinc/) { + print "$name at $filename line $line "; + &printList (@_); + print "\n"; + } + $obj->WidgetMethod($name,@_) }; + } +} + +### 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 "Tk::Photo(\"". scalar $value->cget(-file) . "\)"; + } + elsif ($ref eq '') { # scalar + if (defined $value) { + if ($value eq '') { + print "''"; + } + 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 "[ "; + foreach my $value (@values) { + &printItem ($value); + print " "; + } + print "]" ; + } +} # end printarray + +sub printList { + print "( "; + foreach (@_) { + printItem $_; + print " "; + } + print ")"; +} # end printList + + +sub Tk::Error +{my $w = shift; + my $error = shift; + if (Exists($w)) + { + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + } + chomp($error); + warn "Tk::Error: $error in $lastMethod at $filename line $line\n";#, join("\n ",@_)."\n"; +# carp "Tk::Error:CM:: $error\n " . join("\n ",@_)."\n"; +} + +1; + + + |