| # bgerror.tcl - Send bug report in response to uncaught Tcl error. |
| # Copyright (C) 1997, 1998, 1999 Cygnus Solutions. |
| # Written by Tom Tromey <tromey@cygnus.com>. |
| |
| proc bgerror err { |
| global errorInfo errorCode |
| |
| set info $errorInfo |
| set code $errorCode |
| |
| # log the error to the debug window or file |
| dbug E $info |
| dbug E $code |
| |
| set command [list tk_dialog .bgerrorDialog [gettext "GDB Error"] \ |
| [format [gettext "Error: %s"] $err] \ |
| error 0 [gettext "OK"]] |
| lappend command [gettext "Stack Trace"] |
| |
| |
| set value [eval $command] |
| if {$value == 0} { |
| return |
| } |
| |
| 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 |
| 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 "errorCode is $errorCode" |
| $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 .] |
| } |
| } |