diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/bgerror.tcl | 292 |
1 files changed, 226 insertions, 66 deletions
diff --git a/library/bgerror.tcl b/library/bgerror.tcl index 398e140..d3bb58c 100644 --- a/library/bgerror.tcl +++ b/library/bgerror.tcl @@ -1,17 +1,77 @@ # 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. +# Implementation 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, and possible do something more interesting with that +# trace (like save it to a log). This is adapted from work done by +# Donal K. Fellows. # -# RCS: @(#) $Id: bgerror.tcl,v 1.8 2000/04/18 02:18:33 ericm Exp $ -# -# 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. +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: bgerror.tcl,v 1.9 2000/05/31 23:28:46 ericm Exp $ +# $Id: bgerror.tcl,v 1.9 2000/05/31 23:28:46 ericm Exp $ + +option add *ErrorDialog.message.wrapLength 3.5i widgetDefault +option add *ErrorDialog.function.text "Save To Log" widgetDefault +option add *ErrorDialog.function.command "::tk::dialog::error::saveToLog" + +namespace eval ::tk {} +namespace eval ::tk::dialog {} +namespace eval ::tk::dialog::error {} + +proc ::tk::dialog::error::Return {} { + variable button + + .bgerrorDialog.ok configure -state active -relief sunken + update idletasks + after 100 + set button 0 +} + +proc ::tk::dialog::error::details {} { + set w .bgerrorDialog + set caption [option get $w.function text {}] + set command [option get $w.function command {}] + if { [string equal $caption ""] || [string equal $command ""] } { + grid forget $w.function + } + $w.function configure -text $caption \ + -command [list ::tk::dialog::error::evalFunction $command] + grid $w.top.info - -sticky nsew -padx 3m -pady 3m +} + +proc ::tk::dialog::error::evalFunction {cmd} { + uplevel \#0 [list $cmd [.bgerrorDialog.top.info.text get 1.0 end]] +} + +proc ::tk::dialog::error::saveToLog {text} { + if { [string equal $::tcl_platform(platform) "windows"] } { + set allFiles "*.*" + } else { + set allFiles "*" + } + set types [list \ + [list "Log Files" .log] \ + [list "Text Files" .txt] \ + [list "All Files" $allFiles] \ + ] + set filename [tk_getSaveFile -title "Select Log File" \ + -filetypes $types -defaultextension .log -parent .bgerrorDialog] + if {![string length $filename]} { + return + } + set f [open $filename w] + puts -nonewline $text + close $f +} +proc ::tk::dialog::error::Destroy {w} { + if {".bgerrorDialog" == "$w"} { + variable button + set button -1 + } +} # bgerror -- # This is the default version of bgerror. @@ -23,19 +83,9 @@ 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) + set butvar ::tk::dialog::error::button + + set info $errorInfo set ret [catch {tkerror $err} msg]; if {$ret != 1} {return -code $ret $msg} @@ -43,58 +93,168 @@ proc bgerror err { # 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 + set ok "Ok" + set messageFont system + set textRelief "flat" + set textHilight 0 } else { - set ok OK + set ok "OK" + set messageFont {Times -18} + set textRelief "sunken" + set textHilight 1 } - 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 .bgerrorDialog + set title "Application Error" + set text "Error: $err" + set buttons [list ok $ok dismiss "Skip Messages" function "Details >>"] + + # 1. Create the top-level window and divide it into top + # and bottom parts. + + catch {destroy .bgerrorDialog} + toplevel .bgerrorDialog -class ErrorDialog + wm title .bgerrorDialog $title + wm iconname .bgerrorDialog ErrorDialog + wm protocol .bgerrorDialog WM_DELETE_WINDOW { } + + # The following, though surprising, works. + wm transient .bgerrorDialog .bgerrorDialog + + if {$tcl_platform(platform) == "macintosh"} { + unsupported1 style .bgerrorDialog dBoxProc + } + + frame .bgerrorDialog.bot + frame .bgerrorDialog.top + if {$tcl_platform(platform) == "unix"} { + .bgerrorDialog.bot configure -relief raised -bd 1 + .bgerrorDialog.top configure -relief raised -bd 1 } + pack .bgerrorDialog.bot -side bottom -fill both + pack .bgerrorDialog.top -side top -fill both -expand 1 + + set W [frame $w.top.info] + text $W.text \ + -bd 2 \ + -yscrollcommand "$W.scroll set" \ + -setgrid true \ + -width 40 \ + -height 10 \ + -state normal \ + -relief $textRelief \ + -highlightthickness $textHilight \ + -wrap char + + scrollbar $W.scroll -relief sunken -command "$W.text yview" + 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 + $W.text configure -state disabled + + # 2. Fill the top part with bitmap and message (use the option + # database for -wraplength so that it can be overridden by + # the caller). - 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 {![string compare $tcl_platform(platform) "macintosh"]} { - text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \ - -yscrollcommand "$w.scroll set" -width 60 -height 20 + label .bgerrorDialog.msg -justify left -text $text -font $messageFont + if { [string equal $tcl_platform(platform) "macintosh"] } { + # On the Macintosh, use the stop bitmap + label .bgerrorDialog.bitmap -bitmap stop } else { - text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \ - -setgrid true -width 60 -height 20 + # On other platforms, make the error icon + canvas .bgerrorDialog.bitmap -width 32 -height 32 -highlightthickness 0 + .bgerrorDialog.bitmap create oval 0 0 31 31 -fill red -outline black + .bgerrorDialog.bitmap create line 9 9 23 23 -fill white -width 4 + .bgerrorDialog.bitmap create line 9 23 23 9 -fill white -width 4 } - 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 + grid .bgerrorDialog.bitmap .bgerrorDialog.msg \ + -in .bgerrorDialog.top \ + -row 0 \ + -padx 3m \ + -pady 3m + grid configure .bgerrorDialog.msg -sticky nsw + grid rowconfigure .bgerrorDialog.top 1 -weight 1 + grid columnconfigure .bgerrorDialog.top 1 -weight 1 - bind $w <Return> "destroy $w" - bind $w.text <Return> "destroy $w; break" + # 3. Create a row of buttons at the bottom of the dialog. - # Center the window on the screen. + set i 0 + foreach {name caption} $buttons { + button .bgerrorDialog.$name \ + -text $caption \ + -default normal \ + -command "set $butvar $i" + grid .bgerrorDialog.$name \ + -in .bgerrorDialog.bot \ + -column $i \ + -row 0 \ + -sticky ew \ + -padx 10 + grid columnconfigure .bgerrorDialog.bot $i -weight 1 + # We boost the size of some Mac buttons for l&f + if {$tcl_platform(platform) == "macintosh"} { + if {($name == "ok") || ($name == "dismiss")} { + grid columnconfigure .bgerrorDialog.bot $i -minsize 79 + } + } + incr i + } + # The "OK" button is the default for this dialog. + .bgerrorDialog.ok configure -default active + + set ::tk::dialog::error::curh 0 + bind .bgerrorDialog <Return> {::tk::dialog::error::Return} + bind .bgerrorDialog <Destroy> {::tk::dialog::error::Destroy %W} + .bgerrorDialog.function configure \ + -command {::tk::dialog::error::details } + + # 6. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. - wm withdraw $w + wm withdraw .bgerrorDialog 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 {[string compare [grab current .] ""]} { - grab release [grab current .] + set parent [winfo parent .bgerrorDialog] + set width [winfo reqwidth .bgerrorDialog] + set height [winfo reqheight .bgerrorDialog] + set x [expr ([winfo screenwidth .bgerrorDialog] - $width )/2 - \ + [winfo vrootx $parent]] + set y [expr ([winfo screenheight .bgerrorDialog] - $height)/2 - \ + [winfo vrooty $parent]] + .bgerrorDialog configure -width $width + wm geometry .bgerrorDialog +$x+$y + wm deiconify .bgerrorDialog + + # 7. Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current .bgerrorDialog] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] + } + grab .bgerrorDialog + focus .bgerrorDialog.ok + + # 8. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable $butvar + set button $::tk::dialog::error::button; # Save a copy... + catch {focus $oldFocus} + catch {destroy .bgerrorDialog} + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + + if {$button == 1} { + return -code break } } |