diff options
Diffstat (limited to 'generic/tclCmdMZ.c')
| -rw-r--r-- | generic/tclCmdMZ.c | 218 |
1 files changed, 1 insertions, 217 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 9a8b617..03a4ccb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -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: tclCmdMZ.c,v 1.114 2004/10/18 21:15:35 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.115 2004/10/21 15:19:46 dgp Exp $ */ #include "tclInt.h" @@ -868,222 +868,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * TclProcessReturn -- - * - * Does the work of the [return] command based on the code, - * level, and returnOpts arguments. Note that the code argument - * must agree with the -code entry in returnOpts and the level - * argument must agree with the -level entry in returnOpts, as - * is the case for values returned from TclMergeReturnOptions. - * - * Results: - * Returns the return code the [return] command should return. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -int -TclProcessReturn(interp, code, level, returnOpts) - Tcl_Interp *interp; - int code; - int level; - Tcl_Obj *returnOpts; -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *valuePtr; - - /* Store the merged return options */ - if (iPtr->returnOpts != returnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = returnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } - - if (code == TCL_ERROR) { - valuePtr = NULL; - Tcl_DictObjGet(NULL, iPtr->returnOpts, - iPtr->returnErrorinfoKey, &valuePtr); - if (valuePtr != NULL) { - int infoLen; - CONST char *info = Tcl_GetStringFromObj(valuePtr, &infoLen); - if (infoLen) { - Tcl_AddObjErrorInfo(interp, info, infoLen); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - } - valuePtr = NULL; - Tcl_DictObjGet(NULL, iPtr->returnOpts, - iPtr->returnErrorcodeKey, &valuePtr); - if (valuePtr != NULL) { - Tcl_SetObjErrorCode(interp, valuePtr); - } else { - Tcl_SetErrorCode(interp, "NONE", NULL); - } - - valuePtr = NULL; - Tcl_DictObjGet(NULL, iPtr->returnOpts, - iPtr->returnErrorlineKey, &valuePtr); - if (valuePtr != NULL) { - Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine); - } - } - if (level != 0) { - iPtr->returnLevel = level; - iPtr->returnCode = code; - return TCL_RETURN; - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclMergeReturnOptions -- - * - * Parses, checks, and stores the options to the [return] command. - * - * Results: - * Returns TCL_ERROR is any of the option values are invalid. - * Otherwise, returns TCL_OK, and writes the returnOpts, code, - * and level values to the pointers provided. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ - Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a - * (Tcl_Obj *) where the pointer to the - * merged return options dictionary should - * be written */ - int *codePtr; /* If not NULL, points to space where the - * -code value should be written */ - int *levelPtr; /* If not NULL, points to space where the - * -level value should be written */ -{ - Interp *iPtr = (Interp *) interp; - int code=TCL_OK; - int level = 1; - Tcl_Obj *valuePtr; - Tcl_Obj *returnOpts = Tcl_NewObj(); - - for (; objc > 1; objv += 2, objc -= 2) { - int optLen; - CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen); - int compareLen; - CONST char *compare = Tcl_GetStringFromObj( - iPtr->returnOptionsKey, &compareLen); - - if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { - Tcl_DictSearch search; - int done = 0; - Tcl_Obj *keyPtr; - Tcl_Obj *dict = objv[1]; - - nestedOptions: - if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, - &search, &keyPtr, &valuePtr, &done)) { - /* Value is not a legal dictionary */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", - compare, " value: expected dictionary but got \"", - TclGetString(objv[1]), "\"", (char *) NULL); - goto error; - } - - while (!done) { - Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); - } - - valuePtr = NULL; - Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr); - if (valuePtr != NULL) { - dict = valuePtr; - Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey); - goto nestedOptions; - } - - } else { - Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); - } - } - - /* Check for bogus -code value */ - Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr); - if ((valuePtr != NULL) - && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { - static CONST char *returnCodes[] = { - "ok", "error", "return", "break", "continue", NULL - }; - - if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes, - NULL, TCL_EXACT, &code)) { - /* Value is not a legal return code */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad completion code \"", - TclGetString(valuePtr), - "\": must be ok, error, return, break, ", - "continue, or an integer", (char *) NULL); - goto error; - } - Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey); - } - - /* Check for bogus -level value */ - Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr); - if (valuePtr != NULL) { - if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) - || (level < 0)) { - /* Value is not a legal level */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -level value: ", - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", (char *) NULL); - goto error; - } - Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey); - } - - /* - * Convert [return -code return -level X] to - * [return -code ok -level X+1] - */ - if (code == TCL_RETURN) { - level++; - code = TCL_OK; - } - - if (codePtr != NULL) { - *codePtr = code; - } - if (levelPtr != NULL) { - *levelPtr = level; - } - if (optionsPtrPtr == NULL) { - /* Not passing back the options (?!), so clean them up */ - Tcl_DecrRefCount(returnOpts); - } else { - *optionsPtrPtr = returnOpts; - } - return TCL_OK; - -error: - Tcl_DecrRefCount(returnOpts); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SourceObjCmd -- * * This procedure is invoked to process the "source" Tcl command. |