summaryrefslogtreecommitdiffstats
path: root/library/bgerror.tcl
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-04-01 09:51:44 (GMT)
committerrjohnson <rjohnson>1998-04-01 09:51:44 (GMT)
commit066ea7fd88d49cb456f74da71dbe875e4fc0aabb (patch)
tree8fb30cb152c4dc191be47fa043d2e6f5ea38c7ba /library/bgerror.tcl
parent13242623d2ff3ea02ab6a62bfb48a7dbb5c27e22 (diff)
downloadtk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.zip
tk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.tar.gz
tk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.tar.bz2
Initial revision
Diffstat (limited to 'library/bgerror.tcl')
-rw-r--r--library/bgerror.tcl99
1 files changed, 99 insertions, 0 deletions
diff --git a/library/bgerror.tcl b/library/bgerror.tcl
new file mode 100644
index 0000000..d2b1cdc
--- /dev/null
+++ b/library/bgerror.tcl
@@ -0,0 +1,99 @@
+# bgerror.tcl --
+#
+# This file contains a default version of the bgerror procedure. It
+# posts a dialog box with the error message and gives the user a chance
+# to see a more detailed stack trace.
+#
+# SCCS: @(#) bgerror.tcl 1.16 97/08/06 09:19:50
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+
+# bgerror --
+# This is the default version of bgerror.
+# It tries to execute tkerror, if that fails it posts a dialog box containing
+# the error message and gives the user a chance to ask to see a stack
+# trace.
+# Arguments:
+# err - The error message.
+
+proc bgerror err {
+ global errorInfo tcl_platform
+
+ # save errorInfo which would be erased in the catch below otherwise.
+ set info $errorInfo ;
+
+ # For backward compatibility :
+ # Let's try to execute "tkerror" (using catch {tkerror ...}
+ # instead of searching it with info procs so the application gets
+ # a chance to auto load it using its favorite "unknown" mecanism.
+ # (we do the default dialog only if we get a TCL_ERROR (=1) return
+ # code from the tkerror trial, other ret codes are passed back
+ # to our caller (tcl background error handler) so the called "tkerror"
+ # can still use return -code break, to skip remaining messages
+ # in the error queue for instance) -- dl
+ set ret [catch {tkerror $err} msg];
+ if {$ret != 1} {return -code $ret $msg}
+
+ # Ok the application's tkerror either failed or was not found
+ # we use the default dialog then :
+ if {$tcl_platform(platform) == "macintosh"} {
+ set ok Ok
+ } else {
+ set ok OK
+ }
+ set button [tk_dialog .bgerrorDialog "Error in Tcl Script" \
+ "Error: $err" error 0 $ok "Skip Messages" "Stack Trace"]
+ if {$button == 0} {
+ return
+ } elseif {$button == 1} {
+ return -code break
+ }
+
+ set w .bgerrorTrace
+ catch {destroy $w}
+ toplevel $w -class ErrorTrace
+ wm minsize $w 1 1
+ wm title $w "Stack Trace for Error"
+ wm iconname $w "Stack Trace"
+ button $w.ok -text OK -command "destroy $w" -default active
+ if {$tcl_platform(platform) == "macintosh"} {
+ text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \
+ -yscrollcommand "$w.scroll set" -width 60 -height 20
+ } else {
+ text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
+ -setgrid true -width 60 -height 20
+ }
+ scrollbar $w.scroll -relief sunken -command "$w.text yview"
+ pack $w.ok -side bottom -padx 3m -pady 2m
+ pack $w.scroll -side right -fill y
+ pack $w.text -side left -expand yes -fill both
+ $w.text insert 0.0 $info
+ $w.text mark set insert 0.0
+
+ bind $w <Return> "destroy $w"
+ bind $w.text <Return> "destroy $w; break"
+
+ # Center the window on the screen.
+
+ wm withdraw $w
+ update idletasks
+ set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
+ - [winfo vrootx [winfo parent $w]]]
+ set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
+ - [winfo vrooty [winfo parent $w]]]
+ wm geom $w +$x+$y
+ wm deiconify $w
+
+ # Be sure to release any grabs that might be present on the
+ # screen, since they could make it impossible for the user
+ # to interact with the stack trace.
+
+ if {[grab current .] != ""} {
+ grab release [grab current .]
+ }
+}