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