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
|
package Tk::ErrorDialog;
use vars qw($VERSION);
$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
use Tk ();
require Tk::Dialog;
use base qw(Tk::Toplevel);
# ErrorDialog - a translation of bgerror() from Tcl/Tk to Perl/Tk.
#
# Currently TkPerl background errors are sent to stdout/stderr; use this
# module if you want them in a window. You can also "roll your own" by
# supplying the routine Tk::Error.
use strict;
Construct Tk::Widget 'ErrorDialog';
my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'],
-bitmap => 'error'
);
my $ED_OBJECT;
sub import
{
my $class = shift;
while (@_)
{
my $key = shift;
my $val = shift;
$options{$key} = $val;
}
}
sub Populate {
# ErrorDialog constructor. Uses `new' method from base class
# to create object container then creates the dialog toplevel and the
# traceback toplevel.
my($cw, $args) = @_;
my $dr = $cw->Dialog(
-title => 'Error in '.$cw->MainWindow->name,
-text => 'on-the-fly-text',
-bitmap => $options{'-bitmap'},
-buttons => $options{'-buttons'},
);
$cw->minsize(1, 1);
$cw->title('Stack Trace for Error');
$cw->iconname('Stack Trace');
my $t_ok = $cw->Button(
-text => 'OK',
-command => [
sub {
shift->withdraw;
}, $cw,
]
);
my $t_text = $cw->Text(
-relief => 'sunken',
-bd => 2,
-setgrid => 'true',
-width => 60,
-height => 20,
);
my $t_scroll = $cw->Scrollbar(
-relief => 'sunken',
-command => ['yview', $t_text],
);
$t_text->configure(-yscrollcommand => ['set', $t_scroll]);
$t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m');
$t_scroll->pack(-side => 'right', -fill => 'y');
$t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both');
$cw->withdraw;
$cw->Advertise(error_dialog => $dr); # advertise dialog widget
$cw->Advertise(text => $t_text); # advertise text widget
$cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef],
-appendtraceback => [ PASSIVE => undef, undef, 1 ]);
$ED_OBJECT = $cw;
$cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw});
return $cw;
} # end Populate
sub Tk::Error {
# Post a dialog box with the error message and give the user a chance
# to see a more detailed stack trace.
my($w, $error, @msgs) = @_;
my $grab = $w->grab('current');
$grab->Unbusy if (defined $grab);
$w->ErrorDialog if not defined $ED_OBJECT;
my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text'));
# chop $error;
$d->configure(-text => "Error: $error");
$d->bell;
my $ans = $d->Show;
$t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'};
$t->insert('end', "\n");
$t->mark('set', 'ltb', 'end');
$t->insert('end', "--- Begin Traceback ---\n$error\n");
my $msg;
for $msg (@msgs) {
$t->insert('end', "$msg\n");
}
$t->yview('ltb');
$ED_OBJECT->deiconify if ($ans =~ /trace/i);
my $c = $ED_OBJECT->{Configure}{'-cleanupcode'};
&$c if defined $c; # execute any cleanup code if it was defined
$w->break if ($ans =~ /skip/i);
} # end Tk::Error
1;
|
