aboutsummaryrefslogtreecommitdiff
path: root/Perl/Zinc/TraceErrors.pm
blob: f5d106975d26b3220545b577dcc36dd5860342fa (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
#
# 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 ZincTraceUtils;

my $WidgetMethodfunction;
my $bold = "";
my $_bold = "";

BEGIN {
    my $bold = "";
    my $_bold = "";
    
    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;
    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";
    }
    return $res;
}
    
    

1;