home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 April / PCWorld_2001-04_cd.bin / Software / TemaCD / webclean / !!!python!!! / BeOpen-Python-2.0.exe / BGERROR.TCL < prev    next >
Encoding:
Text File  |  2000-04-17  |  3.4 KB  |  101 lines
  1. # bgerror.tcl --
  2. #
  3. # This file contains a default version of the bgerror procedure.  It
  4. # posts a dialog box with the error message and gives the user a chance
  5. # to see a more detailed stack trace.
  6. #
  7. # RCS: @(#) $Id: bgerror.tcl,v 1.8 2000/04/18 02:18:33 ericm Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  
  15.  
  16. # bgerror --
  17. # This is the default version of bgerror. 
  18. # It tries to execute tkerror, if that fails it posts a dialog box containing
  19. # the error message and gives the user a chance to ask to see a stack
  20. # trace.
  21. # Arguments:
  22. # err -            The error message.
  23.  
  24. proc bgerror err {
  25.     global errorInfo tcl_platform
  26.     
  27.     # save errorInfo which would be erased in the catch below otherwise.
  28.     set info $errorInfo ;
  29.  
  30.     # For backward compatibility :
  31.     # Let's try to execute "tkerror" (using catch {tkerror ...} 
  32.     # instead of searching it with info procs so the application gets
  33.     # a chance to auto load it using its favorite "unknown" mecanism.
  34.     # (we do the default dialog only if we get a TCL_ERROR (=1) return
  35.     #  code from the tkerror trial, other ret codes are passed back
  36.     #  to our caller (tcl background error handler) so the called "tkerror"
  37.     #  can still use  return -code break, to skip remaining messages
  38.     #  in the error queue for instance)
  39.  
  40.     set ret [catch {tkerror $err} msg];
  41.     if {$ret != 1} {return -code $ret $msg}
  42.  
  43.     # Ok the application's tkerror either failed or was not found
  44.     # we use the default dialog then :
  45.     if {$tcl_platform(platform) == "macintosh"} {
  46.     set ok Ok
  47.     } else {
  48.     set ok OK
  49.     }
  50.     set button [tk_dialog .bgerrorDialog "Error in Tcl Script" \
  51.         "Error: $err" error 0 $ok "Skip Messages" "Stack Trace"]
  52.     if {$button == 0} {
  53.     return
  54.     } elseif {$button == 1} {
  55.     return -code break
  56.     }
  57.  
  58.     set w .bgerrorTrace
  59.     catch {destroy $w}
  60.     toplevel $w -class ErrorTrace
  61.     wm minsize $w 1 1
  62.     wm title $w "Stack Trace for Error"
  63.     wm iconname $w "Stack Trace"
  64.     button $w.ok -text OK -command "destroy $w" -default active
  65.     if {![string compare $tcl_platform(platform) "macintosh"]} {
  66.       text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \
  67.         -yscrollcommand "$w.scroll set" -width 60 -height 20
  68.     } else {
  69.       text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
  70.         -setgrid true -width 60 -height 20
  71.     }
  72.     scrollbar $w.scroll -relief sunken -command "$w.text yview"
  73.     pack $w.ok -side bottom -padx 3m -pady 2m
  74.     pack $w.scroll -side right -fill y
  75.     pack $w.text -side left -expand yes -fill both
  76.     $w.text insert 0.0 $info
  77.     $w.text mark set insert 0.0
  78.  
  79.     bind $w <Return> "destroy $w"
  80.     bind $w.text <Return> "destroy $w; break"
  81.  
  82.     # Center the window on the screen.
  83.  
  84.     wm withdraw $w
  85.     update idletasks
  86.     set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  87.         - [winfo vrootx [winfo parent $w]]}]
  88.     set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  89.         - [winfo vrooty [winfo parent $w]]}]
  90.     wm geom $w +$x+$y
  91.     wm deiconify $w
  92.  
  93.     # Be sure to release any grabs that might be present on the
  94.     # screen, since they could make it impossible for the user
  95.     # to interact with the stack trace.
  96.  
  97.     if {[string compare [grab current .] ""]} {
  98.     grab release [grab current .]
  99.     }
  100. }
  101.