blob: 0d1e64f94f62d770da2ab7ebd1534434e9423cef (
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
|
#
# 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) 2003 CENA, D.Etienne <etienne@cena.fr> to trace all
# Tk::Zinc errors.
#
# This package overloads the Tk::Zinc::WidgetMethods function in order to
# to trap errors by calling every Tk::Zinc method in an eval() block.
#
# This may be very usefull when your application encounters errors such as
# "error .... at /usr/lib/perl5/Tk.pm line 228". With ZincTraceErrors, the
# module name, the line number and the complete error messages are reported
# for each error.
#
# When you have no idea where this happens in your code or when your
# application segfaults, use the ZincTrace package which traces every
# Tk::Zinc method call.
#
# for using this file do some thing like :
# perl -MZincTraceErrors myappli.pl
package ZincTraceErrors;
use Tk;
use strict;
use Tk::Zinc::TraceUtils;
my $WidgetMethodfunction;
my $bold = "[1m";
my $_bold = "[m";
BEGIN {
my $bold = "[1m";
my $_bold = "[m";
if ($ZincTrace::on == 1) {
print STDERR $bold."ZincTraceErrors: incompatible package ZincTrace is already ".
"loaded".$_bold." (exit 1)\n";
exit 1;
}
print $bold."ZincTraceErrors is ON".$_bold."\n";
$ZincTraceErrors::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;
# invoke function possibly overloaded in other modules
my ($res, @res);
if (wantarray()) {
eval {@res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;};
} else {
eval {$res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;};
}
if ($@) {
print $bold."error:".$_bold." $filename line $line $name";
&printList (@args);
my $msg = $@;
$msg =~ s/at .*//g;
print " ".$bold."returns".$_bold." $msg\n";
}
if (wantarray()) {
return @res;
} else {
return $res;
}
}
1;
|
