bgerror.tcl (8246B)
1 # bgerror.tcl -- 2 # 3 # Implementation of the bgerror procedure. It posts a dialog box with 4 # the error message and gives the user a chance to see a more detailed 5 # stack trace, and possible do something more interesting with that 6 # trace (like save it to a log). This is adapted from work done by 7 # Donal K. Fellows. 8 # 9 # Copyright (c) 1998-2000 by Ajuba Solutions. 10 # Copyright (c) 2007 by ActiveState Software Inc. 11 # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> 12 # Copyright (c) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> 13 14 namespace eval ::tk::dialog::error { 15 namespace import -force ::tk::msgcat::* 16 namespace export bgerror 17 option add *ErrorDialog.function.text [mc "Save To Log"] \ 18 widgetDefault 19 option add *ErrorDialog.function.command [namespace code SaveToLog] 20 option add *ErrorDialog*Label.font TkCaptionFont widgetDefault 21 if {[tk windowingsystem] eq "aqua"} { 22 option add *ErrorDialog*background systemAlertBackgroundActive \ 23 widgetDefault 24 option add *ErrorDialog*info.text.background white widgetDefault 25 option add *ErrorDialog*Button.highlightBackground \ 26 systemAlertBackgroundActive widgetDefault 27 } 28 } 29 30 proc ::tk::dialog::error::Return {which code} { 31 variable button 32 33 .bgerrorDialog.$which state {active selected focus} 34 update idletasks 35 after 100 36 set button $code 37 } 38 39 proc ::tk::dialog::error::Details {} { 40 set w .bgerrorDialog 41 set caption [option get $w.function text {}] 42 set command [option get $w.function command {}] 43 if { ($caption eq "") || ($command eq "") } { 44 grid forget $w.function 45 } 46 lappend command [$w.top.info.text get 1.0 end-1c] 47 $w.function configure -text $caption -command $command 48 grid $w.top.info - -sticky nsew -padx 3m -pady 3m 49 } 50 51 proc ::tk::dialog::error::SaveToLog {text} { 52 if { $::tcl_platform(platform) eq "windows" } { 53 set allFiles *.* 54 } else { 55 set allFiles * 56 } 57 set types [list \ 58 [list [mc "Log Files"] .log] \ 59 [list [mc "Text Files"] .txt] \ 60 [list [mc "All Files"] $allFiles] \ 61 ] 62 set filename [tk_getSaveFile -title [mc "Select Log File"] \ 63 -filetypes $types -defaultextension .log -parent .bgerrorDialog] 64 if {$filename ne {}} { 65 set f [open $filename w] 66 puts -nonewline $f $text 67 close $f 68 } 69 return 70 } 71 72 proc ::tk::dialog::error::Destroy {w} { 73 if {$w eq ".bgerrorDialog"} { 74 variable button 75 set button -1 76 } 77 } 78 79 proc ::tk::dialog::error::DeleteByProtocol {} { 80 variable button 81 set button 1 82 } 83 84 proc ::tk::dialog::error::ReturnInDetails w { 85 bind $w <Return> {}; # Remove this binding 86 $w invoke 87 return -code break 88 } 89 90 # ::tk::dialog::error::bgerror -- 91 # 92 # This is the default version of bgerror. 93 # It tries to execute tkerror, if that fails it posts a dialog box 94 # containing the error message and gives the user a chance to ask 95 # to see a stack trace. 96 # 97 # Arguments: 98 # err - The error message. 99 # 100 proc ::tk::dialog::error::bgerror err { 101 global errorInfo 102 variable button 103 104 set info $errorInfo 105 106 set ret [catch {::tkerror $err} msg]; 107 if {$ret != 1} {return -code $ret $msg} 108 109 # Ok the application's tkerror either failed or was not found 110 # we use the default dialog then : 111 set windowingsystem [tk windowingsystem] 112 if {$windowingsystem eq "aqua"} { 113 set ok [mc Ok] 114 } else { 115 set ok [mc OK] 116 } 117 118 # Truncate the message if it is too wide (>maxLine characters) or 119 # too tall (>4 lines). Truncation occurs at the first point at 120 # which one of those conditions is met. 121 set displayedErr "" 122 set lines 0 123 set maxLine 45 124 foreach line [split $err \n] { 125 if { [string length $line] > $maxLine } { 126 append displayedErr "[string range $line 0 [expr {$maxLine-3}]]..." 127 break 128 } 129 if { $lines > 4 } { 130 append displayedErr "..." 131 break 132 } else { 133 append displayedErr "${line}\n" 134 } 135 incr lines 136 } 137 138 set title [mc "Application Error"] 139 set text [mc "Error: %1\$s" $displayedErr] 140 set buttons [list ok $ok dismiss [mc "Skip Messages"] \ 141 function [mc "Details >>"]] 142 143 # 1. Create the top-level window and divide it into top 144 # and bottom parts. 145 146 set dlg .bgerrorDialog 147 set bg [ttk::style lookup . -background] 148 destroy $dlg 149 toplevel $dlg -class ErrorDialog -background $bg 150 wm withdraw $dlg 151 wm title $dlg $title 152 wm iconname $dlg ErrorDialog 153 wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol] 154 155 if {$windowingsystem eq "aqua"} { 156 ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {} 157 } elseif {$windowingsystem eq "x11"} { 158 wm attributes $dlg -type dialog 159 } 160 161 ttk::frame $dlg.bot 162 ttk::frame $dlg.top 163 pack $dlg.bot -side bottom -fill both 164 pack $dlg.top -side top -fill both -expand 1 165 166 set W [ttk::frame $dlg.top.info] 167 text $W.text -setgrid true -height 10 -wrap char \ 168 -yscrollcommand [list $W.scroll set] 169 if {$windowingsystem ne "aqua"} { 170 $W.text configure -width 40 171 } 172 173 ttk::scrollbar $W.scroll -command [list $W.text yview] 174 pack $W.scroll -side right -fill y 175 pack $W.text -side left -expand yes -fill both 176 $W.text insert 0.0 "$err\n$info" 177 $W.text mark set insert 0.0 178 bind $W.text <ButtonPress-1> { focus %W } 179 $W.text configure -state disabled 180 181 # 2. Fill the top part with bitmap and message 182 183 # Max-width of message is the width of the screen... 184 set wrapwidth [winfo screenwidth $dlg] 185 # ...minus the width of the icon, padding and a fudge factor for 186 # the window manager decorations and aesthetics. 187 set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}] 188 ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth 189 ttk::label $dlg.bitmap -image ::tk::icons::error 190 191 grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m 192 grid configure $dlg.bitmap -sticky ne 193 grid configure $dlg.msg -sticky nsw -padx {0 3m} 194 grid rowconfigure $dlg.top 1 -weight 1 195 grid columnconfigure $dlg.top 1 -weight 1 196 197 # 3. Create a row of buttons at the bottom of the dialog. 198 199 set i 0 200 foreach {name caption} $buttons { 201 ttk::button $dlg.$name -text $caption -default normal \ 202 -command [namespace code [list set button $i]] 203 grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 10 204 grid columnconfigure $dlg.bot $i -weight 1 205 # We boost the size of some Mac buttons for l&f 206 if {$windowingsystem eq "aqua"} { 207 if {($name eq "ok") || ($name eq "dismiss")} { 208 grid columnconfigure $dlg.bot $i -minsize 90 209 } 210 grid configure $dlg.$name -pady 7 211 } 212 incr i 213 } 214 # The "OK" button is the default for this dialog. 215 $dlg.ok configure -default active 216 217 bind $dlg <Return> [namespace code {Return ok 0}] 218 bind $dlg <Escape> [namespace code {Return dismiss 1}] 219 bind $dlg <Destroy> [namespace code {Destroy %W}] 220 bind $dlg.function <Return> [namespace code {ReturnInDetails %W}] 221 $dlg.function configure -command [namespace code Details] 222 223 # 6. Withdraw the window, then update all the geometry information 224 # so we know how big it wants to be, then center the window in the 225 # display (Motif style) and de-iconify it. 226 227 ::tk::PlaceWindow $dlg 228 229 # 7. Set a grab and claim the focus too. 230 231 ::tk::SetFocusGrab $dlg $dlg.ok 232 233 # 8. Ensure that we are topmost. 234 235 raise $dlg 236 if {[tk windowingsystem] eq "win32"} { 237 # Place it topmost if we aren't at the top of the stacking 238 # order to ensure that it's seen 239 if {[lindex [wm stackorder .] end] ne "$dlg"} { 240 wm attributes $dlg -topmost 1 241 } 242 } 243 244 # 9. Wait for the user to respond, then restore the focus and 245 # return the index of the selected button. Restore the focus 246 # before deleting the window, since otherwise the window manager 247 # may take the focus away so we can't redirect it. Finally, 248 # restore any grab that was in effect. 249 250 vwait [namespace which -variable button] 251 set copy $button; # Save a copy... 252 253 ::tk::RestoreFocusGrab $dlg $dlg.ok destroy 254 255 if {$copy == 1} { 256 return -code break 257 } 258 } 259 260 namespace eval :: { 261 # Fool the indexer 262 proc bgerror err {} 263 rename bgerror {} 264 namespace import ::tk::dialog::error::bgerror 265 }