Plutot que redefinir Tk::Methods, on surcharge Tk::Zinc::WidgetMethod. Ainsi,

ZincDebug ou un autre plugin peut etre charg� avant ZincTrace.

1 files changed, 35 insertions, 51 deletions

diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm
index c78b9fc..0d11b54 100644
--- a/Perl/Zinc/Trace.pm
+++ b/Perl/Zinc/Trace.pm
@@ -21,7 +21,6 @@
 # for using this file do some thing like :
 # perl -MZincTrace myappli.pl
 
-BEGIN { print "ZincTrace is ON\n"; select STDOUT; $|=1 } ## for flushing the trace output
 package ZincTrace;
 
 use Tk;
@@ -31,44 +30,43 @@ use Tk::Photo;
 
 use Carp;
 
-my $asCode = 0;
-#$asCode = 1;
-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 ($asCode) {
-					  print "$obj->$name";
-					  &printList (@_);
-					  print ";";
-				      } elsif ($obj =~ /^Tk::Zinc/) {
-					  print "TRACE: $filename line $line $name";
-					  &printList (@_);
-				      }
-				      if (wantarray()) {
-					  my @res = $obj->WidgetMethod($name,@_);
-					  print "  RETURNS ";
-					  &printList (@res); print "\n";
-					  $obj->update;
-					  return @res;
-				      } else {
-					  my $res = $obj->WidgetMethod($name,@_);
-					  print "  RETURNS ";
-					  &printItem ($res); print "\n";
-					  $obj->update;
-					  return $res;
-				      }
-				  }
+my $WidgetMethodfunction;
+BEGIN {
+    print "ZincTrace is ON\n";
+    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;
+    print "TRACE: $filename line $line $name";
+    &printList (@_);
+    # invoke function possibly overloaded in other modules
+    if (wantarray()) {
+	my @res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;
+	print "  RETURNS ";
+	&printList (@res); print "\n";
+	$zinc->update;
+	return @res;
+    } else {
+	my $res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;
+	print "  RETURNS ";
+	&printItem ($res); print "\n";
+	$zinc->update;
+	return $res;
     }
 }
+    
+    
 
 ### to print something
 sub printItem {
@@ -141,20 +139,6 @@ sub printList {
     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;