Generate -errorcode values to go with errors. Generate messages and postscript

using Tcl_Obj API, not the string result API.

17 files changed, 87 insertions, 53 deletions

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)\""
     }
 }