# bgerror.tcl - Send bug report in response to uncaught Tcl error.
|
# bgerror.tcl - Send bug report in response to uncaught Tcl error.
|
# Copyright (C) 1997, 1998, 1999 Cygnus Solutions.
|
# Copyright (C) 1997, 1998, 1999 Cygnus Solutions.
|
# Written by Tom Tromey <tromey@cygnus.com>.
|
# Written by Tom Tromey <tromey@cygnus.com>.
|
|
|
proc bgerror err {
|
proc bgerror err {
|
global errorInfo errorCode
|
global errorInfo errorCode
|
|
|
set info $errorInfo
|
set info $errorInfo
|
set code $errorCode
|
set code $errorCode
|
|
|
# log the error to the debug window or file
|
# log the error to the debug window or file
|
dbug E $info
|
dbug E $info
|
dbug E $code
|
dbug E $code
|
|
|
set command [list tk_dialog .bgerrorDialog [gettext "GDB Error"] \
|
set command [list tk_dialog .bgerrorDialog [gettext "GDB Error"] \
|
[format [gettext "Error: %s"] $err] \
|
[format [gettext "Error: %s"] $err] \
|
error 0 [gettext "OK"]]
|
error 0 [gettext "OK"]]
|
lappend command [gettext "Stack Trace"]
|
lappend command [gettext "Stack Trace"]
|
|
|
|
|
set value [eval $command]
|
set value [eval $command]
|
if {$value == 0} {
|
if {$value == 0} {
|
return
|
return
|
}
|
}
|
|
|
set w .bgerrorTrace
|
set w .bgerrorTrace
|
catch {destroy $w}
|
catch {destroy $w}
|
toplevel $w -class ErrorTrace
|
toplevel $w -class ErrorTrace
|
wm minsize $w 1 1
|
wm minsize $w 1 1
|
wm title $w "Stack Trace for Error"
|
wm title $w "Stack Trace for Error"
|
wm iconname $w "Stack Trace"
|
wm iconname $w "Stack Trace"
|
button $w.ok -text OK -command "destroy $w" -default active
|
button $w.ok -text OK -command "destroy $w" -default active
|
text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
|
text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
|
-setgrid true -width 60 -height 20
|
-setgrid true -width 60 -height 20
|
scrollbar $w.scroll -relief sunken -command "$w.text yview"
|
scrollbar $w.scroll -relief sunken -command "$w.text yview"
|
pack $w.ok -side bottom -padx 3m -pady 2m
|
pack $w.ok -side bottom -padx 3m -pady 2m
|
pack $w.scroll -side right -fill y
|
pack $w.scroll -side right -fill y
|
pack $w.text -side left -expand yes -fill both
|
pack $w.text -side left -expand yes -fill both
|
$w.text insert 0.0 "errorCode is $errorCode"
|
$w.text insert 0.0 "errorCode is $errorCode"
|
$w.text insert 0.0 $info
|
$w.text insert 0.0 $info
|
$w.text mark set insert 0.0
|
$w.text mark set insert 0.0
|
|
|
bind $w <Return> "destroy $w"
|
bind $w <Return> "destroy $w"
|
bind $w.text <Return> "destroy $w; break"
|
bind $w.text <Return> "destroy $w; break"
|
|
|
# Center the window on the screen.
|
# Center the window on the screen.
|
|
|
wm withdraw $w
|
wm withdraw $w
|
update idletasks
|
update idletasks
|
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
|
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
|
- [winfo vrootx [winfo parent $w]]]
|
- [winfo vrootx [winfo parent $w]]]
|
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
|
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
|
- [winfo vrooty [winfo parent $w]]]
|
- [winfo vrooty [winfo parent $w]]]
|
wm geom $w +$x+$y
|
wm geom $w +$x+$y
|
wm deiconify $w
|
wm deiconify $w
|
|
|
# Be sure to release any grabs that might be present on the
|
# Be sure to release any grabs that might be present on the
|
# screen, since they could make it impossible for the user
|
# screen, since they could make it impossible for the user
|
# to interact with the stack trace.
|
# to interact with the stack trace.
|
|
|
if {[grab current .] != ""} {
|
if {[grab current .] != ""} {
|
grab release [grab current .]
|
grab release [grab current .]
|
}
|
}
|
}
|
}
|
|
|
