blob: ad0015f1b3743289cd09b45190debfb0695e5632 (
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
#
# 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 Tk::Font;
use Tk::Photo;
use Carp;
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 (@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;
}
}
### 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 " **** $value ***** ";
print "Tk::Photo(\"". scalar $value->cget('-file') . "\")";
}
elsif ($ref eq 'Tk::Font') {
print "'$value'";
}
elsif ($ref eq '') { # scalar
if (defined $value) {
if ($value eq '') {
print "''";
} elsif ($value =~ /\s/
or $value =~ /^[a-zA-Z]/
or $value =~ /^[\W]$/ ) {
print "'$value'";
} 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 "[";
while (@values) {
my $value = shift @values;
&printItem ($value);
print ", " if (@values);
}
print "]" ;
}
} # end printarray
sub printList {
print "(";
while (@_) {
my $v = shift @_;
printItem $v;
if ($v =~ /^-\w+/) {
print " => ";
} elsif (@_) {
print ", ";
}
}
print ")";
} # end printList
1;
|
