summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm
blob: 19377eaeca4277b4be30da0a8d6dd668201c1214 (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
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;