* library/bgerror.tcl: Improved bgerror based on work by Donal

K. Fellows; no longer dependant on tk_dialog; features a
Windows-esque "Details" button, and a customizable extra function
button that allows the user to (for example) save the stack trace
to a file.


FossilOrigin-Name: 07f7224553d34cc2628b75cd8c35f6442973f31c

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
     }
 }