summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-03-09 09:12:38 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-03-09 09:12:38 (GMT)
commit0f443aa5cb126f232e2ffb85bb63b1e93f89564c (patch)
tree0ad84f916420342085164f7dfc0af2fa1bc87e2e
parente7ae31d6d3e1a343991401b5795fc1b04c6e8236 (diff)
downloadtcl-0f443aa5cb126f232e2ffb85bb63b1e93f89564c.zip
tcl-0f443aa5cb126f232e2ffb85bb63b1e93f89564c.tar.gz
tcl-0f443aa5cb126f232e2ffb85bb63b1e93f89564c.tar.bz2
Move the implementation of [try] from Tcl to C. Not yet bytecoded.
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclBasic.c3
-rw-r--r--generic/tclCmdMZ.c503
-rw-r--r--generic/tclInt.h6
-rw-r--r--library/init.tcl184
-rw-r--r--tests/error.test26
6 files changed, 524 insertions, 204 deletions
diff --git a/ChangeLog b/ChangeLog
index 19582a6..78eb759 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2009-03-09 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCmdMZ.c (Tcl_TryObjCmd, TclNRTryObjCmd): Moved the
+ implementation of [try] from Tcl code into C. Still lacks a bytecode
+ version, but should be better than what was before.
+
2009-03-04 Donal K. Fellows <dkf@users.sf.net>
* generic/tclZlib.c (TclZlibCmd): Checksums are defined to be unsigned
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b1a8d35..9f4d0dc 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.385 2009/02/03 23:34:33 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.386 2009/03/09 09:12:39 dkf Exp $
*/
#include "tclInt.h"
@@ -210,6 +210,7 @@ static const CmdInfo builtInCmds[] = {
{"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, NULL, 1},
{"throw", Tcl_ThrowObjCmd, NULL, NULL, 1},
{"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
+ {"try", Tcl_TryObjCmd, NULL, TclNRTryObjCmd, 1},
{"unset", Tcl_UnsetObjCmd, NULL, NULL, 1},
{"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
{"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 5a6f947..dbff659 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,12 +15,20 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.180 2009/02/25 14:56:05 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.181 2009/03/09 09:12:39 dkf Exp $
*/
#include "tclInt.h"
#include "tclRegexp.h"
+static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode,
+ Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
+static int TryPostBody(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int TryPostFinal(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int TryPostHandler(ClientData data[], Tcl_Interp *interp,
+ int result);
static int UniCharIsAscii(int character);
/*
@@ -4026,14 +4034,13 @@ Tcl_TimeObjCmd(
return TCL_OK;
}
-#if 0 /* not yet implemented */
/*
*----------------------------------------------------------------------
*
- * Tcl_TryObjCmd --
+ * Tcl_TryObjCmd, TclNRTryObjCmd --
*
* This procedure is invoked to process the "try" Tcl command. See the
- * user documentation for details on what it does.
+ * user documentation (or TIP #329) for details on what it does.
*
* Results:
* A standard Tcl object result.
@@ -4056,14 +4063,498 @@ Tcl_TryObjCmd(
int
TclNRTryObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
+ int i, bodyShared, haveHandlers, dummy, code;
+ static const char *handlerNames[] = {
+ "finally", "on", "trap", NULL
+ };
+ enum Handlers {
+ TryFinally, TryOn, TryTrap
+ };
+ static const char *exceptionNames[] = {
+ "ok", "error", "return", "break", "continue", NULL
+ };
+
+ /*
+ * Parse the arguments. The handlers are passed to subsequent callbacks as
+ * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix,
+ * bindVariables, script), and the finally script is just passed as it is.
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "body ?handler ...? ?finally script?");
+ return TCL_ERROR;
+ }
+ bodyObj = objv[1];
+ handlersObj = Tcl_NewObj();
+ bodyShared = 0;
+ haveHandlers = 0;
+ for (i=2 ; i<objc ; i++) {
+ int type;
+ Tcl_Obj *handlerItems[5];
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type",
+ 0, &type) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ switch ((enum Handlers) type) {
+ case TryFinally: /* finally script */
+ if (i < objc-2) {
+ Tcl_AppendResult(interp, "finally clause must be last", NULL);
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ } else if (i == objc-1) {
+ Tcl_AppendResult(interp, "wrong # args to finally clause: ",
+ "must be \"", TclGetString(objv[0]),
+ " ... finally script\"", NULL);
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ finallyObj = objv[++i];
+ break;
+
+ case TryOn: /* on code variableList script */
+ if (i > objc-4) {
+ Tcl_AppendResult(interp, "wrong # args to on clause: ",
+ "must be \"", TclGetString(objv[0]),
+ " ... on code variableList script\"", NULL);
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(NULL, objv[i+1], &code) != TCL_OK
+ && Tcl_GetIndexFromObj(NULL, objv[i+1], exceptionNames,
+ "code", 0, &code) != TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad code '%s': must be integer, \"ok\", \"error\", "
+ "\"return\", \"break\" or \"continue\"",
+ Tcl_GetString(objv[i+1])));
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ handlerItems[2] = NULL;
+ goto commonHandler;
+
+ case TryTrap: /* trap pattern variableList script */
+ if (i > objc-4) {
+ Tcl_AppendResult(interp, "wrong # args to trap clause: ",
+ "must be \"... trap pattern variableList script\"",
+ NULL);
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ code = 1;
+ if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad prefix '%s': must be a list",
+ Tcl_GetString(objv[i+1])));
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ handlerItems[2] = objv[i+1];
+
+ commonHandler:
+ if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+
+ handlerItems[0] = objv[i]; /* type */
+ TclNewIntObj(handlerItems[1], code); /* returnCode */
+ if (handlerItems[2] == NULL) { /* errorCodePrefix */
+ TclNewObj(handlerItems[2]);
+ }
+ handlerItems[3] = objv[i+2]; /* bindVariables */
+ handlerItems[4] = objv[i+3]; /* script */
+
+ bodyShared = !strcmp(TclGetString(objv[i+3]), "-");
+ Tcl_ListObjAppendElement(NULL, handlersObj,
+ Tcl_NewListObj(5, handlerItems));
+ haveHandlers = 1;
+ i += 3;
+ break;
+ }
+ }
+ if (bodyShared) {
+ Tcl_AppendResult(interp,
+ "last non-finally clause must not have a body of \"-\"",
+ NULL);
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ if (!haveHandlers) {
+ Tcl_DecrRefCount(handlersObj);
+ handlersObj = NULL;
+ }
+
+ /*
+ * Execute the body.
+ */
+
+ Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, objv[0],
+ NULL);
+ return TclNREvalObjEx(interp, bodyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * During --
+ *
+ * This helper function patches together the updates to the interpreter's
+ * return options that are needed when things fail during the processing
+ * of a handler or finally script for the [try] command.
+ *
+ * Returns:
+ * The new option dictionary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline Tcl_Obj *
+During(
+ Tcl_Interp *interp,
+ int resultCode, /* The result code from the just-evaluated
+ * script. */
+ Tcl_Obj *oldOptions, /* The old option dictionary. */
+ Tcl_Obj *errorInfo) /* An object to append to the errorinfo and
+ * release, or NULL if nothing is to be added.
+ * Designed to be used with Tcl_ObjPrintf. */
+{
+ Tcl_Obj *during, *options;
+
+ if (errorInfo != NULL) {
+ Tcl_AppendObjToErrorInfo(interp, errorInfo);
+ }
+ options = Tcl_GetReturnOptions(interp, resultCode);
+ TclNewLiteralStringObj(during, "-during");
+ Tcl_IncrRefCount(during);
+ Tcl_DictObjPut(interp, options, during, oldOptions);
+ Tcl_DecrRefCount(during);
+ Tcl_IncrRefCount(options);
+ Tcl_DecrRefCount(oldOptions);
+ return options;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostBody --
+ *
+ * Callback to handle the outcome of the execution of the body of a 'try'
+ * command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostBody(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj;
+ int i, dummy, code;
+
+ handlersObj = data[0];
+ finallyObj = data[1];
+ cmdObj = data[2];
+
+ /*
+ * Basic processing of the outcome of the script, including adding of
+ * errorinfo trace.
+ */
+
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"%s\" body line %d)", TclGetString(cmdObj),
+ Tcl_GetErrorLine(interp)));
+ }
+ if (handlersObj != NULL || finallyObj != NULL) {
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ } else {
+ options = NULL;
+ }
+ Tcl_ResetResult(interp);
+
+ /*
+ * Handle the results.
+ */
+
+ if (handlersObj != NULL) {
+ int numHandlers, found = 0;
+ Tcl_Obj **handlers, **info;
+
+ Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
+ for (i=0 ; i<numHandlers ; i++) {
+ Tcl_Obj *handlerObj;
+
+ Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info);
+ if (!found) {
+ Tcl_GetIntFromObj(NULL, info[1], &code);
+ if (code != result) {
+ continue;
+ }
+
+ /*
+ * When processing an error, must additionally perform
+ * list-prefix matching of the errorcode list.
+ */
+
+ if (code == TCL_ERROR) {
+ Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
+ int len1, len2, j;
+
+ TclNewLiteralStringObj(errorCodeName, "-errorcode");
+ Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
+ Tcl_DecrRefCount(errorCodeName);
+ Tcl_ListObjGetElements(NULL, info[2], &len1, &bits1);
+ if (Tcl_ListObjGetElements(NULL, errcode, &len2,
+ &bits2) != TCL_OK) {
+ continue;
+ }
+ if (len2 < len1) {
+ didNotMatch:
+ continue;
+ }
+ for (j=0 ; j<len1 ; j++) {
+ if (strcmp(TclGetString(bits1[j]),
+ TclGetString(bits2[j])) != 0) {
+ /*
+ * Really want continue outerloop, but C doesn't
+ * give us that.
+ */
+
+ goto didNotMatch;
+ }
+ }
+ }
+
+ found = 1;
+ }
+
+ /*
+ * Now we need to scan forward over "-" bodies. Note that we've
+ * already checked that the last body is not a "-", so this search
+ * will terminate successfully.
+ */
+
+ if (!strcmp(TclGetString(info[4]), "-")) {
+ continue;
+ }
+
+ /*
+ * Bind the variables. We already know this is a list of variable
+ * names, but it might be empty.
+ */
+
+ Tcl_ResetResult(interp);
+ result = TCL_ERROR;
+ Tcl_ListObjLength(NULL, info[3], &dummy);
+ if (dummy > 0) {
+ Tcl_Obj *varName;
+
+ Tcl_ListObjIndex(NULL, info[3], 0, &varName);
+ if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ goto handlerFailed;
+ }
+ if (dummy > 1) {
+ Tcl_ListObjIndex(NULL, info[3], 1, &varName);
+ if (Tcl_ObjSetVar2(interp, varName, NULL, options,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ goto handlerFailed;
+ }
+ }
+ }
+
+ /*
+ * Evaluate the handler body and process the outcome. Note that we
+ * need to keep the type of handler for debugging purposes.
+ */
+
+ handlerObj = info[0];
+ Tcl_IncrRefCount(handlerObj);
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_NRAddCallback(interp, TryPostHandler, cmdObj, options,
+ handlerObj, finallyObj);
+ return TclNREvalObjEx(interp, info[4], 0,
+ ((Interp *) interp)->cmdFramePtr, -1);
+
+ handlerFailed:
+ options = During(interp, result, options, NULL);
+ break;
+ }
+
+ /*
+ * No handler matched; get rid of the list of handlers.
+ */
+
+ Tcl_DecrRefCount(handlersObj);
+ }
+
+ /*
+ * Process the finally clause.
+ */
+
+ if (finallyObj != NULL) {
+ Tcl_NRAddCallback(interp, TryPostFinal, resultObj, INT2PTR(result),
+ options, cmdObj);
+ return TclNREvalObjEx(interp, finallyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, -1);
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ if (options != NULL) {
+ result = TclProcessReturn(interp, result, 0, options);
+ Tcl_DecrRefCount(options);
+ }
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostHandler --
+ *
+ * Callback to handle the outcome of the execution of a handler of a
+ * 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostHandler(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *cmdObj, *options, *handlerObj;
+ Tcl_Obj *finallyObj;
+
+ cmdObj = data[0];
+ options = data[1];
+ handlerObj = data[2];
+ finallyObj = data[3];
+
+ /*
+ * The handler result completely substitutes for the result of the body.
+ */
+
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ if (result == TCL_ERROR) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... %s\" handler line %d)",
+ TclGetString(cmdObj), TclGetString(handlerObj),
+ Tcl_GetErrorLine(interp)));
+ } else {
+ Tcl_DecrRefCount(options);
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ }
+ Tcl_DecrRefCount(handlerObj);
+
+ /*
+ * Process the finally clause if it is present.
+ */
+
+ if (finallyObj != NULL) {
+ Tcl_NRAddCallback(interp, TryPostFinal, resultObj, INT2PTR(result),
+ options, cmdObj);
+ return TclNREvalObjEx(interp, finallyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, -1);
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = TclProcessReturn(interp, result, 0, options);
+ Tcl_DecrRefCount(options);
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostFinal --
+ *
+ * Callback to handle the outcome of the execution of the finally script
+ * of a 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int finalResult)
+{
+ Tcl_Obj *resultObj, *options, *cmdObj;
+ int result;
+
+ resultObj = data[0];
+ result = PTR2INT(data[1]);
+ options = data[2];
+ cmdObj = data[3];
+
+ /*
+ * If the result wasn't OK, we need to adjust the result options.
+ */
+
+ if (finalResult != TCL_OK) {
+ Tcl_DecrRefCount(resultObj);
+ resultObj = NULL;
+ result = finalResult;
+ if (result == TCL_ERROR) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... finally\" body line %d)",
+ TclGetString(cmdObj), Tcl_GetErrorLine(interp)));
+ } else {
+ Tcl_Obj *origOptions = options;
+
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ Tcl_DecrRefCount(origOptions);
+ }
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+ result = TclProcessReturn(interp, result, 0, options);
+ Tcl_DecrRefCount(options);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ }
+ return result;
}
-#endif /* not yet implemented */
/*
*----------------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3de0ea2..3f7a2dc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.417 2009/02/13 03:22:52 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.418 2009/03/09 09:12:39 dkf Exp $
*/
#ifndef _TCLINT
@@ -2585,6 +2585,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
@@ -3126,6 +3127,9 @@ MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/library/init.tcl b/library/init.tcl
index 3ec3079..6ca4873 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.120 2009/01/16 20:44:25 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.121 2009/03/09 09:12:39 dkf Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -113,188 +113,6 @@ namespace eval tcl {
}
}
-# TIP #329: [try]
-# This is a *temporary* implementation, to be replaced with one in C and
-# bytecode at a later date before 8.6.0
-namespace eval ::tcl::control {
- # These are not local, since this allows us to [uplevel] a [catch] rather
- # than [catch] the [uplevel]ing of something, resulting in a cleaner
- # -errorinfo:
- variable em {}
- variable opts {}
-
- variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 }
-
- namespace export try
-
- # ::tcl::control::try --
- #
- # Advanced error handling construct.
- #
- # Arguments:
- # See try(n) for details
- proc try {args} {
- variable magicCodes
-
- # ----- Parse arguments -----
-
- set trybody [lindex $args 0]
- set finallybody {}
- set handlers [list]
- set i 1
-
- while {$i < [llength $args]} {
- switch -- [lindex $args $i] {
- "on" {
- incr i
- set code [lindex $args $i]
- if {[dict exists $magicCodes $code]} {
- set code [dict get $magicCodes $code]
- } elseif {![string is integer -strict $code]} {
- set msgPart [join [dict keys $magicCodes] {", "}]
- error "bad code '[lindex $args $i]': must be\
- integer or \"$msgPart\""
- }
- lappend handlers [lrange $args $i $i] \
- [format %d $code] {} {*}[lrange $args $i+1 $i+2]
- incr i 3
- }
- "trap" {
- incr i
- if {![string is list [lindex $args $i]]} {
- error "bad prefix '[lindex $args $i]':\
- must be a list"
- }
- lappend handlers [lrange $args $i $i] 1 \
- {*}[lrange $args $i $i+2]
- incr i 3
- }
- "finally" {
- incr i
- set finallybody [lindex $args $i]
- incr i
- break
- }
- default {
- error "bad handler '[lindex $args $i]': must be\
- \"on code varlist body\", or\
- \"trap prefix varlist body\""
- }
- }
- }
-
- if {($i != [llength $args]) || ([lindex $handlers end] eq "-")} {
- error "wrong # args: should be\
- \"try body ?handler ...? ?finally body?\""
- }
-
- # ----- Execute 'try' body -----
-
- variable em
- variable opts
- set EMVAR [namespace which -variable em]
- set OPTVAR [namespace which -variable opts]
- set code [uplevel 1 [list ::catch $trybody $EMVAR $OPTVAR]]
-
- if {$code == 1} {
- set line [dict get $opts -errorline]
- dict append opts -errorinfo \
- "\n (\"[lindex [info level 0] 0]\" body line $line)"
- }
-
- # Keep track of the original error message & options
- set _em $em
- set _opts $opts
-
- # ----- Find and execute handler -----
-
- set errorcode {}
- if {[dict exists $opts -errorcode]} {
- set errorcode [dict get $opts -errorcode]
- }
- set found false
- foreach {descrip oncode pattern varlist body} $handlers {
- if {!$found} {
- if {
- ($code != $oncode) || ([lrange $pattern 0 end] ne
- [lrange $errorcode 0 [llength $pattern]-1] )
- } then {
- continue
- }
- }
- set found true
- if {$body eq "-"} {
- continue
- }
-
- # Handler found ...
-
- # Assign trybody results into variables
- lassign $varlist resultsVarName optionsVarName
- if {[llength $varlist] >= 1} {
- upvar 1 $resultsVarName resultsvar
- set resultsvar $em
- }
- if {[llength $varlist] >= 2} {
- upvar 1 $optionsVarName optsvar
- set optsvar $opts
- }
-
- # Execute the handler
- set code [uplevel 1 [list ::catch $body $EMVAR $OPTVAR]]
-
- if {$code == 1} {
- set line [dict get $opts -errorline]
- dict append opts -errorinfo \
- "\n (\"[lindex [info level 0] 0] ... $descrip\"\
- body line $line)"
- # On error chain to original outcome
- dict set opts -during $_opts
- }
-
- # Handler result replaces the original result (whether success or
- # failure); capture context of original exception for reference.
- set _em $em
- set _opts $opts
-
- # Handler has been executed - stop looking for more
- break
- }
-
- # No catch handler found -- error falls through to caller
- # OR catch handler executed -- result falls through to caller
-
- # ----- If we have a finally block then execute it -----
-
- if {$finallybody ne {}} {
- set code [uplevel 1 [list ::catch $finallybody $EMVAR $OPTVAR]]
-
- # Finally result takes precedence except on success
-
- if {$code == 1} {
- set line [dict get $opts -errorline]
- dict append opts -errorinfo \
- "\n (\"[lindex [info level 0] 0] ... finally\"\
- body line $line)"
- # On error chain to original outcome
- dict set opts -during $_opts
- }
- if {$code != 0} {
- set _em $em
- set _opts $opts
- }
-
- # Otherwise our result is not affected
- }
-
- # Propagate the error or the result of the executed catch body to the
- # caller.
- dict incr _opts -level
- return -options $_opts $_em
- }
-}
-namespace import ::tcl::control::try
-
# Windows specific end of initialization
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
diff --git a/tests/error.test b/tests/error.test
index 6125dd4..4eb765e 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: error.test,v 1.18 2009/01/13 20:30:04 dkf Exp $
+# RCS: @(#) $Id: error.test,v 1.19 2009/03/09 09:12:39 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -396,38 +396,38 @@ test error-13.1 {try with no arguments} -body {
# warning: error message may change
try
} -returnCodes error -match glob -result {wrong # args: *}
-test error-13.2 {try with body only (ok) } {
+test error-13.2 {try with body only (ok)} {
try list
} {}
-test error-13.3 {try with missing finally body } -body {
+test error-13.3 {try with missing finally body} -body {
# warning: error message may change
try list finally
-} -returnCodes error -match glob -result {wrong # args: *}
-test error-13.4 {try with bad handler keyword } -body {
+} -returnCodes error -match glob -result {wrong # args to finally clause: *}
+test error-13.4 {try with bad handler keyword} -body {
# warning: error message may change
try list then a b c
} -returnCodes error -match glob -result {bad handler *}
-test error-13.5 {try with partial handler #1 } -body {
+test error-13.5 {try with partial handler #1} -body {
# warning: error message may change
try list on
-} -returnCodes error -match glob -result {bad code *}
-test error-13.6 {try with partial handler #2 } -body {
+} -returnCodes error -match glob -result {wrong # args to on clause: *}
+test error-13.6 {try with partial handler #2} -body {
# warning: error message may change
try list on error
-} -returnCodes error -match glob -result {wrong # args: *}
-test error-13.7 {try with partial handler #3 } -body {
+} -returnCodes error -match glob -result {wrong # args to on clause: *}
+test error-13.7 {try with partial handler #3} -body {
# warning: error message may change
try list on error {em opts}
-} -returnCodes error -match glob -result {wrong # args: *}
+} -returnCodes error -match glob -result {wrong # args to on clause: *}
test error-13.8 {try with multiple handlers and finally (ok)} {
try list on error {} {} trap {} {} {} finally {}
} {}
test error-13.9 {last handler body can't be a fallthrough #1} -body {
try list on error {} {} on break {} -
-} -returnCodes error -match glob -result {wrong # args: *}
+} -returnCodes error -result {last non-finally clause must not have a body of "-"}
test error-13.10 {last handler body can't be a fallthrough #2} -body {
try list on error {} {} on break {} - finally { list d e f }
-} -returnCodes error -match glob -result {wrong # args: *}
+} -returnCodes error -result {last non-finally clause must not have a body of "-"}
# try tests - multiple handlers (left-to-right matching, only one runs)