[37] | 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 | } |
---|