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