Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::ErrorDialog; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.009'; # $Id: //depot/Tk8/Tk/ErrorDialog.pm#9 $ | |
5 | ||
6 | use English; | |
7 | use Tk (); | |
8 | require Tk::Dialog; | |
9 | use base qw(Tk::Toplevel); | |
10 | ||
11 | ||
12 | # ErrorDialog - a translation of `tkerror' from Tcl/Tk to TkPerl. | |
13 | # | |
14 | # Currently TkPerl background errors are sent to stdout/stderr; use this | |
15 | # module if you want them in a window. You can also "roll your own" by | |
16 | # supplying the routine Tk::Error. | |
17 | # | |
18 | # Stephen O. Lidie, Lehigh University Computing Center. 95/03/02 | |
19 | # lusol@Lehigh.EDU | |
20 | # | |
21 | # This is an OO implementation of `tkerror', with a twist: since there is | |
22 | # only one ErrorDialog object, you aren't required to invoke the constructor | |
23 | # to create it; it will be created automatically when the first background | |
24 | # error occurs. However, in order to configure the ErrorDialog object you | |
25 | # must call the constructor and create it manually. | |
26 | # | |
27 | # The ErrorDialog object essentially consists of two subwidgets: an | |
28 | # ErrorDialog widget to display the background error and a Text widget for the | |
29 | # traceback information. If required, you can invoke the configure() method | |
30 | # to change some characteristics of these subwidgets. | |
31 | # | |
32 | # Because an ErrorDialog object is a Frame widget all the composite base | |
33 | # class methods are available to you. | |
34 | # | |
35 | # Advertised widgets: error_dialog, text. | |
36 | # | |
37 | # 1) Call the constructor to create the ErrorDialog object, which in turn | |
38 | # returns a blessed reference to the new object: | |
39 | # | |
40 | # require Tk::ErrorDialog; | |
41 | # | |
42 | # $ED = $mw->ErrorDialog( | |
43 | # -cleanupcode => $code, | |
44 | # -appendtraceback => $bool, | |
45 | # ); | |
46 | # | |
47 | # mw - a window reference, usually the result of a MainWindow->new | |
48 | # call. | |
49 | # code - a CODE reference if special post-background error processing | |
50 | # is required (default is undefined). | |
51 | # bool - a boolean indicating whether or not to append successive | |
52 | # tracebacks (default is 1, do append). | |
53 | # | |
54 | ||
55 | use strict; | |
56 | ||
57 | Construct Tk::Widget 'ErrorDialog'; | |
58 | ||
59 | my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'], | |
60 | -bitmap => 'error' | |
61 | ); | |
62 | my $ED_OBJECT; | |
63 | ||
64 | sub import | |
65 | { | |
66 | my $class = shift; | |
67 | while (@_) | |
68 | { | |
69 | my $key = shift; | |
70 | my $val = shift; | |
71 | $options{$key} = $val; | |
72 | } | |
73 | } | |
74 | ||
75 | sub Populate { | |
76 | ||
77 | # ErrorDialog constructor. Uses `new' method from base class | |
78 | # to create object container then creates the dialog toplevel and the | |
79 | # traceback toplevel. | |
80 | ||
81 | my($cw, $args) = @_; | |
82 | ||
83 | my $dr = $cw->Dialog( | |
84 | -title => 'Error in '.$cw->MainWindow->name, | |
85 | -text => 'on-the-fly-text', | |
86 | -bitmap => $options{'-bitmap'}, | |
87 | -buttons => $options{'-buttons'}, | |
88 | ); | |
89 | $cw->minsize(1, 1); | |
90 | $cw->title('Stack Trace for Error'); | |
91 | $cw->iconname('Stack Trace'); | |
92 | my $t_ok = $cw->Button( | |
93 | -text => 'OK', | |
94 | -command => [ | |
95 | sub { | |
96 | shift->withdraw; | |
97 | }, $cw, | |
98 | ] | |
99 | ); | |
100 | my $t_text = $cw->Text( | |
101 | -relief => 'sunken', | |
102 | -bd => 2, | |
103 | -setgrid => 'true', | |
104 | -width => 60, | |
105 | -height => 20, | |
106 | ); | |
107 | my $t_scroll = $cw->Scrollbar( | |
108 | -relief => 'sunken', | |
109 | -command => ['yview', $t_text], | |
110 | ); | |
111 | $t_text->configure(-yscrollcommand => ['set', $t_scroll]); | |
112 | $t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m'); | |
113 | $t_scroll->pack(-side => 'right', -fill => 'y'); | |
114 | $t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both'); | |
115 | $cw->withdraw; | |
116 | ||
117 | $cw->Advertise(error_dialog => $dr); # advertise dialog widget | |
118 | $cw->Advertise(text => $t_text); # advertise text widget | |
119 | $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef], | |
120 | -appendtraceback => [ PASSIVE => undef, undef, 1 ]); | |
121 | $ED_OBJECT = $cw; | |
122 | return $cw; | |
123 | ||
124 | } # end new, ErrorDialog constructor | |
125 | ||
126 | ||
127 | sub Tk::Error { | |
128 | ||
129 | # Post a dialog box with the error message and give the user a chance | |
130 | # to see a more detailed stack trace. | |
131 | ||
132 | my($w, $error, @msgs) = @_; | |
133 | ||
134 | my $grab = $w->grab('current'); | |
135 | $grab->Unbusy if (defined $grab); | |
136 | ||
137 | $w->ErrorDialog if not defined $ED_OBJECT; | |
138 | ||
139 | my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text')); | |
140 | chop $error; | |
141 | $d->configure(-text => "Error: $error"); | |
142 | $d->bell; | |
143 | my $ans = $d->Show; | |
144 | ||
145 | $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'}; | |
146 | $t->insert('end', "\n"); | |
147 | $t->mark('set', 'ltb', 'end'); | |
148 | $t->insert('end', "--- Begin Traceback ---\n$error\n"); | |
149 | my $msg; | |
150 | for $msg (@msgs) { | |
151 | $t->insert('end', "$msg\n"); | |
152 | } | |
153 | $t->yview('ltb'); | |
154 | ||
155 | $ED_OBJECT->deiconify if ($ans =~ /trace/i); | |
156 | ||
157 | my $c = $ED_OBJECT->{Configure}{'-cleanupcode'}; | |
158 | &$c if defined $c; # execute any cleanup code if it was defined | |
159 | $w->break if ($ans =~ /skip/i); | |
160 | ||
161 | } # end Tk::Error | |
162 | ||
163 | ||
164 | 1; |