You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
293 lines
8.8 KiB
Tcl
293 lines
8.8 KiB
Tcl
# 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.
|
|
# All rights reserved.
|
|
#
|
|
# RCS: @(#) $Id: bgerror.tcl,v 1.23 2002/08/31 06:12:28 das Exp $
|
|
# $Id: bgerror.tcl,v 1.23 2002/08/31 06:12:28 das Exp $
|
|
|
|
namespace eval ::tk {
|
|
namespace eval dialog {
|
|
namespace eval error {
|
|
namespace import ::tk::msgcat::*
|
|
namespace export bgerror
|
|
option add *ErrorDialog.function.text [mc "Save To Log"] \
|
|
widgetDefault
|
|
option add *ErrorDialog.function.command [namespace code SaveToLog]
|
|
}
|
|
}
|
|
}
|
|
|
|
proc ::tk::dialog::error::Return {} {
|
|
variable button
|
|
|
|
.bgerrorDialog.ok configure -state active -relief sunken
|
|
update idletasks
|
|
after 100
|
|
set button 0
|
|
}
|
|
|
|
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
|
|
}
|
|
$w.function configure -text $caption -command \
|
|
"$command [list [.bgerrorDialog.top.info.text get 1.0 end]]"
|
|
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 {![string length $filename]} {
|
|
return
|
|
}
|
|
set f [open $filename w]
|
|
puts -nonewline $f $text
|
|
close $f
|
|
}
|
|
|
|
proc ::tk::dialog::error::Destroy {w} {
|
|
if {$w eq ".bgerrorDialog"} {
|
|
variable button
|
|
set button -1
|
|
}
|
|
}
|
|
|
|
# ::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 tcl_platform
|
|
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 :
|
|
if {($tcl_platform(platform) eq "macintosh")
|
|
|| ([tk windowingsystem] eq "aqua")} {
|
|
set ok [mc Ok]
|
|
set messageFont system
|
|
set textRelief flat
|
|
set textHilight 0
|
|
} else {
|
|
set ok [mc OK]
|
|
set messageFont {Times -18}
|
|
set textRelief sunken
|
|
set textHilight 1
|
|
}
|
|
|
|
|
|
# Truncate the message if it is too wide (longer than 30 characacters) or
|
|
# too tall (more than 4 newlines). Truncation occurs at the first point at
|
|
# which one of those conditions is met.
|
|
set displayedErr ""
|
|
set lines 0
|
|
foreach line [split $err \n] {
|
|
if { [string length $line] > 30 } {
|
|
append displayedErr "[string range $line 0 29]..."
|
|
break
|
|
}
|
|
if { $lines > 4 } {
|
|
append displayedErr "..."
|
|
break
|
|
} else {
|
|
append displayedErr "${line}\n"
|
|
}
|
|
incr lines
|
|
}
|
|
|
|
set w .bgerrorDialog
|
|
set title [mc "Application Error"]
|
|
set text [mc {Error: %1$s} $err]
|
|
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.
|
|
|
|
catch {destroy .bgerrorDialog}
|
|
toplevel .bgerrorDialog -class ErrorDialog
|
|
wm title .bgerrorDialog $title
|
|
wm iconname .bgerrorDialog ErrorDialog
|
|
wm protocol .bgerrorDialog WM_DELETE_WINDOW { }
|
|
|
|
if {($tcl_platform(platform) eq "macintosh")
|
|
|| ([tk windowingsystem] eq "aqua")} {
|
|
::tk::unsupported::MacWindowStyle style .bgerrorDialog dBoxProc
|
|
}
|
|
|
|
frame .bgerrorDialog.bot
|
|
frame .bgerrorDialog.top
|
|
if {[tk windowingsystem] eq "x11"} {
|
|
.bgerrorDialog.bot configure -relief raised -bd 1
|
|
.bgerrorDialog.top configure -relief raised -bd 1
|
|
}
|
|
pack .bgerrorDialog.bot -side bottom -fill both
|
|
pack .bgerrorDialog.top -side top -fill both -expand 1
|
|
|
|
set W [frame $w.top.info]
|
|
text $W.text \
|
|
-bd 2 \
|
|
-yscrollcommand [list $W.scroll set]\
|
|
-setgrid true \
|
|
-width 40 \
|
|
-height 10 \
|
|
-state normal \
|
|
-relief $textRelief \
|
|
-highlightthickness $textHilight \
|
|
-wrap char
|
|
|
|
scrollbar $W.scroll -relief sunken -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 .bgerrorDialog]
|
|
# ...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 .bgerrorDialog 9m]}]
|
|
label .bgerrorDialog.msg -justify left -text $text -font $messageFont \
|
|
-wraplength $wrapwidth
|
|
if {($tcl_platform(platform) eq "macintosh")
|
|
|| ([tk windowingsystem] eq "aqua")} {
|
|
# On the Macintosh, use the stop bitmap
|
|
label .bgerrorDialog.bitmap -bitmap stop
|
|
} else {
|
|
# On other platforms, make the error icon
|
|
canvas .bgerrorDialog.bitmap -width 32 -height 32 -highlightthickness 0
|
|
.bgerrorDialog.bitmap create oval 0 0 31 31 -fill red -outline black
|
|
.bgerrorDialog.bitmap create line 9 9 23 23 -fill white -width 4
|
|
.bgerrorDialog.bitmap create line 9 23 23 9 -fill white -width 4
|
|
}
|
|
grid .bgerrorDialog.bitmap .bgerrorDialog.msg \
|
|
-in .bgerrorDialog.top \
|
|
-row 0 \
|
|
-padx 3m \
|
|
-pady 3m
|
|
grid configure .bgerrorDialog.msg -sticky nsw -padx {0 3m}
|
|
grid rowconfigure .bgerrorDialog.top 1 -weight 1
|
|
grid columnconfigure .bgerrorDialog.top 1 -weight 1
|
|
|
|
# 3. Create a row of buttons at the bottom of the dialog.
|
|
|
|
set i 0
|
|
foreach {name caption} $buttons {
|
|
button .bgerrorDialog.$name \
|
|
-text $caption \
|
|
-default normal \
|
|
-command [namespace code "set button $i"]
|
|
grid .bgerrorDialog.$name \
|
|
-in .bgerrorDialog.bot \
|
|
-column $i \
|
|
-row 0 \
|
|
-sticky ew \
|
|
-padx 10
|
|
grid columnconfigure .bgerrorDialog.bot $i -weight 1
|
|
# We boost the size of some Mac buttons for l&f
|
|
if {($tcl_platform(platform) eq "macintosh")
|
|
|| ([tk windowingsystem] eq "aqua")} {
|
|
if {($name eq "ok") || ($name eq "dismiss")} {
|
|
grid columnconfigure .bgerrorDialog.bot $i -minsize 79
|
|
}
|
|
}
|
|
incr i
|
|
}
|
|
# The "OK" button is the default for this dialog.
|
|
.bgerrorDialog.ok configure -default active
|
|
|
|
bind .bgerrorDialog <Return> [namespace code Return]
|
|
bind .bgerrorDialog <Destroy> [namespace code [list Destroy %W]]
|
|
.bgerrorDialog.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 and de-iconify it.
|
|
|
|
wm withdraw .bgerrorDialog
|
|
update idletasks
|
|
set parent [winfo parent .bgerrorDialog]
|
|
set width [winfo reqwidth .bgerrorDialog]
|
|
set height [winfo reqheight .bgerrorDialog]
|
|
set x [expr {([winfo screenwidth .bgerrorDialog] - $width )/2 - \
|
|
[winfo vrootx $parent]}]
|
|
set y [expr {([winfo screenheight .bgerrorDialog] - $height)/2 - \
|
|
[winfo vrooty $parent]}]
|
|
.bgerrorDialog configure -width $width
|
|
wm geometry .bgerrorDialog +$x+$y
|
|
wm deiconify .bgerrorDialog
|
|
|
|
# 7. Set a grab and claim the focus too.
|
|
|
|
set oldFocus [focus]
|
|
set oldGrab [grab current .bgerrorDialog]
|
|
if {$oldGrab != ""} {
|
|
set grabStatus [grab status $oldGrab]
|
|
}
|
|
grab .bgerrorDialog
|
|
focus .bgerrorDialog.ok
|
|
|
|
# 8. 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...
|
|
catch {focus $oldFocus}
|
|
catch {destroy .bgerrorDialog}
|
|
if {$oldGrab ne ""} {
|
|
if {$grabStatus eq "global"} {
|
|
grab -global $oldGrab
|
|
} else {
|
|
grab $oldGrab
|
|
}
|
|
}
|
|
|
|
if {$copy == 1} {
|
|
return -code break
|
|
}
|
|
}
|
|
|
|
namespace eval :: {
|
|
# Fool the indexer
|
|
proc bgerror err {}
|
|
rename bgerror {}
|
|
namespace import ::tk::dialog::error::bgerror
|
|
}
|