Ajout de ZincTrace, package qui surcharge la methode Tk::Methods pour

tracer les appels aux methodes zinc.

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