aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/Zinc/Trace.pm86
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;