diff options
Diffstat (limited to 'tk8.6/library/bgerror.tcl')
| -rw-r--r-- | tk8.6/library/bgerror.tcl | 270 |
1 files changed, 270 insertions, 0 deletions
diff --git a/tk8.6/library/bgerror.tcl b/tk8.6/library/bgerror.tcl new file mode 100644 index 0000000..574ad8b --- /dev/null +++ b/tk8.6/library/bgerror.tcl @@ -0,0 +1,270 @@ +# 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 {flag 1}} { + global errorInfo + variable button + + set info $errorInfo + + set ret [catch {::tkerror $err} msg]; + if {$ret != 1} {return -code $ret $msg} + + # The application's tkerror either failed or was not found + # so we use the default dialog. But on Aqua we cannot display + # the dialog if the background error occurs in an idle task + # being processed inside of [NSView drawRect]. In that case + # we post the dialog as an after task instead. + set windowingsystem [tk windowingsystem] + if {$windowingsystem eq "aqua"} { + if $flag { + after 500 [list bgerror "$err" 0] + return + } + } + + 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 +} |