summaryrefslogtreecommitdiffstats
path: root/tk8.6/library/bgerror.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tk8.6/library/bgerror.tcl')
-rw-r--r--tk8.6/library/bgerror.tcl265
1 files changed, 265 insertions, 0 deletions
diff --git a/tk8.6/library/bgerror.tcl b/tk8.6/library/bgerror.tcl
new file mode 100644
index 0000000..b15387e
--- /dev/null
+++ b/tk8.6/library/bgerror.tcl
@@ -0,0 +1,265 @@
+# bgerror.tcl --
+#
+# 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.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2007 by ActiveState Software Inc.
+# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+# Copyright (c) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+namespace eval ::tk::dialog::error {
+ namespace import -force ::tk::msgcat::*
+ namespace export bgerror
+ option add *ErrorDialog.function.text [mc "Save To Log"] \
+ widgetDefault
+ option add *ErrorDialog.function.command [namespace code SaveToLog]
+ option add *ErrorDialog*Label.font TkCaptionFont widgetDefault
+ if {[tk windowingsystem] eq "aqua"} {
+ option add *ErrorDialog*background systemAlertBackgroundActive \
+ widgetDefault
+ option add *ErrorDialog*info.text.background white widgetDefault
+ option add *ErrorDialog*Button.highlightBackground \
+ systemAlertBackgroundActive widgetDefault
+ }
+}
+
+proc ::tk::dialog::error::Return {which code} {
+ variable button
+
+ .bgerrorDialog.$which state {active selected focus}
+ update idletasks
+ after 100
+ set button $code
+}
+
+proc ::tk::dialog::error::Details {} {
+ set w .bgerrorDialog
+ set caption [option get $w.function text {}]
+ set command [option get $w.function command {}]
+ if { ($caption eq "") || ($command eq "") } {
+ grid forget $w.function
+ }
+ lappend command [$w.top.info.text get 1.0 end-1c]
+ $w.function configure -text $caption -command $command
+ grid $w.top.info - -sticky nsew -padx 3m -pady 3m
+}
+
+proc ::tk::dialog::error::SaveToLog {text} {
+ if { $::tcl_platform(platform) eq "windows" } {
+ set allFiles *.*
+ } else {
+ set allFiles *
+ }
+ set types [list \
+ [list [mc "Log Files"] .log] \
+ [list [mc "Text Files"] .txt] \
+ [list [mc "All Files"] $allFiles] \
+ ]
+ set filename [tk_getSaveFile -title [mc "Select Log File"] \
+ -filetypes $types -defaultextension .log -parent .bgerrorDialog]
+ if {$filename ne {}} {
+ set f [open $filename w]
+ puts -nonewline $f $text
+ close $f
+ }
+ return
+}
+
+proc ::tk::dialog::error::Destroy {w} {
+ if {$w eq ".bgerrorDialog"} {
+ variable button
+ set button -1
+ }
+}
+
+proc ::tk::dialog::error::DeleteByProtocol {} {
+ variable button
+ set button 1
+}
+
+proc ::tk::dialog::error::ReturnInDetails w {
+ bind $w <Return> {}; # Remove this binding
+ $w invoke
+ return -code break
+}
+
+# ::tk::dialog::error::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 ::tk::dialog::error::bgerror err {
+ global errorInfo
+ variable button
+
+ set info $errorInfo
+
+ 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 :
+ set windowingsystem [tk windowingsystem]
+ if {$windowingsystem eq "aqua"} {
+ set ok [mc Ok]
+ } else {
+ set ok [mc OK]
+ }
+
+ # Truncate the message if it is too wide (>maxLine characters) or
+ # too tall (>4 lines). Truncation occurs at the first point at
+ # which one of those conditions is met.
+ set displayedErr ""
+ set lines 0
+ set maxLine 45
+ foreach line [split $err \n] {
+ if { [string length $line] > $maxLine } {
+ append displayedErr "[string range $line 0 [expr {$maxLine-3}]]..."
+ break
+ }
+ if { $lines > 4 } {
+ append displayedErr "..."
+ break
+ } else {
+ append displayedErr "${line}\n"
+ }
+ incr lines
+ }
+
+ set title [mc "Application Error"]
+ set text [mc "Error: %1\$s" $displayedErr]
+ set buttons [list ok $ok dismiss [mc "Skip Messages"] \
+ function [mc "Details >>"]]
+
+ # 1. Create the top-level window and divide it into top
+ # and bottom parts.
+
+ set dlg .bgerrorDialog
+ set bg [ttk::style lookup . -background]
+ destroy $dlg
+ toplevel $dlg -class ErrorDialog -background $bg
+ wm withdraw $dlg
+ wm title $dlg $title
+ wm iconname $dlg ErrorDialog
+ wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol]
+
+ if {$windowingsystem eq "aqua"} {
+ ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {}
+ } elseif {$windowingsystem eq "x11"} {
+ wm attributes $dlg -type dialog
+ }
+
+ ttk::frame $dlg.bot
+ ttk::frame $dlg.top
+ pack $dlg.bot -side bottom -fill both
+ pack $dlg.top -side top -fill both -expand 1
+
+ set W [ttk::frame $dlg.top.info]
+ text $W.text -setgrid true -height 10 -wrap char \
+ -yscrollcommand [list $W.scroll set]
+ if {$windowingsystem ne "aqua"} {
+ $W.text configure -width 40
+ }
+
+ ttk::scrollbar $W.scroll -command [list $W.text yview]
+ pack $W.scroll -side right -fill y
+ pack $W.text -side left -expand yes -fill both
+ $W.text insert 0.0 "$err\n$info"
+ $W.text mark set insert 0.0
+ bind $W.text <ButtonPress-1> { focus %W }
+ $W.text configure -state disabled
+
+ # 2. Fill the top part with bitmap and message
+
+ # Max-width of message is the width of the screen...
+ set wrapwidth [winfo screenwidth $dlg]
+ # ...minus the width of the icon, padding and a fudge factor for
+ # the window manager decorations and aesthetics.
+ set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}]
+ ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth
+ ttk::label $dlg.bitmap -image ::tk::icons::error
+
+ grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m
+ grid configure $dlg.bitmap -sticky ne
+ grid configure $dlg.msg -sticky nsw -padx {0 3m}
+ grid rowconfigure $dlg.top 1 -weight 1
+ grid columnconfigure $dlg.top 1 -weight 1
+
+ # 3. Create a row of buttons at the bottom of the dialog.
+
+ set i 0
+ foreach {name caption} $buttons {
+ ttk::button $dlg.$name -text $caption -default normal \
+ -command [namespace code [list set button $i]]
+ grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 10
+ grid columnconfigure $dlg.bot $i -weight 1
+ # We boost the size of some Mac buttons for l&f
+ if {$windowingsystem eq "aqua"} {
+ if {($name eq "ok") || ($name eq "dismiss")} {
+ grid columnconfigure $dlg.bot $i -minsize 90
+ }
+ grid configure $dlg.$name -pady 7
+ }
+ incr i
+ }
+ # The "OK" button is the default for this dialog.
+ $dlg.ok configure -default active
+
+ bind $dlg <Return> [namespace code {Return ok 0}]
+ bind $dlg <Escape> [namespace code {Return dismiss 1}]
+ bind $dlg <Destroy> [namespace code {Destroy %W}]
+ bind $dlg.function <Return> [namespace code {ReturnInDetails %W}]
+ $dlg.function configure -command [namespace code 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 (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $dlg
+
+ # 7. Set a grab and claim the focus too.
+
+ ::tk::SetFocusGrab $dlg $dlg.ok
+
+ # 8. Ensure that we are topmost.
+
+ raise $dlg
+ if {[tk windowingsystem] eq "win32"} {
+ # Place it topmost if we aren't at the top of the stacking
+ # order to ensure that it's seen
+ if {[lindex [wm stackorder .] end] ne "$dlg"} {
+ wm attributes $dlg -topmost 1
+ }
+ }
+
+ # 9. 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.
+
+ vwait [namespace which -variable button]
+ set copy $button; # Save a copy...
+
+ ::tk::RestoreFocusGrab $dlg $dlg.ok destroy
+
+ if {$copy == 1} {
+ return -code break
+ }
+}
+
+namespace eval :: {
+ # Fool the indexer
+ proc bgerror err {}
+ rename bgerror {}
+ namespace import ::tk::dialog::error::bgerror
+}