home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.8.3.809-MSWin32-x86.msi / _61899c025f67fefd7020dd4105da71c7 < prev    next >
Encoding:
Text File  |  2004-02-02  |  4.9 KB  |  165 lines

  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;
  165.