diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 503 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | library/init.tcl | 184 | ||||
| -rw-r--r-- | tests/error.test | 26 |
6 files changed, 524 insertions, 204 deletions
@@ -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) |