summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog10
-rw-r--r--generic/tkPack.c4
-rw-r--r--generic/tkUtil.c2
-rw-r--r--library/choosedir.tcl3
-rw-r--r--library/clrpick.tcl6
-rw-r--r--library/comdlg.tcl27
-rw-r--r--library/console.tcl4
-rw-r--r--library/dialog.tcl5
-rw-r--r--library/fontchooser.tcl10
-rw-r--r--library/iconlist.tcl10
-rw-r--r--library/megawidget.tcl10
-rw-r--r--library/menu.tcl11
-rw-r--r--library/msgbox.tcl20
-rw-r--r--library/palette.tcl3
-rw-r--r--library/safetk.tcl10
-rw-r--r--library/spinbox.tcl3
-rw-r--r--library/tk.tcl6
-rw-r--r--library/tkfbox.tcl3
-rw-r--r--library/unsupported.tcl6
-rw-r--r--library/xmfbox.tcl3
20 files changed, 100 insertions, 56 deletions
diff --git a/ChangeLog b/ChangeLog
index f9a8229..e24796b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2012-08-27 Donal K. Fellows <dkf@users.sf.net>
+
+ * (very many files): Reworked the generation of error messages and
+ postscript so that they no longer made nearly as much use of the Tcl
+ interpreter's string result code, in the process substantially
+ reducing the amount of ad-hoc stack buffers used for message
+ generation. There should be no observable changes from this except
+ that Tk now causes the ::errorCode variable to be set meaningfully in
+ virtually all places where errors are generated.
+
2012-08-24 Donal K. Fellows <dkf@users.sf.net>
* library/tkfbox.tcl (GlobFiltered): [Bug 3558535]: Factor out the
diff --git a/generic/tkPack.c b/generic/tkPack.c
index d91fda7..134b61f 100644
--- a/generic/tkPack.c
+++ b/generic/tkPack.c
@@ -1114,7 +1114,7 @@ PackAfter(
for ( ; objc > 0; objc -= 2, objv += 2, prevPtr = packPtr) {
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: \"%s\" should be followed by options",
+ "wrong # args: window \"%s\" should be followed by options",
Tcl_GetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
@@ -1200,7 +1200,7 @@ PackAfter(
if (optionCount < (index+2)) {
missingPad:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: window \"%s\" option must be"
+ "wrong # args: \"%s\" option must be"
" followed by screen distance", curOpt));
Tcl_SetErrorCode(interp, "TK", "OLDPACK", "BAD_PARAMETER",
NULL);
diff --git a/generic/tkUtil.c b/generic/tkUtil.c
index a8d2884..385d1cb 100644
--- a/generic/tkUtil.c
+++ b/generic/tkUtil.c
@@ -998,7 +998,7 @@ TkFindStateNumObj(
Tcl_GetString(optionPtr), key, mPtr->strKey);
for (mPtr++; mPtr->strKey != NULL; mPtr++) {
Tcl_AppendPrintfToObj(msgObj, ",%s %s",
- ((mPtr[1].strKey != NULL) ? "" : "or "), mPtr->strKey);
+ ((mPtr[1].strKey != NULL) ? "" : " or"), mPtr->strKey);
}
Tcl_SetObjResult(interp, msgObj);
Tcl_SetErrorCode(interp, "TK", "LOOKUP", Tcl_GetString(optionPtr),
diff --git a/library/choosedir.tcl b/library/choosedir.tcl
index 62e3165..c0ab326 100644
--- a/library/choosedir.tcl
+++ b/library/choosedir.tcl
@@ -186,7 +186,8 @@ proc ::tk::dialog::file::chooseDir::Config {dataName argList} {
}
if {![winfo exists $data(-parent)]} {
- error "bad window path name \"$data(-parent)\""
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
}
}
diff --git a/library/clrpick.tcl b/library/clrpick.tcl
index 092915c..3772a30 100644
--- a/library/clrpick.tcl
+++ b/library/clrpick.tcl
@@ -190,11 +190,13 @@ proc ::tk::dialog::color::Config {dataName argList} {
set data(-title) " "
}
if {[catch {winfo rgb . $data(-initialcolor)} err]} {
- error $err
+ return -code error -errorcode [list TK LOOKUP COLOR $data(-initialcolor)] \
+ $err
}
if {![winfo exists $data(-parent)]} {
- error "bad window path name \"$data(-parent)\""
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
}
}
diff --git a/library/comdlg.tcl b/library/comdlg.tcl
index 39d27d3..f89754c 100644
--- a/library/comdlg.tcl
+++ b/library/comdlg.tcl
@@ -40,7 +40,8 @@ proc tclParseConfigSpec {w specs flags argList} {
#
foreach spec $specs {
if {[llength $spec] < 4} {
- error "\"spec\" should contain 5 or 4 elements"
+ return -code error -errorcode {TK VALUE CONFIG_SPEC} \
+ "\"spec\" should contain 5 or 4 elements"
}
set cmdsw [lindex $spec 0]
set cmd($cmdsw) ""
@@ -53,9 +54,11 @@ proc tclParseConfigSpec {w specs flags argList} {
if {[llength $argList] & 1} {
set cmdsw [lindex $argList end]
if {![info exists cmd($cmdsw)]} {
- error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
+ return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
+ "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
}
- error "value for \"$cmdsw\" missing"
+ return -code error -errorcode {TK VALUE_MISSING} \
+ "value for \"$cmdsw\" missing"
}
# 2: set the default values
@@ -68,7 +71,8 @@ proc tclParseConfigSpec {w specs flags argList} {
#
foreach {cmdsw value} $argList {
if {![info exists cmd($cmdsw)]} {
- error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
+ return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
+ "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
}
set data($cmdsw) $value
}
@@ -120,7 +124,8 @@ proc tclListValidFlags {v} {
proc ::tk::FocusGroup_Create {t} {
variable ::tk::Priv
if {[winfo toplevel $t] ne $t} {
- error "$t is not a toplevel window"
+ return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \
+ "$t is not a toplevel window"
}
if {![info exists Priv(fg,$t)]} {
set Priv(fg,$t) 1
@@ -140,7 +145,8 @@ proc ::tk::FocusGroup_BindIn {t w cmd} {
variable FocusIn
variable ::tk::Priv
if {![info exists Priv(fg,$t)]} {
- error "focus group \"$t\" doesn't exist"
+ return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
+ "focus group \"$t\" doesn't exist"
}
set FocusIn($t,$w) $cmd
}
@@ -156,7 +162,8 @@ proc ::tk::FocusGroup_BindOut {t w cmd} {
variable FocusOut
variable ::tk::Priv
if {![info exists Priv(fg,$t)]} {
- error "focus group \"$t\" doesn't exist"
+ return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
+ "focus group \"$t\" doesn't exist"
}
set FocusOut($t,$w) $cmd
}
@@ -255,7 +262,8 @@ proc ::tk::FocusGroup_Out {t w detail} {
proc ::tk::FDGetFileTypes {string} {
foreach t $string {
if {[llength $t] < 2 || [llength $t] > 3} {
- error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
+ return -code error -errorcode {TK VALUE FILE_TYPE} \
+ "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
}
lappend fileTypes([lindex $t 0]) {*}[lindex $t 1]
}
@@ -274,7 +282,8 @@ proc ::tk::FDGetFileTypes {string} {
# empty.
foreach macType [lindex $t 2] {
if {[string length $macType] != 4} {
- error "bad Macintosh file type \"$macType\""
+ return -code error -errorcode {TK VALUE MAC_TYPE} \
+ "bad Macintosh file type \"$macType\""
}
}
diff --git a/library/console.tcl b/library/console.tcl
index 37832f2..ab074f5 100644
--- a/library/console.tcl
+++ b/library/console.tcl
@@ -976,8 +976,8 @@ proc ::tk::console::Expand {w {type ""}} {
proc ::tk::console::ExpandPathname str {
set pwd [EvalAttached pwd]
- if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
- return -code error $err
+ if {[catch {EvalAttached [list cd [file dirname $str]]} err opt]} {
+ return -options $opt $err
}
set dir [file tail $str]
## Check to see if it was known to be a directory and keep the trailing
diff --git a/library/dialog.tcl b/library/dialog.tcl
index adea259..6a9babb 100644
--- a/library/dialog.tcl
+++ b/library/dialog.tcl
@@ -34,8 +34,9 @@ proc ::tk_dialog {w title text bitmap default args} {
# Check that $default was properly given
if {[string is integer -strict $default]} {
if {$default >= [llength $args]} {
- return -code error "default button index greater than number of\
- buttons specified for tk_dialog"
+ return -code error -errorcode {TK DIALOG BAD_DEFAULT} \
+ "default button index greater than number of buttons\
+ specified for tk_dialog"
}
} elseif {"" eq $default} {
set default -1
diff --git a/library/fontchooser.tcl b/library/fontchooser.tcl
index 13b5895..179476c 100644
--- a/library/fontchooser.tcl
+++ b/library/fontchooser.tcl
@@ -96,7 +96,8 @@ proc ::tk::fontchooser::Configure {args} {
} elseif {[info exists S($option)]} {
return $S($option)
}
- return -code error "bad option \"$option\": must be\
+ return -code error -errorcode [list TK LOOKUP OPTION $option] \
+ "bad option \"$option\": must be\
-command, -font, -parent, -title or -visible"
}
@@ -104,9 +105,10 @@ proc ::tk::fontchooser::Configure {args} {
-font $S(-font) -command $S(-command)]
set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args]
if {![winfo exists $S(-parent)]} {
+ set code [list TK LOOKUP WINDOW $S(-parent)]
set err "bad window path name \"$S(-parent)\""
array set S $cache
- return -code error $err
+ return -code error -errorcode $code $err
}
if {[string trim $S(-title)] eq ""} {
set S(-title) [::msgcat::mc "Font"]
@@ -434,9 +436,9 @@ proc ::tk::fontchooser::ttk_slistbox {w args} {
grid columnconfigure $f 0 -weight 1
interp hide {} $w
interp alias {} $w {} $f.list
- } err]} {
+ } err opt]} {
destroy $f
- return -code error $err
+ return -options $opt $err
}
return $w
}
diff --git a/library/iconlist.tcl b/library/iconlist.tcl
index ce1aae2..62b0b2d 100644
--- a/library/iconlist.tcl
+++ b/library/iconlist.tcl
@@ -98,8 +98,9 @@ package require Tk 8.6
set first [set last [lindex $args 0]]
}
default {
- return -code error "wrong # args: should be\
- \"[lrange [info level 0] 0 1] first ?last?\""
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] first ?last?\""
}
}
@@ -149,8 +150,9 @@ package require Tk 8.6
set first [set last [lindex $args 0]]
}
default {
- return -code error "wrong # args: should be\
- \"[lrange [info level 0] 0 1] first ?last?\""
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] first ?last?\""
}
}
diff --git a/library/megawidget.tcl b/library/megawidget.tcl
index 1cd2900..9b9be92 100644
--- a/library/megawidget.tcl
+++ b/library/megawidget.tcl
@@ -76,8 +76,14 @@ package require Tk 8.6
}
}
- method CreateHull {} {error "method must be overridden"}
- method Create {} {error "method must be overridden"}
+ method CreateHull {} {
+ return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
+ "method must be overridden"
+ }
+ method Create {} {
+ return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
+ "method must be overridden"
+ }
method WhenIdle {method args} {
if {![info exists IdleCallbacks($method)]} {
diff --git a/library/menu.tcl b/library/menu.tcl
index a51c96f..cfe7536 100644
--- a/library/menu.tcl
+++ b/library/menu.tcl
@@ -253,7 +253,8 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
set tearoff [expr {[tk windowingsystem] eq "x11" \
|| [$menu cget -type] eq "tearoff"}]
if {[string first $w $menu] != 0} {
- error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
+ return -code error -errorcode {TK MENUBUTTON POST_NONCHILD} \
+ "can't post $menu: it isn't a descendant of $w"
}
set cur $Priv(postedMb)
if {$cur ne ""} {
@@ -320,7 +321,7 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
$menu activate $entry
GenerateMenuSelect $menu
}
- }
+ }
right {
set x [expr {[winfo rootx $w] + [winfo width $w]}]
set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
@@ -353,14 +354,12 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
}
}
}
- } msg]} {
+ } msg opt]} {
# Error posting menu (e.g. bogus -postcommand). Unpost it and
# reflect the error.
- set savedInfo $errorInfo
MenuUnpost {}
- error $msg $savedInfo
-
+ return -options $opt $msg
}
set Priv(tearoff) $tearoff
diff --git a/library/msgbox.tcl b/library/msgbox.tcl
index 60a2a19..10e91f1 100644
--- a/library/msgbox.tcl
+++ b/library/msgbox.tcl
@@ -111,7 +111,7 @@ static unsigned char w3_bits[] = {
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
-
+
# ::tk::MessageBox --
#
# Pops up a messagebox with an application-supplied message with
@@ -153,8 +153,9 @@ proc ::tk::MessageBox {args} {
tclParseConfigSpec $w $specs "" $args
- if {[lsearch -exact {info warning error question} $data(-icon)] == -1} {
- error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
+ if {$data(-icon) ni {info warning error question}} {
+ return -code error -errorcode [list TK LOOKUP ICON $data(-icon)] \
+ "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
}
set windowingsystem [tk windowingsystem]
if {$windowingsystem eq "aqua"} {
@@ -169,7 +170,8 @@ proc ::tk::MessageBox {args} {
}
if {![winfo exists $data(-parent)]} {
- error "bad window path name \"$data(-parent)\""
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
}
switch -- $data(-type) {
@@ -204,9 +206,10 @@ proc ::tk::MessageBox {args} {
set cancel cancel
}
default {
- error "bad -type value \"$data(-type)\": must be\
- abortretryignore, ok, okcancel, retrycancel,\
- yesno, or yesnocancel"
+ return -code error -errorcode [list TK LOOKUP DLG_TYPE $data(-type)] \
+ "bad -type value \"$data(-type)\": must be\
+ abortretryignore, ok, okcancel, retrycancel,\
+ yesno, or yesnocancel"
}
}
@@ -230,7 +233,8 @@ proc ::tk::MessageBox {args} {
}
}
if {!$valid} {
- error "invalid default button \"$data(-default)\""
+ return -code error -errorcode {TK MSGBOX DEFAULT} \
+ "invalid default button \"$data(-default)\""
}
# 2. Set the dialog to be a child window of $parent
diff --git a/library/palette.tcl b/library/palette.tcl
index 21be8dc..924dd61 100644
--- a/library/palette.tcl
+++ b/library/palette.tcl
@@ -36,7 +36,8 @@ proc ::tk_setPalette {args} {
array set new $args
}
if {![info exists new(background)]} {
- error "must specify a background color"
+ return -code error -errorcode {TK SET_PALETTE BACKGROUND} \
+ "must specify a background color"
}
set bg [winfo rgb . $new(background)]
if {![info exists new(foreground)]} {
diff --git a/library/safetk.tcl b/library/safetk.tcl
index e664ace..9f8e25d 100644
--- a/library/safetk.tcl
+++ b/library/safetk.tcl
@@ -114,8 +114,8 @@ proc ::safe::loadTk {} {}
}
if {$nDisplay ne $display} {
if {$displayGiven} {
- error "conflicting -display $display and -use\
- $use -> $nDisplay"
+ return -code error -errorcode {TK DISPLAY SAFE} \
+ "conflicting -display $display and -use $use -> $nDisplay"
} else {
set display $nDisplay
}
@@ -139,7 +139,7 @@ proc ::safe::TkInit {interpPath} {
} else {
Log $interpPath "TkInit called for interp with clearance:\
preventing Tk init" ERROR
- error "not allowed"
+ return -code error -errorcode {TK SAFE PERMISSION} "not allowed"
}
}
@@ -219,8 +219,8 @@ proc ::safe::tkTopLevel {slave display} {
incr tkSafeId
set w ".safe$tkSafeId"
if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
- return -code error "Unable to create toplevel for\
- safe slave \"$slave\" ($msg)"
+ return -code error -errorcode {TK TOPLEVEL SAFE} \
+ "Unable to create toplevel for safe slave \"$slave\" ($msg)"
}
Log $slave "New toplevel $w" NOTICE
diff --git a/library/spinbox.tcl b/library/spinbox.tcl
index 06c002c..641584d 100644
--- a/library/spinbox.tcl
+++ b/library/spinbox.tcl
@@ -376,7 +376,8 @@ proc ::tk::spinbox::ButtonDown {w x y} {
$w selection clear
}
default {
- return -code error "unknown spinbox element \"$Priv(element)\""
+ return -code error -errorcode {TK SPINBOX UNKNOWN_ELEMENT} \
+ "unknown spinbox element \"$Priv(element)\""
}
}
}
diff --git a/library/tk.tcl b/library/tk.tcl
index cac9075..e0d9eda 100644
--- a/library/tk.tcl
+++ b/library/tk.tcl
@@ -213,7 +213,8 @@ if {[tk windowingsystem] ne "win32"} {
} txt] && [catch {
selection get -displayof $w -selection $sel
} txt]} then {
- return -code error "could not find default selection"
+ return -code error -errorcode {TK SELECTION NONE} \
+ "could not find default selection"
} else {
return $txt
}
@@ -223,7 +224,8 @@ if {[tk windowingsystem] ne "win32"} {
if {[catch {
selection get -displayof $w -selection $sel
} txt]} then {
- return -code error "could not find default selection"
+ return -code error -errorcode {TK SELECTION NONE} \
+ "could not find default selection"
} else {
return $txt
}
diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl
index ae16939..6604575 100644
--- a/library/tkfbox.tcl
+++ b/library/tkfbox.tcl
@@ -313,7 +313,8 @@ proc ::tk::dialog::file::Config {dataName type argList} {
set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)]
if {![winfo exists $data(-parent)]} {
- error "bad window path name \"$data(-parent)\""
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
}
# Set -multiple to a one or zero value (not other boolean types like
diff --git a/library/unsupported.tcl b/library/unsupported.tcl
index feb9cc5..2c68e78 100644
--- a/library/unsupported.tcl
+++ b/library/unsupported.tcl
@@ -231,7 +231,8 @@ proc ::tk::unsupported::ExposePrivateCommand {cmd} {
variable PrivateCommands
set cmds [array get PrivateCommands $cmd]
if {[llength $cmds] == 0} {
- return -code error "No compatibility support for \[$cmd]"
+ return -code error -errorcode {TK EXPOSE_PRIVATE_COMMAND} \
+ "No compatibility support for \[$cmd]"
}
foreach {old new} $cmds {
namespace eval :: [list interp alias {} $old {}] $new
@@ -258,7 +259,8 @@ proc ::tk::unsupported::ExposePrivateVariable {var} {
variable PrivateVariables
set vars [array get PrivateVariables $var]
if {[llength $vars] == 0} {
- return -code error "No compatibility support for \$$var"
+ return -code error -errorcode {TK EXPOSE_PRIVATE_VARIABLE} \
+ "No compatibility support for \$$var"
}
namespace eval ::tk::mac {}
foreach {old new} $vars {
diff --git a/library/xmfbox.tcl b/library/xmfbox.tcl
index a1d6048..0578361 100644
--- a/library/xmfbox.tcl
+++ b/library/xmfbox.tcl
@@ -305,7 +305,8 @@ proc ::tk::MotifFDialog_Config {dataName type argList} {
set data(filter) *
}
if {![winfo exists $data(-parent)]} {
- error "bad window path name \"$data(-parent)\""
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
}
}
generated by cgit v0.12 at 2024-07-18 16:53:28 (GMT)