blob: 2c43305edf39c6c7a9f7d9149ccd0b21a6662cad (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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 .]
}
}
|
