SGI/util/SGI/lib/tk8.0/bgerror.tcl

   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 # SCCS: @(#) bgerror.tcl 1.16 97/08/06 09:19:50
   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)  -- dl
  39     set ret [catch {tkerror $err} msg];
  40     if {$ret != 1} {return -code $ret $msg}
  41
  42     # Ok the application's tkerror either failed or was not found
  43     # we use the default dialog then :
  44     if {$tcl_platform(platform) == "macintosh"} {
  45         set ok Ok
  46     } else {
  47         set ok OK
  48     }
  49     set button [tk_dialog .bgerrorDialog "Error in Tcl Script" \
  50             "Error: $err" error 0 $ok "Skip Messages" "Stack Trace"]
  51     if {$button == 0} {
  52         return
  53     } elseif {$button == 1} {
  54         return -code break
  55     }
  56
  57     set w .bgerrorTrace
  58     catch {destroy $w}
  59     toplevel $w -class ErrorTrace
  60     wm minsize $w 1 1
  61     wm title $w "Stack Trace for Error"
  62     wm iconname $w "Stack Trace"
  63     button $w.ok -text OK -command "destroy $w" -default active
  64     if {$tcl_platform(platform) == "macintosh"} {
  65       text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \
  66             -yscrollcommand "$w.scroll set" -width 60 -height 20
  67     } else {
  68       text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
  69             -setgrid true -width 60 -height 20
  70     }
  71     scrollbar $w.scroll -relief sunken -command "$w.text yview"
  72     pack $w.ok -side bottom -padx 3m -pady 2m
  73     pack $w.scroll -side right -fill y
  74     pack $w.text -side left -expand yes -fill both
  75     $w.text insert 0.0 $info
  76     $w.text mark set insert 0.0
  77
  78     bind $w <Return> "destroy $w"
  79     bind $w.text <Return> "destroy $w; break"
  80
  81     # Center the window on the screen.
  82
  83     wm withdraw $w
  84     update idletasks
  85     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  86             - [winfo vrootx [winfo parent $w]]]
  87     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  88             - [winfo vrooty [winfo parent $w]]]
  89     wm geom $w +$x+$y
  90     wm deiconify $w
  91
  92     # Be sure to release any grabs that might be present on the
  93     # screen, since they could make it impossible for the user
  94     # to interact with the stack trace.
  95
  96     if {[grab current .] != ""} {
  97         grab release [grab current .]
  98     }
  99 }