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