← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to Tk/ErrorDialog.pm

  • Committer: Bazaar Package Importer
  • Author(s): Colin Tuckley
  • Date: 2010-05-30 09:19:40 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20100530091940-wbmq9bloo92t9m6x
Tags: 1:804.029-1
http://bugs.debian.org/578814
* New Upstream Release (Closes: #578814).
* Added debian/watch file.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tk/ErrorDialog.pm
1
1
package Tk::ErrorDialog;
2
2
 
3
3
use vars qw($VERSION);
4
 
$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
 
4
#$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
 
5
$VERSION = '4.008';
5
6
 
6
7
use Tk ();
7
8
require Tk::Dialog;
21
22
my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'],
22
23
                -bitmap  => 'error'
23
24
              );
24
 
my $ED_OBJECT;
 
25
my %ED_OBJECT; # ErrorDialog per MainWindow (singleton)
25
26
 
26
27
sub import
27
28
{
42
43
 
43
44
    my($cw, $args) = @_;
44
45
 
45
 
    my $dr = $cw->Dialog(
46
 
        -title          => 'Error in '.$cw->MainWindow->name,
 
46
    my $mw = $cw->MainWindow;
 
47
    my $dr = $mw->Dialog(
 
48
        -title          => 'Error in '.$mw->name,
47
49
        -text           => 'on-the-fly-text',
48
50
        -bitmap         => $options{'-bitmap'},
49
51
        -buttons        => $options{'-buttons'},
80
82
    $cw->Advertise(text => $t_text);     # advertise text widget
81
83
    $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef],
82
84
                     -appendtraceback => [ PASSIVE => undef, undef, 1 ]);
83
 
    $ED_OBJECT = $cw;
 
85
    $ED_OBJECT{$mw} = $cw;
84
86
    $cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw});
85
87
    return $cw;
86
88
 
96
98
    my $grab = $w->grab('current');
97
99
    $grab->Unbusy if (defined $grab);
98
100
 
99
 
    $w->ErrorDialog if not defined $ED_OBJECT;
100
 
 
101
 
    my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text'));
102
 
#   chop $error;
 
101
    my $mw = $w->MainWindow;
 
102
    my $ed = $ED_OBJECT{$mw} || $w->ErrorDialog;
 
103
 
 
104
    my($d, $t) = ($ed->Subwidget('error_dialog'), $ed->Subwidget('text'));
 
105
 
103
106
    $d->configure(-text => "Error:  $error");
104
107
    $d->bell;
 
108
    $mw->deiconify if $mw->state ne 'normal';
105
109
    my $ans = $d->Show;
106
110
 
107
 
    $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'};
 
111
    $t->delete('0.0', 'end') if not $ed->{'-appendtraceback'};
108
112
    $t->insert('end', "\n");
109
113
    $t->mark('set', 'ltb', 'end');
110
114
    $t->insert('end', "--- Begin Traceback ---\n$error\n");
114
118
    }
115
119
    $t->yview('ltb');
116
120
 
117
 
    $ED_OBJECT->deiconify if ($ans =~ /trace/i);
 
121
    $ed->deiconify if ($ans =~ /trace/i);
118
122
 
119
 
    my $c = $ED_OBJECT->{Configure}{'-cleanupcode'};
 
123
    my $c = $ed->{Configure}{'-cleanupcode'};
120
124
    &$c if defined $c;          # execute any cleanup code if it was defined
121
125
    $w->break if ($ans =~ /skip/i);
122
126