blob: 0a2b7c4b158328a91ef20360643b54c42ada1a95 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
#
# 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 and
# when you have no idea where this happens in your code.
#
# To trap Tk::Zinc errors, use rather the ZincTraceErrors package.
#
# for using this file do some thing like :
# perl -MZincTrace myappli.pl
package ZincTrace;
use Tk;
use strict;
use ZincTraceUtils;
my $WidgetMethodfunction;
BEGIN {
if ($ZincTraceErrors::on == 1) {
print STDERR "ZincTrace: incompatible package ZincTraceErrors is already ".
"loaded (exit 1)\n";
exit 1;
}
print "ZincTrace is ON\n";
$ZincTrace::on = 1;
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(@args);
# 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;
}
}
1;
|
