home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _61899c025f67fefd7020dd4105da71c7 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.4 KB  |  126 lines
  1. package Tk::ErrorDialog;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
  5.  
  6. use Tk ();
  7. require Tk::Dialog;
  8. use base qw(Tk::Toplevel);
  9.  
  10.  
  11. # ErrorDialog - a translation of bgerror() from Tcl/Tk to Perl/Tk.
  12. #
  13. # Currently TkPerl background errors are sent to stdout/stderr; use this
  14. # module if you want them in a window.  You can also "roll your own" by
  15. # supplying the routine Tk::Error.
  16.  
  17. use strict;
  18.  
  19. Construct Tk::Widget 'ErrorDialog';
  20.  
  21. my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'],
  22.                 -bitmap  => 'error'
  23.               );
  24. my $ED_OBJECT;
  25.  
  26. sub import
  27. {
  28.  my $class = shift;
  29.  while (@_)
  30.   {
  31.    my $key = shift;
  32.    my $val = shift;
  33.    $options{$key} = $val;
  34.   }
  35. }
  36.  
  37. sub Populate {
  38.  
  39.     # ErrorDialog constructor.  Uses `new' method from base class
  40.     # to create object container then creates the dialog toplevel and the
  41.     # traceback toplevel.
  42.  
  43.     my($cw, $args) = @_;
  44.  
  45.     my $dr = $cw->Dialog(
  46.         -title          => 'Error in '.$cw->MainWindow->name,
  47.         -text           => 'on-the-fly-text',
  48.         -bitmap         => $options{'-bitmap'},
  49.     -buttons        => $options{'-buttons'},
  50.     );
  51.     $cw->minsize(1, 1);
  52.     $cw->title('Stack Trace for Error');
  53.     $cw->iconname('Stack Trace');
  54.     my $t_ok = $cw->Button(
  55.         -text    => 'OK',
  56.         -command => [
  57.             sub {
  58.         shift->withdraw;
  59.         }, $cw,
  60.         ]
  61.     );
  62.     my $t_text = $cw->Text(
  63.         -relief  => 'sunken',
  64.         -bd      => 2,
  65.         -setgrid => 'true',
  66.         -width   => 60,
  67.         -height  => 20,
  68.     );
  69.     my $t_scroll = $cw->Scrollbar(
  70.         -relief => 'sunken',
  71.         -command => ['yview', $t_text],
  72.     );
  73.     $t_text->configure(-yscrollcommand => ['set', $t_scroll]);
  74.     $t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m');
  75.     $t_scroll->pack(-side => 'right', -fill => 'y');
  76.     $t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both');
  77.     $cw->withdraw;
  78.  
  79.     $cw->Advertise(error_dialog => $dr); # advertise dialog widget
  80.     $cw->Advertise(text => $t_text);     # advertise text widget
  81.     $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef],
  82.                      -appendtraceback => [ PASSIVE => undef, undef, 1 ]);
  83.     $ED_OBJECT = $cw;
  84.     $cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw});
  85.     return $cw;
  86.  
  87. } # end Populate
  88.  
  89. sub Tk::Error {
  90.  
  91.     # Post a dialog box with the error message and give the user a chance
  92.     # to see a more detailed stack trace.
  93.  
  94.     my($w, $error, @msgs) = @_;
  95.  
  96.     my $grab = $w->grab('current');
  97.     $grab->Unbusy if (defined $grab);
  98.  
  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;
  103.     $d->configure(-text => "Error:  $error");
  104.     $d->bell;
  105.     my $ans = $d->Show;
  106.  
  107.     $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'};
  108.     $t->insert('end', "\n");
  109.     $t->mark('set', 'ltb', 'end');
  110.     $t->insert('end', "--- Begin Traceback ---\n$error\n");
  111.     my $msg;
  112.     for $msg (@msgs) {
  113.     $t->insert('end', "$msg\n");
  114.     }
  115.     $t->yview('ltb');
  116.  
  117.     $ED_OBJECT->deiconify if ($ans =~ /trace/i);
  118.  
  119.     my $c = $ED_OBJECT->{Configure}{'-cleanupcode'};
  120.     &$c if defined $c;        # execute any cleanup code if it was defined
  121.     $w->break if ($ans =~ /skip/i);
  122.  
  123. } # end Tk::Error
  124.  
  125. 1;
  126.