aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Perl/Zinc/Trace.pm130
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;
+
+
+