diff options
author | dgp <dgp@users.sourceforge.net> | 2012-11-16 22:51:18 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2012-11-16 22:51:18 (GMT) |
commit | e9cf99c21231dad15d31ffeaac55995ab1f0bf49 (patch) | |
tree | be5a399ed574820d42a50aa0bc73bf00f69ded73 /generic | |
parent | b339d4bf03af06566a6b7f37a6154e8f86c6caf5 (diff) | |
parent | 858c24761a7fd85cfa09b2dd4eb401723851bff6 (diff) | |
download | tcl-e9cf99c21231dad15d31ffeaac55995ab1f0bf49.zip tcl-e9cf99c21231dad15d31ffeaac55995ab1f0bf49.tar.gz tcl-e9cf99c21231dad15d31ffeaac55995ab1f0bf49.tar.bz2 |
merge trunk
Diffstat (limited to 'generic')
73 files changed, 7019 insertions, 2935 deletions
diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 188d6de..f3db471 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -354,13 +354,14 @@ static const chr punctCharTable[] = { */ static const crange spaceRangeTable[] = { - {0x9, 0xd}, {0x2000, 0x200a} + {0x9, 0xd}, {0x2000, 0x200b} }; #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x3000 + 0x20, 0x85, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, + 0x2060, 0x3000, 0xfeff }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) @@ -617,7 +618,7 @@ static const crange graphRangeTable[] = { {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e}, - {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20b9}, {0x20d0, 0x20f0}, + {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0}, {0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a}, {0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, diff --git a/generic/tcl.decls b/generic/tcl.decls index b421ae2..1829249 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2318,6 +2318,12 @@ declare 629 { int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) } +# TIP #400 +declare 630 { + void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) +} + # ----- BASELINE -- FOR -- 8.6.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index a7d3917..300614c 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -51,17 +51,15 @@ extern "C" { * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) - * tools/tcl.wse.in (for windows installer) - * tools/tclSplash.bmp (not patchlevel) */ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_BETA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6b2" +#define TCL_PATCH_LEVEL "8.6b3" /* *---------------------------------------------------------------------------- @@ -2332,6 +2330,14 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, /* *---------------------------------------------------------------------------- + * Definitions needed for the Tcl_LoadFile function. [TIP #416] + */ + +#define TCL_LOAD_GLOBAL 1 +#define TCL_LOAD_LAZY 2 + +/* + *---------------------------------------------------------------------------- * Single public declaration for NRE. */ diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 83f4fe9..7833105 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -362,6 +362,10 @@ static const TalInstDesc TalInstructionTable[] = { | INST_APPEND_ARRAY4), 2, 1}, {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, + {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, + {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, + {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, + {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, {"beginCatch", ASSEM_BEGIN_CATCH, INST_BEGIN_CATCH4, 0, 0}, {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, @@ -369,7 +373,10 @@ static const TalInstDesc TalInstructionTable[] = { {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, + {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, + {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, @@ -406,6 +413,8 @@ static const TalInstDesc TalInstructionTable[] = { {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, 1, 1}, + {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, + {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 | INST_INVOKE_STK4), INT_MIN,1}, {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, @@ -457,6 +466,7 @@ static const TalInstDesc TalInstructionTable[] = { 0, 1}, {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1}, + {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 @@ -467,11 +477,19 @@ static const TalInstDesc TalInstructionTable[] = { {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, + {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, + {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, + {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, + {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, + {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, + {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, + {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, + {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, @@ -481,6 +499,8 @@ static const TalInstDesc TalInstructionTable[] = { {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, + {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, + {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, {NULL, 0, 0, 0, 0} }; @@ -499,7 +519,13 @@ static const unsigned char NonThrowingByteCodes[] = { INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ - INST_NOP /* 132 */ + INST_NOP, /* 132 */ + INST_STR_MAP, /* 143 */ + INST_STR_FIND, /* 144 */ + INST_COROUTINE_NAME, /* 149 */ + INST_NS_CURRENT, /* 151 */ + INST_INFO_LEVEL_NUM, /* 152 */ + INST_RESOLVE_COMMAND /* 154 */ }; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4d6ff0c..971ae36 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -131,13 +131,11 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); -static Tcl_NRPostProc NRCoroutineActivateCallback; static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); static Tcl_NRPostProc NRRunObjProc; -static Tcl_NRPostProc NRTailcallEval; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -219,7 +217,7 @@ static const CmdInfo builtInCmds[] = { {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, @@ -230,6 +228,7 @@ static const CmdInfo builtInCmds[] = { {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, @@ -240,7 +239,7 @@ static const CmdInfo builtInCmds[] = { {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1}, {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, @@ -248,7 +247,7 @@ static const CmdInfo builtInCmds[] = { {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, @@ -257,7 +256,7 @@ static const CmdInfo builtInCmds[] = { {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, + {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, /* @@ -1696,9 +1695,9 @@ Tcl_HideCommand( */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" - " token (rename)", NULL); + " token (rename)", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); return TCL_ERROR; } @@ -1721,8 +1720,9 @@ Tcl_HideCommand( */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_AppendResult(interp, "can only hide global namespace commands" - " (use rename then hide)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only hide global namespace commands (use rename then hide)", + -1)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1746,8 +1746,9 @@ Tcl_HideCommand( hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "hidden command named \"%s\" already exists", + hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); return TCL_ERROR; } @@ -1849,8 +1850,9 @@ Tcl_ExposeCommand( */ if (strstr(cmdName, "::") != NULL) { - Tcl_AppendResult(interp, "cannot expose to a namespace " - "(use expose to toplevel, then rename)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot expose to a namespace (use expose to toplevel, then rename)", + -1)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1865,8 +1867,8 @@ Tcl_ExposeCommand( hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown hidden command \"%s\"", hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", hiddenCmdToken, NULL); return TCL_ERROR; @@ -1885,9 +1887,9 @@ Tcl_ExposeCommand( * than 'nicely' erroring out ? */ - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "trying to expose a non-global command namespace command", - NULL); + -1)); return TCL_ERROR; } @@ -1904,8 +1906,8 @@ Tcl_ExposeCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "exposed command \"", cmdName, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "exposed command \"%s\" already exists", cmdName)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); return TCL_ERROR; } @@ -2478,9 +2480,10 @@ TclRenameCommand( cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "can't ", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", NULL); + oldName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } @@ -2510,15 +2513,15 @@ TclRenameCommand( TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": bad command name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": bad command name", newName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": command already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": command already exists", newName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", "TARGET_EXISTS", NULL); result = TCL_ERROR; @@ -3519,9 +3522,9 @@ OldMathFuncProc( * We have a non-numeric argument. */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", - TCL_STATIC); + -1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); ckfree(args); return TCL_ERROR; @@ -3734,41 +3737,28 @@ Tcl_ListMathFuncs( Tcl_Interp *interp, const char *pattern) { - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *nsPtr; - Namespace *dummy1NsPtr; - Namespace *dummy2NsPtr; - const char *dummyNamePtr; - Tcl_Obj *result = Tcl_NewObj(); - - TclGetNamespaceForQualName(interp, "::tcl::mathfunc", - globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr); - if (nsPtr == NULL) { - return result; + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ } - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(pattern, -1)); - } + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } else { - Tcl_HashSearch cmdHashSearch; - Tcl_HashEntry *cmdHashEntry = - Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch); - - for (; cmdHashEntry != NULL; - cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) { - const char *cmdNamePtr = - Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry); - - if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(cmdNamePtr, -1)); - } - } + result = Tcl_NewObj(); } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + return result; } @@ -3808,9 +3798,8 @@ TclInterpReady( */ if (iPtr->flags & DELETED) { - /* JJM - Superfluous Tcl_ResetResult call removed. */ - Tcl_AppendResult(interp, - "attempt to call eval in deleted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to call eval in deleted interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; @@ -3838,8 +3827,8 @@ TclInterpReady( return TCL_OK; } - Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "too many nested evaluations (infinite loop?)", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); return TCL_ERROR; } @@ -3973,8 +3962,7 @@ Tcl_Canceled( } } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); } @@ -4582,8 +4570,8 @@ TEOV_NotFound( cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[0]), NULL); @@ -6242,11 +6230,11 @@ ProcessUnexpectedResult( Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_AppendResult(interp, - "invoked \"break\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"break\" outside of a loop", -1)); } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendResult(interp, - "invoked \"continue\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", -1)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); @@ -6567,7 +6555,8 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal argument vector", -1)); return TCL_ERROR; } @@ -6585,8 +6574,8 @@ TclObjInvoke( hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "invalid hidden command name \"", - cmdName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid hidden command name \"%s\"", cmdName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, NULL); return TCL_ERROR; @@ -7194,7 +7183,8 @@ ExprIsqrtFunc( return TCL_OK; negarg: - Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); return TCL_ERROR; @@ -8243,10 +8233,9 @@ TclNRTailcallObjCmd( return TCL_ERROR; } - if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */ - Tcl_SetResult(interp, - "tailcall can only be called from a proc or lambda", - TCL_STATIC); + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); return TCL_ERROR; } @@ -8284,7 +8273,7 @@ TclNRTailcallObjCmd( } Tcl_IncrRefCount(nsObjPtr); - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, NULL, NULL); tailcallPtr = TOP_CB(interp); TOP_CB(interp) = tailcallPtr->nextPtr; @@ -8294,7 +8283,7 @@ TclNRTailcallObjCmd( } int -NRTailcallEval( +TclNRTailcallEval( ClientData data[], Tcl_Interp *interp, int result) @@ -8405,8 +8394,8 @@ TclNRYieldObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8416,7 +8405,7 @@ TclNRYieldObjCmd( } NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, clientData, NULL, NULL); return TCL_OK; } @@ -8439,8 +8428,8 @@ TclNRYieldToObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yieldto can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8488,7 +8477,7 @@ YieldToCallback( * yieldTo: invoke the command using tailcall tech. */ - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL); cbPtr = TOP_CB(interp); TOP_CB(interp) = cbPtr->nextPtr; @@ -8633,7 +8622,7 @@ NRCoroutineExitCallback( /* *---------------------------------------------------------------------- * - * NRCoroutineActivateCallback -- + * TclNRCoroutineActivateCallback -- * * This is the workhorse for coroutines: it implements both yield and * resume. @@ -8647,8 +8636,8 @@ NRCoroutineExitCallback( *---------------------------------------------------------------------- */ -static int -NRCoroutineActivateCallback( +int +TclNRCoroutineActivateCallback( ClientData data[], Tcl_Interp *interp, int result) @@ -8688,8 +8677,8 @@ NRCoroutineActivateCallback( */ if (corPtr->stackLevel != stackLevel) { - Tcl_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot yield: C stack busy", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL); return TCL_ERROR; @@ -8748,8 +8737,8 @@ NRCoroInjectObjCmd( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_AppendResult(interp, "can only inject a command into a coroutine", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -8757,8 +8746,8 @@ NRCoroInjectObjCmd( corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_AppendResult(interp, - "can only inject a command into a suspended coroutine", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); return TCL_ERROR; } @@ -8774,7 +8763,7 @@ NRCoroInjectObjCmd( return TCL_OK; } - + int TclNRInterpCoroutine( ClientData clientData, @@ -8785,9 +8774,9 @@ TclNRInterpCoroutine( CoroutineData *corPtr = clientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]), - "\" is already running", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "coroutine \"%s\" is already running", + Tcl_GetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } @@ -8823,7 +8812,7 @@ TclNRInterpCoroutine( break; } - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, NULL, NULL, NULL); return TCL_OK; } @@ -8868,22 +8857,24 @@ TclNRCoroutineObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": bad procedure name", + fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } @@ -8947,7 +8938,6 @@ TclNRCoroutineObjCmd( corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; corPtr->stackLevel = NULL; corPtr->auxNumLevels = 0; - iPtr->numLevels--; /* * Create the coro's execEnv, switch to it to push the exit and coro @@ -8966,19 +8956,20 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); + /* insure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + iPtr->numLevels--; SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); iPtr->execEnvPtr = corPtr->callerEEPtr; /* - * Now just resume the coroutine. Take care to insure that the command is - * looked up in the correct namespace. + * Now just resume the coroutine. */ - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, NULL, NULL, NULL); return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 444e7fa..3d8b24c 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -303,18 +303,16 @@ Tcl_SetByteArrayObj( TclFreeIntRep(objPtr); Tcl_InvalidateStringRep(objPtr); - length = (length < 0) ? 0 : length; + if (length < 0) { + length = 0; + } byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length) { - if (bytes) { - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); - } else { - memset(byteArrayPtr->bytes, 0, (size_t) length); - } - } + if ((bytes != NULL) && (length > 0)) { + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + } objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } @@ -873,9 +871,9 @@ BinaryFormatCmd( if (count == BINARY_ALL) { count = listc; } else if (count > listc) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", - NULL); + -1)); return TCL_ERROR; } } @@ -884,9 +882,8 @@ BinaryFormatCmd( case 'x': if (count == BINARY_ALL) { - Tcl_AppendResult(interp, - "cannot use \"*\" in format string with \"x\"", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot use \"*\" in format string with \"x\"", -1)); return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; @@ -1198,8 +1195,9 @@ BinaryFormatCmd( badValue: Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected ", errorString, - " string but got \"", errorValue, "\" instead", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected %s string but got \"%s\" instead", + errorString, errorValue)); return TCL_ERROR; badCount: @@ -1217,12 +1215,13 @@ BinaryFormatCmd( Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); return TCL_ERROR; } error: - Tcl_AppendResult(interp, errorString, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } @@ -1586,12 +1585,13 @@ BinaryScanCmd( Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); return TCL_ERROR; } error: - Tcl_AppendResult(interp, errorString, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 5b5a0d6..ab977cb 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -170,11 +170,15 @@ TclInitDbCkalloc(void) */ int -TclDumpMemoryInfo(ClientData clientData, int flags) +TclDumpMemoryInfo( + ClientData clientData, + int flags) { char buf[1024]; - if (clientData == NULL) { return 0; } + if (clientData == NULL) { + return 0; + } sprintf(buf, "total mallocs %10d\n" "total frees %10d\n" @@ -815,15 +819,16 @@ MemoryCmd( size_t len; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option [args..]\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s option [args..]\"", argv[0])); return TCL_ERROR; } - if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { + if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s file\"", + argv[0], argv[1])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -833,7 +838,8 @@ MemoryCmd( result = Tcl_DumpActiveMemory(fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { - Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s", + argv[2], Tcl_PosixError(interp))); return TCL_ERROR; } return TCL_OK; @@ -857,17 +863,17 @@ MemoryCmd( "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); return TCL_OK; } - if (strcmp(argv[1],"init") == 0) { + if (strcmp(argv[1], "init") == 0) { if (argc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } - if (strcmp(argv[1],"objs") == 0) { + if (strcmp(argv[1], "objs") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " objs file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s objs file\"", argv[0])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -876,7 +882,9 @@ MemoryCmd( } fileP = fopen(fileName, "w"); if (fileP == NULL) { - Tcl_AppendResult(interp, "cannot open output file", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot open output file: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } TclDbDumpActiveObjects(fileP); @@ -886,8 +894,8 @@ MemoryCmd( } if (strcmp(argv[1],"onexit") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " onexit file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s onexit file\"", argv[0])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -901,8 +909,8 @@ MemoryCmd( } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " tag string\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s tag string\"", argv[0])); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { @@ -939,19 +947,20 @@ MemoryCmd( return TCL_OK; } - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be active, break_on_malloc, info, init, objs, onexit, " - "tag, trace, trace_on_at_malloc, or validate", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": should be active, break_on_malloc, info, " + "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate", + argv[1])); return TCL_ERROR; argError: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " count\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s count\"", argv[0], argv[1])); return TCL_ERROR; bad_suboption: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " on|off\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1])); return TCL_ERROR; } @@ -981,8 +990,8 @@ CheckmemCmd( const char *argv[]) /* String values of arguments. */ { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s fileName\"", argv[0])); return TCL_ERROR; } tclMemDumpFileName = dumpFile; @@ -1250,7 +1259,9 @@ Tcl_ValidateAllMemory( } int -TclDumpMemoryInfo(ClientData clientData, int flags) +TclDumpMemoryInfo( + ClientData clientData, + int flags) { return 1; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 7fa4017..6d2976d 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -878,8 +878,8 @@ ConvertLocalToUTCUsingC( if (localErrno != 0 || (fields->seconds == -1 && timeVal.tm_yday == -1)) { - Tcl_SetResult(interp, "time value too large/small to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time value too large/small to represent", -1)); return TCL_ERROR; } return TCL_OK; @@ -1018,17 +1018,17 @@ ConvertUTCToLocalUsingC( tock = (time_t) fields->seconds; if ((Tcl_WideInt) tock != fields->seconds) { - Tcl_AppendResult(interp, - "number too large to represent as a Posix time", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "number too large to represent as a Posix time", -1)); Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime(&tock); if (timeVal == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "localtime failed (clock value may be too " - "large/small to represent)", NULL); + "large/small to represent)", -1)); Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f09ee70..14951e4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -32,6 +32,9 @@ struct ForeachState { int *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ + Tcl_Obj *resultList; /* List of result values from the loop body, + * or NULL if we're not collecting them + * ([lmap] vs [foreach]). */ }; /* @@ -52,6 +55,8 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); +static inline int EachloopCmd(Tcl_Interp *interp, int collect, + int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; @@ -194,7 +199,8 @@ Tcl_CaseObjCmd( if (i == caseObjc-1) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra case pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra case pattern with no body", -1)); return TCL_ERROR; } @@ -409,8 +415,9 @@ Tcl_CdObjCmd( } else { result = Tcl_FSChdir(dir); if (result != TCL_OK) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't change working directory to \"%s\": %s", + TclGetString(dir), Tcl_PosixError(interp))); result = TCL_ERROR; } } @@ -642,8 +649,9 @@ EncodingDirsObjCmd( dirListObj = objv[2]; if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected directory list but got \"", - TclGetString(dirListObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected directory list but got \"%s\"", + TclGetString(dirListObj))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH", NULL); return TCL_ERROR; @@ -1165,9 +1173,9 @@ FileAttrAccessTimeCmd( tval.modtime = buf.st_mtime; if (Tcl_FSUtime(objv[1], &tval) != 0) { - Tcl_AppendResult(interp, "could not set access time for file \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set access time for file \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1237,9 +1245,9 @@ FileAttrModifyTimeCmd( tval.modtime = newTime; if (Tcl_FSUtime(objv[1], &tval) != 0) { - Tcl_AppendResult(interp, "could not set modification time for " - "file \"", TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set modification time for file \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1842,7 +1850,7 @@ PathFilesystemCmd( } fsInfo = Tcl_FSFileSystemInfo(objv[1]); if (fsInfo == NULL) { - Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; @@ -1990,8 +1998,9 @@ PathSplitCmd( } res = Tcl_FSSplitPath(objv[1], NULL); if (res == NULL) { - Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]), - "\": no such file or directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH", NULL); return TCL_ERROR; @@ -2092,7 +2101,8 @@ FilesystemSeparatorCmd( Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]); if (separatorObj == NULL) { - Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; @@ -2211,9 +2221,9 @@ GetStatBuf( if (status < 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2560,7 +2570,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2592,6 +2602,38 @@ TclNRForeachCmd( int objc, Tcl_Obj *const objv[]) { + return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv); +} + +int +Tcl_LmapObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv); +} + +int +TclNRLmapCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); +} + +static inline int +EachloopCmd( + Tcl_Interp *interp, /* Our context for variables and script + * evaluation. */ + int collect, /* Select collecting or accumulating mode + * (TCL_EACH_*) */ + int objc, /* The arguments being passed in... */ + Tcl_Obj *const objv[]) +{ int numLists = (objc-2) / 2; register struct ForeachState *statePtr; int i, j, result; @@ -2635,6 +2677,12 @@ TclNRForeachCmd( statePtr->bodyPtr = objv[objc - 1]; statePtr->bodyIdx = objc - 1; + if (collect == TCL_EACH_COLLECT) { + statePtr->resultList = Tcl_NewListObj(0, NULL); + } else { + statePtr->resultList = NULL; + } + /* * Break up the value lists and variable lists into elements. */ @@ -2648,8 +2696,11 @@ TclNRForeachCmd( TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { - Tcl_AppendResult(interp, "foreach varlist is empty", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s varlist is empty", + (statePtr->resultList != NULL ? "lmap" : "foreach"))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), "NEEDVARS", NULL); result = TCL_ERROR; goto done; @@ -2719,14 +2770,21 @@ ForeachLoopStep( switch (result) { case TCL_CONTINUE: result = TCL_OK; + break; case TCL_OK: + if (statePtr->resultList != NULL) { + Tcl_ListObjAppendElement(interp, statePtr->resultList, + Tcl_GetObjResult(interp)); + } break; case TCL_BREAK: result = TCL_OK; - goto done; + goto finish; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); + "\n (\"%s\" body line %d)", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + Tcl_GetErrorLine(interp))); default: goto done; } @@ -2751,7 +2809,14 @@ ForeachLoopStep( * We're done. Tidy up our work space and finish off. */ - Tcl_ResetResult(interp); + finish: + if (statePtr->resultList == NULL) { + Tcl_ResetResult(interp); + } else { + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ + } + done: ForeachCleanup(interp, statePtr); return result; @@ -2784,7 +2849,8 @@ ForeachAssignments( if (varValuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting foreach loop variable \"%s\")", + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), TclGetString(statePtr->varvList[i][v]))); return TCL_ERROR; } @@ -2813,6 +2879,9 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } + if (statePtr->resultList != NULL) { + TclDecrRefCount(statePtr->resultList); + } TclStackFree(interp, statePtr); } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b312026..155e8e4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -27,15 +27,15 @@ */ typedef struct SortElement { - union { /* The value that we sorting by. */ + union { /* The value that we sorting by. */ const char *strValuePtr; long intValue; double doubleValue; Tcl_Obj *objValuePtr; } collationKey; - union { /* Object being sorted, or its index. */ - Tcl_Obj *objPtr; - int index; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ @@ -164,9 +164,9 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, - {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, - {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, @@ -174,7 +174,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0}, - {"level", InfoLevelCmd, NULL, NULL, NULL, 0}, + {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, {"library", InfoLibraryCmd, NULL, NULL, NULL, 0}, {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0}, {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0}, @@ -229,8 +229,9 @@ TclNRIfObjCmd( Tcl_Obj *boolObj; if (objc <= 1) { - Tcl_AppendResult(interp, "wrong # args: no expression after \"", - TclGetString(objv[0]), "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -319,8 +320,9 @@ IfConditionCallback( */ if (i >= objc) { - Tcl_AppendResult(interp, "wrong # args: ", - "no expression after \"", clause, "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + clause)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -345,8 +347,9 @@ IfConditionCallback( } } if (i < objc - 1) { - Tcl_AppendResult(interp, "wrong # args: ", - "extra words after \"else\" clause in \"if\" command", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args: extra words after \"else\" clause in \"if\" command", + -1)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -361,9 +364,9 @@ IfConditionCallback( return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); missingScript: - clause = TclGetString(objv[i-1]); - Tcl_AppendResult(interp, "wrong # args: no script following \"", clause, - "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no script following \"%s\" argument", + TclGetString(objv[i-1]))); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -491,7 +494,8 @@ InfoArgsCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -552,7 +556,8 @@ InfoBodyCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -981,7 +986,8 @@ InfoDefaultCmd( procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, NULL); return TCL_ERROR; @@ -1012,8 +1018,9 @@ InfoDefaultCmd( } } - Tcl_AppendResult(interp, "procedure \"", procName, - "\" doesn't have an argument \"", argName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\" doesn't have an argument \"%s\"", + procName, argName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; } @@ -1055,10 +1062,10 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); - if (target == NULL) { - return TCL_ERROR; - } + target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + if (target == NULL) { + return TCL_ERROR; + } } iPtr = (Interp *) target; @@ -1158,12 +1165,13 @@ InfoFrameCmd( * A coroutine: must fix the level computations AND the cmdFrame chain, * which is interrupted at the base. */ + CmdFrame *lastPtr = NULL; - runPtr = iPtr->cmdFramePtr; + runPtr = iPtr->cmdFramePtr; /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; + topLevel += corPtr->caller.cmdFramePtr->level; while (runPtr) { runPtr->level += corPtr->caller.cmdFramePtr->level; lastPtr = runPtr; @@ -1196,8 +1204,8 @@ InfoFrameCmd( if ((level > topLevel) || (level <= - topLevel)) { levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", TclGetString(objv[1]), NULL); code = TCL_ERROR; @@ -1401,15 +1409,15 @@ TclInfoFrame( Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; if (namePtr) { - Tcl_Obj *procNameObj; + Tcl_Obj *procNameObj; /* * This is a regular command. */ - TclNewObj(procNameObj); - Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, - procNameObj); + TclNewObj(procNameObj); + Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, + procNameObj); ADD_PAIR("proc", procNameObj); } else if (procPtr->cmdPtr->clientData) { ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; @@ -1484,19 +1492,42 @@ InfoFunctionsCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *pattern; + Tcl_Obj *script; + int code; - if (objc == 1) { - pattern = NULL; - } else if (objc == 2) { - pattern = TclGetString(objv[1]); - } else { + if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_ListMathFuncs(interp, pattern)); - return TCL_OK; + script = Tcl_NewStringObj( +" ::apply [::list {{pattern *}} {\n" +" ::set cmds {}\n" +" ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n" +" ::lappend cmds [::namespace tail $cmd]\n" +" }\n" +" ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n" +" ::set cmd [::namespace tail $cmd]\n" +" ::if {$cmd ni $cmds} {\n" +" ::lappend cmds $cmd\n" +" }\n" +" }\n" +" ::return $cmds\n" +" } [::namespace current]] ", -1); + + if (objc == 2) { + Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1])); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); + } + + Tcl_IncrRefCount(script); + code = Tcl_EvalObjEx(interp, script, 0); + + Tcl_DecrRefCount(script); + + return code; } /* @@ -1538,7 +1569,9 @@ InfoHostnameCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); return TCL_OK; } - Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC); + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to determine name of host", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); return TCL_ERROR; } @@ -1609,8 +1642,8 @@ InfoLevelCmd( return TCL_ERROR; levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -1656,7 +1689,9 @@ InfoLibraryCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; } - Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC); + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no library has been specified for Tcl", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); return TCL_ERROR; } @@ -2590,9 +2625,10 @@ Tcl_LrepeatObjCmd( return TCL_ERROR; } if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_Format(NULL, - "bad count \"%d\": must be integer >= 0", 1, objv+1)); - Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%d\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", + NULL); return TCL_ERROR; } @@ -2608,7 +2644,7 @@ Tcl_LrepeatObjCmd( if (elementCount && objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } totalElems = objc * elementCount; @@ -2723,9 +2759,10 @@ Tcl_LreplaceObjCmd( */ if ((first >= listLen) && (listLen > 0)) { - Tcl_AppendResult(interp, "list doesn't contain element ", - TclGetString(objv[2]), NULL); - Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list doesn't contain element %s", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", + NULL); return TCL_ERROR; } if (last >= listLen) { @@ -2996,8 +3033,9 @@ Tcl_LsearchObjCmd( Tcl_DecrRefCount(startPtr); } if (i > objc-4) { - Tcl_AppendResult(interp, "missing starting index", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing starting index", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } @@ -3027,10 +3065,10 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } @@ -3088,18 +3126,18 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, - "-subindices cannot be used without -index option", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-subindices cannot be used without -index option", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); return TCL_ERROR; } if (bisect && (allMatches || negatedMatch)) { - Tcl_AppendResult(interp, - "-bisect is not compatible with -all or -not", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-bisect is not compatible with -all or -not", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); return TCL_ERROR; } @@ -3531,7 +3569,7 @@ Tcl_LsetObjCmd( if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); + "listVar ?index? ?index ...? value"); return TCL_ERROR; } @@ -3664,10 +3702,10 @@ Tcl_LsortObjCmd( break; case LSORT_COMMAND: if (i == objc-2) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-command\" option must be followed " - "by comparison command", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + "by comparison command", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3685,29 +3723,30 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int indexc, dummy; + int indexc, dummy; Tcl_Obj **indexv; if (i == objc-2) { - Tcl_AppendResult(interp, "\"-index\" option must be " - "followed by list index", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - sortInfo.resultCode = TCL_ERROR; - goto done2; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-index\" option must be followed by list index", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; } if (TclListObjGetElements(interp, objv[i+1], &indexc, &indexv) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done2; + sortInfo.resultCode = TCL_ERROR; + goto done2; } - /* - * Check each of the indices for syntactic correctness. Note that - * we do not store the converted values here because we do not - * know if this is the only -index option yet and so we can't - * allocate any space; that happens after the scan through all the - * options is done. - */ + /* + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. + */ for (j=0 ; j<indexc ; j++) { if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, @@ -3719,7 +3758,7 @@ Tcl_LsortObjCmd( } } indexPtr = objv[i+1]; - i++; + i++; break; } case LSORT_INTEGER: @@ -3739,9 +3778,10 @@ Tcl_LsortObjCmd( break; case LSORT_STRIDE: if (i == objc-2) { - Tcl_AppendResult(interp, "\"-stride\" option must be ", - "followed by stride length", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3750,10 +3790,10 @@ Tcl_LsortObjCmd( goto done2; } if (groupSize < 2) { - Tcl_AppendResult(interp, "stride length must be at least 2", - NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADSTRIDE", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 2", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3773,26 +3813,26 @@ Tcl_LsortObjCmd( */ if (indexPtr) { - Tcl_Obj **indexv; - - TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); - switch (sortInfo.indexc) { - case 0: - sortInfo.indexv = NULL; - break; - case 1: - sortInfo.indexv = &sortInfo.singleIndex; - break; - default: - sortInfo.indexv = + Tcl_Obj **indexv; + + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); - allocatedIndexVector = 1; /* Cannot use indexc field, as it - * might be decreased by 1 later. */ - } - for (j=0 ; j<sortInfo.indexc ; j++) { - TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ + } + for (j=0 ; j<sortInfo.indexc ; j++) { + TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, &sortInfo.indexv[j]); - } + } } listObj = objv[objc-1]; @@ -3847,11 +3887,11 @@ Tcl_LsortObjCmd( if (group) { if (length % groupSize) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", - NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -3867,11 +3907,11 @@ Tcl_LsortObjCmd( groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; } if (groupOffset < 0 || groupOffset >= groupSize) { - Tcl_AppendResult(interp, "when used with \"-stride\", the " - "leading \"-index\" value must be within the group", - NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADINDEX", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADINDEX", NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4255,11 +4295,10 @@ SortCompare( if (TclGetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { - Tcl_ResetResult(infoPtr->interp); - Tcl_AppendResult(infoPtr->interp, - "-compare command returned non-integer result", NULL); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "COMPARISONFAILED", NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( + "-compare command returned non-integer result", -1)); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "COMPARISONFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return 0; } @@ -4470,11 +4509,11 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "INDEXFAILED", NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "INDEXFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -4489,6 +4528,5 @@ SelectObjFromSublist( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7e94d9f..fc957c4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -34,12 +34,35 @@ static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing space, tab, newline, carriage return, - * ethiopic wordspace (U+1361), ogham space mark (U+1680), and ideographic - * space (U+3000). [TIP #318] + * UTF-8 literal string containing all Unicode space characters [TIP #413] */ -#define DEFAULT_TRIM_SET " \t\n\r\xe1\x8d\xa1\xe1\x9a\x80\xe3\x80\x80" +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ /* *---------------------------------------------------------------------- @@ -204,8 +227,8 @@ Tcl_RegexpObjCmd( */ if (doinline && ((objc - 2) != 0)) { - Tcl_AppendResult(interp, "regexp match variables not allowed" - " when using -inline", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "regexp match variables not allowed when using -inline", -1)); goto optionError; } @@ -1839,8 +1862,8 @@ StringMapCmd( strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; @@ -2106,8 +2129,8 @@ StringMatchCmd( strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; @@ -2567,8 +2590,9 @@ StringEqualCmd( return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, NULL); return TCL_ERROR; @@ -2716,8 +2740,9 @@ StringCmpCmd( return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, NULL); return TCL_ERROR; @@ -3302,14 +3327,14 @@ TclInitStringCmd( {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, - {"first", StringFirstCmd, NULL, NULL, NULL, 0}, + {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, {"is", StringIsCmd, NULL, NULL, NULL, 0}, - {"last", StringLastCmd, NULL, NULL, NULL, 0}, + {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, - {"map", StringMapCmd, NULL, NULL, NULL, 0}, + {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, - {"range", StringRangeCmd, NULL, NULL, NULL, 0}, + {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, {"repeat", StringReptCmd, NULL, NULL, NULL, 0}, {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, {"reverse", StringRevCmd, NULL, NULL, NULL, 0}, @@ -3515,9 +3540,9 @@ TclNRSwitchObjCmd( * Mode already set via -exact, -glob, or -regexp. */ - Tcl_AppendResult(interp, "bad option \"", - TclGetString(objv[i]), "\": ", options[mode], - " option already found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": %s option already found", + TclGetString(objv[i]), options[mode])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "DOUBLEOPT", NULL); return TCL_ERROR; @@ -3534,8 +3559,9 @@ TclNRSwitchObjCmd( case OPT_INDEXV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-indexvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-indexvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "NOVAR", NULL); return TCL_ERROR; @@ -3546,8 +3572,9 @@ TclNRSwitchObjCmd( case OPT_MATCHV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-matchvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-matchvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "NOVAR", NULL); return TCL_ERROR; @@ -3565,15 +3592,15 @@ TclNRSwitchObjCmd( return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-indexvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-indexvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-matchvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-matchvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "MODERESTRICTION", NULL); return TCL_ERROR; @@ -3622,7 +3649,8 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra switch pattern with no body", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", NULL); @@ -3637,10 +3665,10 @@ TclNRSwitchObjCmd( if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { - Tcl_AppendResult(interp, ", this may be due to a " - "comment incorrectly placed outside of a " - "switch body - see the \"switch\" " - "documentation", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + ", this may be due to a comment incorrectly" + " placed outside of a switch body - see the" + " \"switch\" documentation", -1); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", "COMMENT?", NULL); break; @@ -3657,9 +3685,9 @@ TclNRSwitchObjCmd( */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "no body specified for pattern \"", - TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no body specified for pattern \"%s\"", + TclGetString(objv[objc-2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", "FALLTHROUGH", NULL); return TCL_ERROR; @@ -3985,7 +4013,8 @@ Tcl_ThrowObjCmd( if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { - Tcl_AppendResult(interp, "type must be non-empty list", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "type must be non-empty list", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", NULL); return TCL_ERROR; @@ -4169,15 +4198,16 @@ TclNRTryObjCmd( switch ((enum Handlers) type) { case TryFinally: /* finally script */ if (i < objc-2) { - Tcl_AppendResult(interp, "finally clause must be last", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "finally clause must be last", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", "NONTERMINAL", NULL); 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_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to finally clause: must be" + " \"... finally script\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", "ARGUMENT", NULL); @@ -4188,15 +4218,16 @@ TclNRTryObjCmd( 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_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to on clause: must be \"... on code" + " variableList script\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", "ARGUMENT", NULL); return TCL_ERROR; } - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { + if (TclGetCompletionCodeFromObj(interp, objv[i+1], + &code) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4205,9 +4236,10 @@ TclNRTryObjCmd( case TryTrap: /* trap pattern variableList script */ if (i > objc-4) { - Tcl_AppendResult(interp, "wrong # args to trap clause: ", + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to trap clause: " "must be \"... trap pattern variableList script\"", - NULL); + -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "ARGUMENT", NULL); @@ -4248,9 +4280,8 @@ TclNRTryObjCmd( } } if (bodyShared) { - Tcl_AppendResult(interp, - "last non-finally clause must not have a body of \"-\"", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "last non-finally clause must not have a body of \"-\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", NULL); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3540716..160fa3c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Prototypes for procedures defined later in this file: @@ -40,6 +41,13 @@ static int PushVarName(Tcl_Interp *interp, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); +static int CompileEachloopCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + CompileEnv *envPtr, int collect); +static int CompileDictEachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr, int collect); + /* * Macro that encapsulates an efficiency trick that avoids a function call for @@ -218,6 +226,245 @@ TclCompileAppendCmd( /* *---------------------------------------------------------------------- * + * TclCompileArray*Cmd -- + * + * Functions called to compile "array" sucommands. + * + * Results: + * All return TCL_OK for a successful compile, and TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "array" subcommand at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileArrayExistsCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + int simpleVarName, isScalar, localIndex; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + } else { + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + } + return TCL_OK; +} + +int +TclCompileArraySetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + int simpleVarName, isScalar, localIndex; + int dataVar, iterVar, keyVar, valVar, infoIndex; + int back, fwd, offsetBack, offsetFwd, savedStackDepth; + ForeachInfo *infoPtr; + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Special case: literal empty value argument is just an "ensure array" + * operation. + */ + + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) { + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); + TclEmitInstInt1(INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + PushLiteral(envPtr, "", 0); + return TCL_OK; + } + + /* + * Prepare for the internal foreach. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr->numLists = 1; + infoPtr->firstValueTemp = dataVar; + infoPtr->loopCtTemp = iterVar; + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0]->numVars = 2; + infoPtr->varLists[0]->varIndexes[0] = keyVar; + infoPtr->varLists[0]->varIndexes[1] = valVar; + infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + + /* + * Start issuing instructions to write to the array. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_BITAND, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + PushLiteral(envPtr, "list must have an even number of elements", + strlen("list must have an even number of elements")); + PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", + strlen("-errorCode {TCL ARGUMENT FORMAT}")); + TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr); + TclEmitInt4( 0, envPtr); + envPtr->currStackDepth = savedStackDepth; + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + back = offsetBack - CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, back, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + envPtr->currStackDepth = savedStackDepth; + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitOpcode( INST_DUP, envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + back = offsetBack - CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, back, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( dataVar, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +int +TclCompileArrayUnsetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int simpleVarName, isScalar, localIndex, savedStackDepth; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); + TclEmitInt4( localIndex, envPtr); + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); + TclEmitInstInt1(INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. @@ -251,6 +498,7 @@ TclCompileBreakCmd( */ TclEmitOpcode(INST_BREAK, envPtr); + PushLiteral(envPtr, "", 0); /* Evil hack! */ return TCL_OK; } @@ -557,6 +805,7 @@ TclCompileContinueCmd( */ TclEmitOpcode(INST_CONTINUE, envPtr); + PushLiteral(envPtr, "", 0); /* Evil hack! */ return TCL_OK; } @@ -575,25 +824,6 @@ TclCompileContinueCmd( * Instructions are added to envPtr to execute the "dict" subcommand at * runtime. * - * Notes: - * The following commands are in fairly common use and are possibly worth - * bytecoding: - * dict append - * dict create [*] - * dict exists [*] - * dict for - * dict get [*] - * dict incr - * dict keys [*] - * dict lappend - * dict set - * dict unset - * - * In practice, those that are pure-value operators (marked with [*]) can - * probably be left alone (except perhaps [dict get] which is very very - * common) and [dict update] should be considered instead (really big - * win!) - * *---------------------------------------------------------------------- */ @@ -658,6 +888,7 @@ TclCompileDictSetCmd( TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -775,6 +1006,310 @@ TclCompileDictGetCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclAdjustStackDepth(-1, envPtr); + return TCL_OK; +} + +int +TclCompileDictExistsCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int numWords, i; + DefineLineInformation; /* TIP #280 */ + + /* + * There must be at least two arguments after the command (the single-arg + * case is legal, but too special and magic for us to deal with here). + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + numWords = parsePtr->numWords-1; + + /* + * Now we do the code generation. + */ + + for (i=0 ; i<numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclAdjustStackDepth(-1, envPtr); + return TCL_OK; +} + +int +TclCompileDictUnsetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int i, dictVarIndex, nameChars; + const char *name; + + /* + * There must be at least one argument after the variable name for us to + * compile to bytecode. + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + /* + * The dictionary variable must be a local scalar that is knowable at + * compile time; anything else exceeds the complexity of the opcode. So + * discover what the index is. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = tokenPtr[1].start; + nameChars = tokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + if (dictVarIndex < 0) { + return TCL_ERROR; + } + + /* + * Remaining words (the key path) can be handled normally. + */ + + for (i=2 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + + /* + * Now emit the instruction to do the dict manipulation. + */ + + TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); + TclEmitInt4( dictVarIndex, envPtr); + return TCL_OK; +} + +int +TclCompileDictCreateCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + int worker; /* Temp var for building the value in. */ + Tcl_Token *tokenPtr; + Tcl_Obj *keyObj, *valueObj, *dictObj; + const char *bytes; + int i, len; + + if ((parsePtr->numWords & 1) == 0) { + return TCL_ERROR; + } + + /* + * See if we can build the value at compile time... + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + dictObj = Tcl_NewObj(); + Tcl_IncrRefCount(dictObj); + for (i=1 ; i<parsePtr->numWords ; i+=2) { + keyObj = Tcl_NewObj(); + Tcl_IncrRefCount(keyObj); + if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(dictObj); + goto nonConstant; + } + tokenPtr = TokenAfter(tokenPtr); + valueObj = Tcl_NewObj(); + Tcl_IncrRefCount(valueObj); + if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(valueObj); + Tcl_DecrRefCount(dictObj); + goto nonConstant; + } + tokenPtr = TokenAfter(tokenPtr); + Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(valueObj); + } + + /* + * We did! Excellent. The "verifyDict" is to do type forcing. + */ + + bytes = Tcl_GetStringFromObj(dictObj, &len); + PushLiteral(envPtr, bytes, len); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DICT_VERIFY, envPtr); + Tcl_DecrRefCount(dictObj); + return TCL_OK; + + /* + * Otherwise, we've got to issue runtime code to do the building, which we + * do by [dict set]ting into an unnamed local variable. This requires that + * we are in a context with an LVT. + */ + + nonConstant: + worker = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (worker < 0) { + return TCL_ERROR; + } + + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, worker, envPtr); + TclEmitOpcode( INST_POP, envPtr); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=1 ; i<parsePtr->numWords ; i+=2) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i+1); + tokenPtr = TokenAfter(tokenPtr); + TclEmitInstInt4( INST_DICT_SET, 1, envPtr); + TclEmitInt4( worker, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( worker, envPtr); + return TCL_OK; +} + +int +TclCompileDictMergeCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + int i, workerIndex, infoIndex, outLoop; + + /* + * Deal with some special edge cases. Note that in the case with one + * argument, the only thing to do is to verify the dict-ness. + */ + + if (parsePtr->numWords < 2) { + PushLiteral(envPtr, "", 0); + return TCL_OK; + } else if (parsePtr->numWords == 2) { + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DICT_VERIFY, envPtr); + return TCL_OK; + } + + /* + * There's real merging work to do. + * + * Allocate some working space. This means we'll only ever compile this + * command when there's an LVT present. + */ + + workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (workerIndex < 0) { + return TCL_ERROR; + } + infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + /* + * Get the first dictionary and verify that it is so. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DICT_VERIFY, envPtr); + Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * For each of the remaining dictionaries... + */ + + outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); + ExceptionRangeStarts(envPtr, outLoop); + for (i=2 ; i<parsePtr->numWords ; i++) { + /* + * Get the dictionary, and merge its pairs into the first dict (using + * a small loop). + */ + + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_SET, 1, envPtr); + TclEmitInt4( workerIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + } + ExceptionRangeEnds(envPtr, outLoop); + TclEmitOpcode( INST_END_CATCH, envPtr); + + /* + * Clean up any state left over. + */ + + Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( workerIndex, envPtr); + TclEmitInstInt1( INST_JUMP1, 18, envPtr); + + /* + * If an exception happens when starting to iterate over the second (and + * subsequent) dicts. This is strictly not necessary, but it is nice. + */ + + ExceptionRangeTarget(envPtr, outLoop, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( workerIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); + return TCL_OK; } @@ -787,11 +1322,42 @@ TclCompileDictForCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_KEEP_NONE); +} + +int +TclCompileDictMapCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); +} + +int +CompileDictEachCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Flag == TCL_EACH_COLLECT to collect and + * construct a new dictionary with the loop + * body result. */ +{ DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; int numVars, endTargetOffset; + int collectVar = -1; /* Index of temp var holding the result + * dict. */ int savedStackDepth = envPtr->currStackDepth; /* Needed because jumps confuse the stack * space calculator. */ @@ -815,6 +1381,19 @@ TclCompileDictForCmd( } /* + * Create temporary variable to capture return values from loop body when + * we're collecting results. + */ + + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; + } + } + + /* * Check we've got a pair of variables and that they are local variables. * Then extract their indices in the LVT. */ @@ -867,8 +1446,18 @@ TclCompileDictForCmd( * Preparation complete; issue instructions. Note that this code issues * fixed-sized jumps. That simplifies things a lot! * - * First up, get the dictionary and start the iteration. No catching of - * errors at this point. + * First up, initialize the accumulator dictionary if needed. + */ + + if (collect == TCL_EACH_COLLECT) { + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* + * Get the dictionary and start the iteration. No catching of errors at + * this point. */ CompileWord(envPtr, dictTokenPtr, interp, 3); @@ -908,6 +1497,14 @@ TclCompileDictForCmd( SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_DICT_SET, 1, envPtr); + TclEmitInt4( collectVar, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } TclEmitOpcode( INST_POP, envPtr); /* @@ -940,7 +1537,7 @@ TclCompileDictForCmd( ExceptionRangeTarget(envPtr, loopRange, breakOffset); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP4, 0, envPtr); @@ -954,8 +1551,12 @@ TclCompileDictForCmd( TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } TclEmitOpcode( INST_RETURN_STK, envPtr); /* @@ -964,25 +1565,31 @@ TclCompileDictForCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - envPtr->currStackDepth = savedStackDepth+2; + envPtr->currStackDepth = savedStackDepth + 2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty - * object. This is done last to promote peephole optimization when it's - * dropped immediately. + * object (or push the accumulator as the result object). This is done + * last to promote peephole optimization when it's dropped immediately. */ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); - PushLiteral(envPtr, "", 0); + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } return TCL_OK; } @@ -1154,6 +1761,7 @@ TclCompileDictUpdateCmd( (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1402,6 +2010,7 @@ TclCompileDictWithCmd( PushLiteral(envPtr, "", 0); } } + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1520,6 +2129,7 @@ TclCompileDictWithCmd( * Prepare for the start of the next command. */ + envPtr->currStackDepth = savedStackDepth + 1; if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); @@ -1619,6 +2229,7 @@ TclCompileErrorCmd( * However, we only deal with the case where there is just a message. */ Tcl_Token *messageTokenPtr; + int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { @@ -1629,6 +2240,7 @@ TclCompileErrorCmd( PushLiteral(envPtr, "-code error -level 0", 20); CompileWord(envPtr, messageTokenPtr, interp, 1); TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1870,6 +2482,39 @@ TclCompileForeachCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_KEEP_NONE); +} + +/* + *---------------------------------------------------------------------- + * + * CompileEachloopCmd -- + * + * Procedure called to compile the "foreach" and "lmap" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileEachloopCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Select collecting or accumulating mode + * (TCL_EACH_*) */ +{ Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData @@ -1878,6 +2523,9 @@ TclCompileForeachCmd( * used to point to a value list. */ int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ + int collectVar = -1; /* Index of temp var holding the result var + * index. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; @@ -1993,6 +2641,14 @@ TclCompileForeachCmd( loopIndex++; } + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; + } + } + /* * We will compile the foreach command. Reserve (numLists + 1) temporary * variables: @@ -2069,6 +2725,16 @@ TclCompileForeachCmd( } /* + * Create temporary variable to capture return values from loop body. + */ + + if (collect == TCL_EACH_COLLECT) { + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* * Initialize the temporary var that holds the count of loop iterations. */ @@ -2092,6 +2758,10 @@ TclCompileForeachCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; + + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); + } TclEmitOpcode( INST_POP, envPtr); /* @@ -2142,11 +2812,18 @@ TclCompileForeachCmd( ExceptionRangeTarget(envPtr, range, breakOffset); /* - * The foreach command's result is an empty string. + * The command's result is an empty string if not collecting, or the + * list of results from evaluating the loop body. */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } envPtr->currStackDepth = savedStackDepth + 1; done: @@ -2307,6 +2984,226 @@ PrintForeachInfo( /* *---------------------------------------------------------------------- * + * TclCompileFormatCmd -- + * + * Procedure called to compile the "format" command. Handles cases that + * can be done as constants or simple string concatenation only. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "format" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileFormatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + Tcl_Obj **objv, *formatObj, *tmpObj; + char *bytes, *start; + int i, j, len; + + /* + * Don't handle any guaranteed-error cases. + */ + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + /* + * Check if the argument words are all compile-time-known literals; that's + * a case we can handle by compiling to a constant. + */ + + formatObj = Tcl_NewObj(); + Tcl_IncrRefCount(formatObj); + tokenPtr = TokenAfter(tokenPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } + + objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + objv[i] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[i]); + if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { + goto checkForStringConcatCase; + } + } + + /* + * Everything is a literal, so the result is constant too (or an error if + * the format is broken). Do the format now. + */ + + tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), + parsePtr->numWords-2, objv); + for (; --i>=0 ;) { + Tcl_DecrRefCount(objv[i]); + } + ckfree(objv); + Tcl_DecrRefCount(formatObj); + if (tmpObj == NULL) { + return TCL_ERROR; + } + + /* + * Not an error, always a constant result, so just push the result as a + * literal. Job done. + */ + + bytes = Tcl_GetStringFromObj(tmpObj, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(tmpObj); + return TCL_OK; + + checkForStringConcatCase: + /* + * See if we can generate a sequence of things to concatenate. This + * requires that all the % sequences be %s or %%, as everything else is + * sufficiently complex that we don't bother. + * + * First, get the state of the system relatively sensible (cleaning up + * after our attempt to spot a literal). + */ + + for (; --i>=0 ;) { + Tcl_DecrRefCount(objv[i]); + } + ckfree(objv); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(tokenPtr); + i = 0; + + /* + * Now scan through and check for non-%s and non-%% substitutions. + */ + + for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { + if (*bytes == '%') { + bytes++; + if (*bytes == 's') { + i++; + continue; + } else if (*bytes == '%') { + continue; + } + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } + } + + /* + * Check if the number of things to concatenate will fit in a byte. + */ + + if (i+2 != parsePtr->numWords || i > 125) { + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } + + /* + * Generate the pushes of the things to concatenate, a sequence of + * literals and compiled tokens (of which at least one is non-literal or + * we'd have the case in the first half of this function) which we will + * concatenate. + */ + + i = 0; /* The count of things to concat. */ + j = 2; /* The index into the argument tokens, for + * TIP#280 handling. */ + start = Tcl_GetString(formatObj); + /* The start of the currently-scanned literal + * in the format string. */ + tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal + * being built. */ + for (bytes = start ; *bytes ; bytes++) { + if (*bytes == '%') { + Tcl_AppendToObj(tmpObj, start, bytes - start); + if (*++bytes == '%') { + Tcl_AppendToObj(tmpObj, "%", 1); + } else { + char *b = Tcl_GetStringFromObj(tmpObj, &len); + + /* + * If there is a non-empty literal from the format string, + * push it and reset. + */ + + if (len > 0) { + PushLiteral(envPtr, b, len); + Tcl_DecrRefCount(tmpObj); + tmpObj = Tcl_NewObj(); + i++; + } + + /* + * Push the code to produce the string that would be + * substituted with %s, except we'll be concatenating + * directly. + */ + + CompileWord(envPtr, tokenPtr, interp, j); + tokenPtr = TokenAfter(tokenPtr); + j++; + i++; + } + start = bytes + 1; + } + } + + /* + * Handle the case of a trailing literal. + */ + + Tcl_AppendToObj(tmpObj, start, bytes - start); + bytes = Tcl_GetStringFromObj(tmpObj, &len); + if (len > 0) { + PushLiteral(envPtr, bytes, len); + i++; + } + Tcl_DecrRefCount(tmpObj); + Tcl_DecrRefCount(formatObj); + + if (i > 1) { + /* + * Do the concatenation, which produces the result. + */ + + TclEmitInstInt1(INST_CONCAT1, i, envPtr); + } else { + /* + * EVIL HACK! Force there to be a string representation in the case + * where there's just a "%s" in the format; case covered by the test + * format-20.1 (and it is horrible...) + */ + + TclEmitOpcode(INST_DUP, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitOpcode(INST_STR_EQ, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileGlobalCmd -- * * Procedure called to compile the "global" command. @@ -2817,22 +3714,105 @@ TclCompileIncrCmd( /* *---------------------------------------------------------------------- * - * TclCompileInfoExistsCmd -- + * TclCompileInfo*Cmd -- * - * Procedure called to compile the "info exists" subcommand. + * Procedures called to compile "info" subcommands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "info exists" - * subcommand at runtime. + * Instructions are added to envPtr to execute the "info" subcommand at + * runtime. * *---------------------------------------------------------------------- */ int +TclCompileInfoCommandsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + + /* + * We require one compile-time known argument for the case we can compile. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + goto notCompilable; + } + bytes = Tcl_GetString(objPtr); + + /* + * We require that the argument start with "::" and not have any of "*\[?" + * in it. (Theoretically, we should look in only the final component, but + * the difference is so slight given current naming practices.) + */ + + if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { + goto notCompilable; + } + Tcl_DecrRefCount(objPtr); + + /* + * Confirmed as a literal that will not frighten the horses. Compile. Note + * that the result needs to be list-ified. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_STR_LEN, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_LIST, 1, envPtr); + return TCL_OK; + + notCompilable: + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; +} + +int +TclCompileInfoCoroutineCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info coroutine] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + return TCL_OK; +} + +int TclCompileInfoExistsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -2883,6 +3863,118 @@ TclCompileInfoExistsCmd( return TCL_OK; } + +int +TclCompileInfoLevelCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info level] without arguments or with a single argument. + */ + + if (parsePtr->numWords == 1) { + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } else { + DefineLineInformation; /* TIP #280 */ + + /* + * Compile the argument, then add the instruction to convert it into a + * list of arguments. + */ + + SetLineInformation(1); + CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); + } + return TCL_OK; +} + +int +TclCompileInfoObjectClassCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectIsACmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * We only handle [info object isa object <somevalue>]. The first three + * words are compressed to a single token by the ensemble compilation + * engine. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 + || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Issue the code. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectNamespaceCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_NS, envPtr); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -3700,11 +4792,42 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * - * TclCompileNamespaceCmd -- + * TclCompileLmapCmd -- + * + * Procedure called to compile the "lmap" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lmap" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLmapCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileNamespace*Cmd -- * - * Procedure called to compile the "namespace" command; currently, only - * the subcommand "namespace upvar" is compiled to bytecodes, and then - * only inside a procedure(-like) context. + * Procedures called to compile the "namespace" command; currently, only + * the subcommands "namespace current" and "namespace upvar" are compiled + * to bytecodes, and the latter only inside a procedure(-like) context. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -3718,6 +4841,154 @@ TclCompileLsetCmd( */ int +TclCompileNamespaceCurrentCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [namespace current] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceCodeCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * The specification of [namespace code] is rather shocking, in that it is + * supposed to check if the argument is itself the result of [namespace + * code] and not apply itself in that case. Which is excessively cautious, + * but what the test suite checks for. + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 + && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { + /* + * Technically, we could just pass a literal '::namespace inscope ' + * term through, but that's something which really shouldn't be + * occurring as something that the user writes so we'll just punt it. + */ + + return TCL_ERROR; + } + + /* + * Now we can compile using the same strategy as [namespace code]'s normal + * implementation does internally. Note that we can't bind the namespace + * name directly here, because TclOO plays complex games with namespaces; + * the value needs to be determined at runtime for safety. + */ + + PushLiteral(envPtr, "::namespace", 11); + PushLiteral(envPtr, "inscope", 7); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST, 4, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceQualifiersCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + int off; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "0", 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + off = CurrentOffset(envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_SUB, envPtr); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_INDEX, envPtr); + PushLiteral(envPtr, ":", 1); + TclEmitOpcode( INST_STR_EQ, envPtr); + off = off - CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceTailCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + JumpFixup jumpFixup; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Take care; only add 2 to found index if the string was actually found. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + PushLiteral(envPtr, "0", 1); + TclEmitOpcode( INST_GE, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); + PushLiteral(envPtr, "2", 1); + TclEmitOpcode( INST_ADD, envPtr); + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + PushLiteral(envPtr, "end", 3); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int TclCompileNamespaceUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -3779,6 +5050,52 @@ TclCompileNamespaceUpvarCmd( PushLiteral(envPtr, "", 0); return TCL_OK; } + +int +TclCompileNamespaceWhichCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *opt; + int idx; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + idx = 1; + + /* + * If there's an option, check that it's "-command". We don't handle + * "-variable" (currently) and anything else is an error. + */ + + if (parsePtr->numWords == 3) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + opt = tokenPtr + 1; + if (opt->size < 2 || opt->size > 8 + || strncmp(opt->start, "-command", opt->size) != 0) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + idx++; + } + + /* + * Issue the bytecode. + */ + + CompileWord(envPtr, tokenPtr, interp, idx); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -3948,6 +5265,180 @@ TclCompileRegexpCmd( /* *---------------------------------------------------------------------- * + * TclCompileRegsubCmd -- + * + * Procedure called to compile the "regsub" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "regsub" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegsubCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + /* + * We only compile the case with [regsub -all] where the pattern is both + * known at compile time and simple (i.e., no RE metacharacters). That is, + * the pattern must be translatable into a glob like "*foo*" with no other + * glob metacharacters inside it; there must be some "foo" in there too. + * The substitution string must also be known at compile time and free of + * metacharacters ("\digit" and "&"). Finally, there must not be a + * variable mentioned in the [regsub] to write the result back to (because + * we can't get the count of substitutions that would be the result in + * that case). The key is that these are the conditions under which a + * [string map] could be used instead, in particular a [string map] of the + * form we can compile to bytecode. + * + * In short, we look for: + * + * regsub -all [--] simpleRE string simpleReplacement + * + * The only optional part is the "--", and no other options are handled. + */ + + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *stringTokenPtr; + Tcl_Obj *patternObj = NULL, *replacementObj = NULL; + Tcl_DString pattern; + const char *bytes; + int len, exact, result = TCL_ERROR; + + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { + return TCL_ERROR; + } + + /* + * Parse the "-all", which must be the first argument (other options not + * supported, non-"-all" substitution we can't compile). + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 + || strncmp(tokenPtr[1].start, "-all", 4)) { + return TCL_ERROR; + } + + /* + * Get the pattern into patternObj, checking for "--" in the process. + */ + + Tcl_DStringInit(&pattern); + tokenPtr = TokenAfter(tokenPtr); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + if (Tcl_GetString(patternObj)[0] == '-') { + if (strcmp(Tcl_GetString(patternObj), "--") != 0 + || parsePtr->numWords == 5) { + goto done; + } + tokenPtr = TokenAfter(tokenPtr); + Tcl_DecrRefCount(patternObj); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + } else if (parsePtr->numWords == 6) { + goto done; + } + + /* + * Identify the code which produces the string to apply the substitution + * to (stringTokenPtr), and the replacement string (into replacementObj). + */ + + stringTokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(stringTokenPtr); + replacementObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { + goto done; + } + + /* + * Next, higher-level checks. Is the RE a very simple glob? Is the + * replacement "simple"? + */ + + bytes = Tcl_GetStringFromObj(patternObj, &len); + if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + goto done; + } + bytes = Tcl_DStringValue(&pattern); + if (*bytes++ != '*') { + goto done; + } + while (1) { + switch (*bytes) { + case '*': + if (bytes[1] == '\0') { + /* + * OK, we've proved there are no metacharacters except for the + * '*' at each end. + */ + + len = Tcl_DStringLength(&pattern) - 2; + if (len > 0) { + goto isSimpleGlob; + } + + /* + * The pattern is "**"! I believe that should be impossible, + * but we definitely can't handle that at all. + */ + } + case '\0': case '?': case '[': case '\\': + goto done; + } + bytes++; + } + isSimpleGlob: + for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + switch (*bytes) { + case '\\': case '&': + goto done; + } + } + + /* + * Proved the simplicity constraints! Time to issue the code. + */ + + result = TCL_OK; + bytes = Tcl_DStringValue(&pattern) + 1; + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + TclEmitOpcode( INST_STR_MAP, envPtr); + + done: + Tcl_DStringFree(&pattern); + if (patternObj) { + Tcl_DecrRefCount(patternObj); + } + if (replacementObj) { + Tcl_DecrRefCount(replacementObj); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. @@ -3980,6 +5471,7 @@ TclCompileReturnCmd( int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; + int savedStackDepth = envPtr->currStackDepth; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ @@ -4002,6 +5494,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -4426,6 +5919,69 @@ IndexTailVarIfKnown( return localIndex; } +int +TclCompileObjectSelfCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * We only handle [self] and [self object] (which is the same operation). + * These are the only very common operations on [self] for which + * bytecoding is at all reasonable. + */ + + if (parsePtr->numWords == 1) { + goto compileSelfObject; + } else if (parsePtr->numWords == 2) { + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { + return TCL_ERROR; + } + + subcmd = tokenPtr + 1; + if (strncmp(subcmd->start, "object", subcmd->size) == 0) { + goto compileSelfObject; + } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { + goto compileSelfNamespace; + } + } + + /* + * Can't compile; handle with runtime call. + */ + + return TCL_ERROR; + + compileSelfObject: + + /* + * This delegates the entire problem to a single opcode. + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + return TCL_OK; + + compileSelfNamespace: + + /* + * This is formally only correct with TclOO methods as they are currently + * implemented; it assumes that the current namespace is invariably when a + * TclOO context is present is the object's namespace, and that's + * technically only something that's a matter of current policy. But it + * avoids creating another opcode, so that's all good! + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8ed3a95..be63e0e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -133,6 +133,8 @@ const AuxDataType tclJumptableInfoType = { #define OP(name) TclEmitOpcode(INST_##name, envPtr) #define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) #define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) +#define OP14(name,val1,val2) \ + TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ @@ -249,18 +251,18 @@ TclCompileSetCmd( /* *---------------------------------------------------------------------- * - * TclCompileStringCmpCmd -- + * TclCompileString*Cmd -- * - * Procedure called to compile the simplest and most common form of the - * "string compare" command. + * Procedures called to compile various subcommands of the "string" + * command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "string compare" - * command at runtime. + * Instructions are added to envPtr to execute the "string" command at + * runtime. * *---------------------------------------------------------------------- */ @@ -296,25 +298,6 @@ TclCompileStringCmpCmd( TclEmitOpcode(INST_STR_CMP, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringEqualCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string equal" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string equal" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringEqualCmd( @@ -347,25 +330,70 @@ TclCompileStringEqualCmd( TclEmitOpcode(INST_STR_EQ, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringIndexCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string index" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string index" command - * at runtime. - * - *---------------------------------------------------------------------- - */ + +int +TclCompileStringFirstCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + OP(STR_FIND); + return TCL_OK; +} + +int +TclCompileStringLastCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + OP(STR_FIND_LAST); + return TCL_OK; +} int TclCompileStringIndexCmd( @@ -394,25 +422,6 @@ TclCompileStringIndexCmd( TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringMatchCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string match" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string match" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringMatchCmd( @@ -494,25 +503,6 @@ TclCompileStringMatchCmd( } return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringLenCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string length" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string length" - * command at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringLenCmd( @@ -553,6 +543,158 @@ TclCompileStringLenCmd( TclDecrRefCount(objPtr); return TCL_OK; } + +int +TclCompileStringMapCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *mapTokenPtr, *stringTokenPtr; + Tcl_Obj *mapObj, **objv; + char *bytes; + int len; + + /* + * We only handle the case: + * + * string map {foo bar} $thing + * + * That is, a literal two-element list (doesn't need to be brace-quoted, + * but does need to be compile-time knowable) and any old argument (the + * thing to map). + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + mapTokenPtr = TokenAfter(parsePtr->tokenPtr); + stringTokenPtr = TokenAfter(mapTokenPtr); + mapObj = Tcl_NewObj(); + Tcl_IncrRefCount(mapObj); + if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } else if (len != 2) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } + + /* + * Now issue the opcodes. Note that in the case that we know that the + * first word is an empty word, we don't issue the map at all. That is the + * correct semantics for mapping. + */ + + bytes = Tcl_GetStringFromObj(objv[0], &len); + if (len == 0) { + CompileWord(envPtr, stringTokenPtr, interp, 2); + } else { + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(objv[1], &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, 2); + OP(STR_MAP); + } + Tcl_DecrRefCount(mapObj); + return TCL_OK; +} + +int +TclCompileStringRangeCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; + Tcl_Obj *tmpObj; + int idx1, idx2, result; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + stringTokenPtr = TokenAfter(parsePtr->tokenPtr); + fromTokenPtr = TokenAfter(stringTokenPtr); + toTokenPtr = TokenAfter(fromTokenPtr); + + /* + * Parse the first index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tmpObj = Tcl_NewObj(); + result = TCL_ERROR; + if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { + if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { + if (idx1 >= 0) { + result = TCL_OK; + } + } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { + if (idx1 <= -2) { + result = TCL_OK; + } + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + goto nonConstantIndices; + } + + /* + * Parse the second index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tmpObj = Tcl_NewObj(); + result = TCL_ERROR; + if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { + if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { + if (idx2 >= 0) { + result = TCL_OK; + } + } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { + if (idx2 <= -2) { + result = TCL_OK; + } + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + goto nonConstantIndices; + } + + /* + * Push the operand onto the stack and then the substring operation. + */ + + CompileWord(envPtr, stringTokenPtr, interp, 1); + OP44( STR_RANGE_IMM, idx1, idx2); + return TCL_OK; + + /* + * Push the operands onto the stack and then the substring operation. + */ + + nonConstantIndices: + CompileWord(envPtr, stringTokenPtr, interp, 1); + CompileWord(envPtr, fromTokenPtr, interp, 2); + CompileWord(envPtr, toTokenPtr, interp, 3); + OP( STR_RANGE); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -697,11 +839,11 @@ TclSubstCompile( } while (count > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + OP1( CONCAT1, 255); count -= 254; } if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); + OP1( CONCAT1, count); count = 1; } @@ -722,7 +864,7 @@ TclSubstCompile( envPtr->line = bline; catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr); + OP4( BEGIN_CATCH4, catchRange); ExceptionRangeStarts(envPtr, catchRange); switch (tokenPtr->type) { @@ -743,20 +885,20 @@ TclSubstCompile( ExceptionRangeEnds(envPtr, catchRange); /* Substitution produced TCL_OK */ - TclEmitOpcode(INST_END_CATCH, envPtr); + OP( END_CATCH); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); /* Exceptional return codes processed here */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - TclEmitOpcode(INST_END_CATCH, envPtr); - TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( RETURN_CODE_BRANCH); /* ERROR -> reraise it */ - TclEmitOpcode(INST_RETURN_STK, envPtr); - TclEmitOpcode(INST_NOP, envPtr); + OP( RETURN_STK); + OP( NOP); /* RETURN */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); @@ -775,14 +917,14 @@ TclSubstCompile( Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } - TclEmitOpcode(INST_POP, envPtr); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); + OP( POP); breakJump = CurrentOffset(envPtr) - breakOffset; if (breakJump > 127) { - TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr); + OP4(JUMP4, -breakJump); } else { - TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr); + OP1(JUMP1, -breakJump); } /* CONTINUE destination */ @@ -790,8 +932,8 @@ TclSubstCompile( Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } - TclEmitOpcode(INST_POP, envPtr); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); + OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); /* RETURN + other destination */ @@ -808,8 +950,8 @@ TclSubstCompile( * Pull the result to top of stack, discard options dict. */ - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_POP, envPtr); + OP4( REVERSE, 2); + OP( POP); /* * We've emitted several POP instructions, and the automatic @@ -828,7 +970,7 @@ TclSubstCompile( (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); + OP1(CONCAT1, count); count = 1; } @@ -840,13 +982,12 @@ TclSubstCompile( bline = envPtr->line; } - while (count > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + OP1( CONCAT1, 255); count -= 254; } if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); + OP1( CONCAT1, count); } Tcl_FreeParse(&parse); @@ -854,6 +995,7 @@ TclSubstCompile( if (state != NULL) { Tcl_RestoreInterpState(interp, state); TclCompileSyntaxError(interp, envPtr); + TclAdjustStackDepth(-1, envPtr); } /* Final target of the multi-jump from all BREAKs */ @@ -1277,14 +1419,14 @@ IssueSwitchChainedTests( switch (mode) { case Switch_Exact: - TclEmitOpcode(INST_DUP, envPtr); + OP( DUP); TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitOpcode(INST_STR_EQ, envPtr); + OP( STR_EQ); break; case Switch_Glob: TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + OP4( OVER, 1); + OP1( STR_MATCH, noCase); break; case Switch_Regexp: simple = exact = 0; @@ -1323,7 +1465,7 @@ IssueSwitchChainedTests( TclCompileTokens(interp, bodyToken[i], 1, envPtr); } - TclEmitInstInt4(INST_OVER, 1, envPtr); + OP4( OVER, 1); if (!simple) { /* * Pass correct RE compile flags. We use only Int1 @@ -1335,11 +1477,11 @@ IssueSwitchChainedTests( int cflags = TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + OP1(REGEXP, cflags); } else if (exact && !noCase) { - TclEmitOpcode(INST_STR_EQ, envPtr); + OP( STR_EQ); } else { - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + OP1(STR_MATCH, noCase); } break; default: @@ -1404,7 +1546,7 @@ IssueSwitchChainedTests( * pattern. */ - TclEmitOpcode(INST_POP, envPtr); + OP( POP); envPtr->currStackDepth = savedStackDepth + 1; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ @@ -1426,7 +1568,7 @@ IssueSwitchChainedTests( */ if (!foundDefault) { - TclEmitOpcode(INST_POP, envPtr); + OP( POP); PushLiteral(envPtr, "", 0); } @@ -1498,6 +1640,7 @@ IssueSwitchJumpTable( int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; + int savedStackDepth = envPtr->currStackDepth; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; @@ -1537,9 +1680,9 @@ IssueSwitchJumpTable( */ jumpLocation = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr); + OP4( JUMP_TABLE, infoIndex); jumpToDefault = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + OP4( JUMP4, 0); for (i=0 ; i<numBodyTokens ; i+=2) { /* @@ -1610,6 +1753,7 @@ IssueSwitchJumpTable( * Compile the body of the arm. */ + envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1630,7 +1774,7 @@ IssueSwitchJumpTable( * rewriting when we fixed this all up. */ - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + OP4( JUMP4, 0); } } @@ -1641,6 +1785,7 @@ IssueSwitchJumpTable( */ if (!foundDefault) { + envPtr->currStackDepth = savedStackDepth; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); PushLiteral(envPtr, "", 0); @@ -1661,6 +1806,7 @@ IssueSwitchJumpTable( */ TclStackFree(interp, finalFixups); + envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -1746,6 +1892,50 @@ PrintJumptableInfo( /* *---------------------------------------------------------------------- * + * TclCompileTailcallCmd -- + * + * Procedure called to compile the "tailcall" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "tailcall" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileTailcallCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 256 + || envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + for (i=1 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileThrowCmd -- * * Procedure called to compile the "throw" command. @@ -1772,6 +1962,7 @@ TclCompileThrowCmd( { DefineLineInformation; /* TIP #280 */ int numWords = parsePtr->numWords; + int savedStackDepth = envPtr->currStackDepth; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; @@ -1802,6 +1993,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); TclCompileSyntaxError(interp, envPtr); Tcl_DecrRefCount(objPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } if (len == 0) { @@ -1822,6 +2014,7 @@ TclCompileThrowCmd( PushLiteral(envPtr, string, len); TclDecrRefCount(dictPtr); OP44( RETURN_IMM, 1, 0); + envPtr->currStackDepth = savedStackDepth + 1; } else { /* * When the code token is not known at compilation time, we need to do @@ -1850,6 +2043,7 @@ TclCompileThrowCmd( PUSH( ""); OP44( RETURN_IMM, 1, 0); } + envPtr->currStackDepth = savedStackDepth + 1; TclDecrRefCount(objPtr); return TCL_OK; } @@ -2117,6 +2311,7 @@ IssueTryInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; + int savedStackDepth = envPtr->currStackDepth; int i, j, len, forwardsNeedFixing = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; @@ -2178,6 +2373,7 @@ IssueTryInstructions( LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); PUSH( TclGetString(matchClauses[i])); OP( STR_EQ); @@ -2218,6 +2414,7 @@ IssueTryInstructions( forwardsToFix[j] = -1; } } + envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); } @@ -2249,6 +2446,7 @@ IssueTryInstructions( } TclStackFree(interp, forwardsToFix); TclStackFree(interp, addrsToFix); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2285,6 +2483,7 @@ IssueTryFinallyInstructions( range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); + envPtr->currStackDepth = savedStackDepth; BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); PUSH( "0"); @@ -2329,6 +2528,7 @@ IssueTryFinallyInstructions( LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); PUSH( TclGetString(matchClauses[i])); OP( STR_EQ); @@ -2401,6 +2601,7 @@ IssueTryFinallyInstructions( } OP4( BEGIN_CATCH4, range); } + envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); OP( PUSH_RETURN_OPTIONS); @@ -2452,7 +2653,6 @@ IssueTryFinallyInstructions( */ OP( POP); - envPtr->currStackDepth = savedStackDepth; /* * Process the finally clause (at last!) Note that we do not wrap this in @@ -2462,11 +2662,13 @@ IssueTryFinallyInstructions( * next command (or some inter-command manipulation). */ + envPtr->currStackDepth = savedStackDepth; BODY( finallyToken, 3 + 4*numHandlers); OP( POP); LOAD( optionsVar); LOAD( resultVar); OP( RETURN_STK); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2547,20 +2749,18 @@ TclCompileUnsetCmd( */ if (!simpleVarName) { - TclEmitInstInt1( INST_UNSET_STK, flags, envPtr); + OP1( UNSET_STK, flags); } else if (isScalar) { if (localIndex < 0) { - TclEmitInstInt1(INST_UNSET_STK, flags, envPtr); + OP1( UNSET_STK, flags); } else { - TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr); - TclEmitInt4( localIndex, envPtr); + OP14( UNSET_SCALAR, flags, localIndex); } } else { if (localIndex < 0) { - TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr); + OP1( UNSET_ARRAY_STK, flags); } else { - TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr); - TclEmitInt4( localIndex, envPtr); + OP14( UNSET_ARRAY, flags, localIndex); } } @@ -2697,7 +2897,7 @@ TclCompileWhileCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); + OP( POP); /* * Compile the test expression then emit the conditional jump that @@ -2752,6 +2952,49 @@ TclCompileWhileCmd( /* *---------------------------------------------------------------------- * + * TclCompileYieldCmd -- + * + * Procedure called to compile the "yield" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "yield" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileYieldCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + if (parsePtr->numWords < 1 || parsePtr->numWords > 2) { + return TCL_ERROR; + } + + if (parsePtr->numWords == 1) { + PushLiteral(envPtr, "", 0); + } else { + DefineLineInformation; /* TIP #280 */ + Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, valueTokenPtr, interp, 1); + } + OP( YIELD); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * PushVarName -- * * Procedure used in the compiling where pushing a variable name is @@ -3074,7 +3317,7 @@ CompileAssociativeBinaryOpCmd( * calcuations, including roundoff errors. */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + OP4( REVERSE, words-1); } while (--words > 1) { TclEmitOpcode(instruction, envPtr); @@ -3165,31 +3408,19 @@ CompileComparisonOpCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } + STORE(tmpIndex); TclEmitOpcode(instruction, envPtr); for (words=3 ; words<parsePtr->numWords ;) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); - } + LOAD(tmpIndex); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } + STORE(tmpIndex); } TclEmitOpcode(instruction, envPtr); } for (; words>3 ; words--) { - TclEmitOpcode(INST_BITAND, envPtr); + OP( BITAND); } /* @@ -3197,13 +3428,7 @@ CompileComparisonOpCmd( * might be expensive elsewhere. */ - PushLiteral(envPtr, "", 0); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + OP14( UNSET_SCALAR, 0, tmpIndex); } return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d4ca284..309682d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -37,7 +37,7 @@ TCL_DECLARE_MUTEX(tableMutex) int tclTraceCompile = 0; static int traceInitialized = 0; #endif - + /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The @@ -372,13 +372,13 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ - {"upvar", 5, 0, 1, {OPERAND_LVT4}}, + {"upvar", 5, -1, 1, {OPERAND_LVT4}}, /* finds level and otherName in stack, links to local variable at * index op1. Leaves the level on stack. */ - {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, + {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ - {"variable", 5, 0, 1, {OPERAND_LVT4}}, + {"variable", 5, -1, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, @@ -434,6 +434,100 @@ InstructionDesc const tclInstructionTable[] = { /* Map variable contents back into a dictionary in the local variable * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ + {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top op4 words (min 1) are a key path into the dictionary just + * below the keys on the stack, and all those values are replaced by a + * boolean indicating whether it is possible to read out a value from + * that key-path (like [dict exists]). + * Stack: ... dict key1 ... keyN => ... boolean */ + {"verifyDict", 1, -1, 0, {OPERAND_NONE}}, + /* Verifies that the word on the top of the stack is a dictionary, + * popping it if it is and throwing an error if it is not. + * Stack: ... value => ... */ + + {"strmap", 1, -2, 0, {OPERAND_NONE}}, + /* Simplified version of [string map] that only applies one change + * string, and only case-sensitively. + * Stack: ... from to string => ... changedString */ + {"strfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the first index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ + {"strrfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the last index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ + {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, + /* String Range: push (string range stktop op4 op4) */ + {"strrange", 1, -2, 0, {OPERAND_NONE}}, + /* String Range with non-constant arguments. + * Stack: ... string idxA idxB => ... substring */ + + {"yield", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, and places the response back on top of the stack when it + * resumes. + * Stack: ... valueToYield => ... resumeValue */ + {"coroName", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current coroutine as an object + * on the stack. */ + {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Do a tailcall with the opnd items on the stack as the thing to + * tailcall to; opnd must be greater than 0 for the semantics to work + * right. */ + + {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current namespace as an object + * on the stack. */ + {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, + /* Push the stack depth (i.e., [info level]) of the interpreter as an + * object on the stack. */ + {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, + /* Push the argument words to a stack depth (i.e., [info level <n>]) + * of the interpreter as an object on the stack. + * Stack: ... depth => ... argList */ + {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Resolves the command named on the top of the stack to its fully + * qualified version, or produces the empty string if no such command + * exists. Never generates errors. + * Stack: ... cmdName => ... fullCmdName */ + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ + {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + /* Push the class of the TclOO object named at the top of the stack + * onto the stack. + * Stack: ... object => ... class */ + {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + /* Push the namespace of the TclOO object named at the top of the + * stack onto the stack. + * Stack: ... object => ... namespace */ + {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, + /* Push whether the value named at the top of the stack is a TclOO + * object (i.e., a boolean). Can corrupt the interpreter result + * despite not throwing, so not safe for use in a post-exception + * context. + * Stack: ... value => ... boolean */ + + {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, + /* Looks up the element on the top of the stack and tests whether it + * is an array. Pushes a boolean describing whether this is the + * case. Also runs the whole-array trace on the named variable, so can + * throw anything. + * Stack: ... varName => ... boolean */ + {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}}, + /* Looks up the variable indexed by opnd and tests whether it is an + * array. Pushes a boolean describing whether this is the case. Also + * runs the whole-array trace on the named variable, so can throw + * anything. + * Stack: ... => ... boolean */ + {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, + /* Forces the element on the top of the stack to be the name of an + * array. + * Stack: ... varName => ... */ + {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}}, + /* Forces the variable indexed by opnd to be an array. Does not touch + * the stack. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -1673,10 +1767,13 @@ TclCompileScript( && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; + int code, savedNumCmds = envPtr->numCommands; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int update = 0, code; + int update = 0; +#ifdef TCL_COMPILE_DEBUG + int startStackDepth = envPtr->currStackDepth; +#endif /* * Mark the start of the command; the proper bytecode @@ -1720,6 +1817,25 @@ TclCompileScript( envPtr); if (code == TCL_OK) { + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + +#ifdef TCL_COMPILE_DEBUG + int diff = envPtr->currStackDepth-startStackDepth; + + if (diff != 1 && (diff != 0 || + *(envPtr->codeNext-1) != INST_DONE)) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", + parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif if (update) { /* * Fix the bytecode length. @@ -4620,6 +4736,5 @@ RecordByteCodeStats( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ba78c36..3302f9b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -676,13 +676,43 @@ typedef struct ByteCode { #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 -/* For [dict with] compilation */ +/* For [dict with], [dict exists], [dict create] and [dict merge] */ #define INST_DICT_EXPAND 138 #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 +#define INST_DICT_EXISTS 141 +#define INST_DICT_VERIFY 142 + +/* For [string map] and [regsub] compilation */ +#define INST_STR_MAP 143 +#define INST_STR_FIND 144 +#define INST_STR_FIND_LAST 145 +#define INST_STR_RANGE_IMM 146 +#define INST_STR_RANGE 147 + +/* For operations to do with coroutines and other NRE-manipulators */ +#define INST_YIELD 148 +#define INST_COROUTINE_NAME 149 +#define INST_TAILCALL 150 + +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 151 +#define INST_INFO_LEVEL_NUM 152 +#define INST_INFO_LEVEL_ARGS 153 +#define INST_RESOLVE_COMMAND 154 +#define INST_TCLOO_SELF 155 +#define INST_TCLOO_CLASS 156 +#define INST_TCLOO_NS 157 +#define INST_TCLOO_IS_OBJECT 158 + +/* For compilation of [array] subcommands */ +#define INST_ARRAY_EXISTS_STK 159 +#define INST_ARRAY_EXISTS_IMM 160 +#define INST_ARRAY_MAKE_STK 161 +#define INST_ARRAY_MAKE_IMM 162 /* The last opcode */ -#define LAST_INST_OPCODE 140 +#define LAST_INST_OPCODE 162 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclConfig.c b/generic/tclConfig.c index dea487a..a4ba71a 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -236,7 +236,7 @@ QueryConfigObjCmd( * present. */ - Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", Tcl_GetString(pkgName), NULL); return TCL_ERROR; @@ -251,7 +251,7 @@ QueryConfigObjCmd( if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { - Tcl_SetResult(interp, "key not known", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", Tcl_GetString(objv[2]), NULL); return TCL_ERROR; @@ -270,8 +270,8 @@ QueryConfigObjCmd( listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { - Tcl_SetResult(interp, "insufficient memory to create list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to create list", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1e2a68b..2801102 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1807,8 +1807,12 @@ EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); +/* 630 */ +EXTERN void Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj); -typedef struct TclStubHooks { +typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -1816,7 +1820,7 @@ typedef struct TclStubHooks { typedef struct TclStubs { int magic; - const struct TclStubHooks *hooks; + const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ @@ -2472,6 +2476,7 @@ typedef struct TclStubs { int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ + void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ } TclStubs; #ifdef __cplusplus @@ -3764,6 +3769,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ +#define Tcl_ZlibStreamSetCompressionDictionary \ + (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ac2cb62..eb3625e 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -76,9 +76,12 @@ static int FinalizeDictWith(ClientData data[], Tcl_Interp *interp, int result); static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int DictForLoopCallback(ClientData data[], Tcl_Interp *interp, int result); - +static int DictMapLoopCallback(ClientData data[], + Tcl_Interp *interp, int result); /* * Table of dict subcommand names and implementations. @@ -86,8 +89,8 @@ static int DictForLoopCallback(ClientData data[], static const EnsembleImplMap implementationMap[] = { {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, - {"create", DictCreateCmd, NULL, NULL, NULL, 0 }, - {"exists", DictExistsCmd, NULL, NULL, NULL, 0 }, + {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, + {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, @@ -95,12 +98,13 @@ static const EnsembleImplMap implementationMap[] = { {"info", DictInfoCmd, NULL, NULL, NULL, 0 }, {"keys", DictKeysCmd, NULL, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, - {"merge", DictMergeCmd, NULL, NULL, NULL, 0 }, + {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, + {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 }, {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, {"size", DictSizeCmd, NULL, NULL, NULL, 0 }, - {"unset", DictUnsetCmd, NULL, NULL, NULL, 0 }, + {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, {"values", DictValuesCmd, NULL, NULL, NULL, 0 }, {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, @@ -181,6 +185,23 @@ static const Tcl_HashKeyType chainHashType = { AllocChainEntry, TclFreeObjEntry }; + +/* + * Structure used in implementation of 'dict map' to hold the state that gets + * passed between parts of the implementation. + */ + +typedef struct { + Tcl_Obj *keyVarObj; /* The name of the variable that will have + * keys assigned to it. */ + Tcl_Obj *valueVarObj; /* The name of the variable that will have + * values assigned to it. */ + Tcl_DictSearch search; /* The dictionary search structure. */ + Tcl_Obj *scriptObj; /* The script to evaluate each time through + * the loop. */ + Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the + * results. */ +} DictMapStorage; /***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/ @@ -700,7 +721,8 @@ SetDictFromAny( missingValue: if (interp != NULL) { - Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } result = TCL_ERROR; @@ -779,9 +801,9 @@ TclTraceDictPath( } if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(keyv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(keyv[i]), NULL); } @@ -953,6 +975,7 @@ Tcl_DictObjGet( if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { + *valuePtrPtr = NULL; return result; } } @@ -1571,9 +1594,9 @@ DictGetCmd( return result; } if (valuePtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(objv[objc-1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(objv[objc-1]), NULL); return TCL_ERROR; @@ -2027,6 +2050,7 @@ DictInfoCmd( { Tcl_Obj *dictPtr; Dict *dict; + char *statsStr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -2042,7 +2066,9 @@ DictInfoCmd( } dict = dictPtr->internalRep.otherValuePtr; - Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC); + statsStr = Tcl_HashStats(&dict->table); + Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); + ckfree(statsStr); return TCL_OK; } @@ -2331,7 +2357,7 @@ DictAppendCmd( * * DictForNRCmd -- * - * This function implements the "dict for" Tcl command. See the user + * These functions implement the "dict for" Tcl command. See the user * documentation for details on what it does, and TIP#111 for the formal * specification. * @@ -2371,8 +2397,8 @@ DictForNRCmd( return TCL_ERROR; } if (varc != 2) { - Tcl_SetResult(interp, "must have exactly two variable names", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2484,13 +2510,15 @@ DictForLoopCallback( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); result = TCL_ERROR; goto done; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; goto done; } @@ -2519,6 +2547,217 @@ DictForLoopCallback( /* *---------------------------------------------------------------------- * + * DictMapNRCmd -- + * + * These functions implement the "dict map" Tcl command. See the user + * documentation for details on what it does, and TIP#405 for the formal + * specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictMapNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj **varv, *keyObj, *valueObj; + DictMapStorage *storagePtr; + int varc, done; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "{keyVar valueVar} dictionary script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); + return TCL_ERROR; + } + storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); + if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, + &valueObj, &done) != TCL_OK) { + TclStackFree(interp, storagePtr); + return TCL_ERROR; + } + if (done) { + /* + * Note that this exit leaves an empty value in the result (due to + * command calling conventions) but that is OK since an empty value is + * an empty dictionary. + */ + + TclStackFree(interp, storagePtr); + return TCL_OK; + } + TclNewObj(storagePtr->accumulatorObj); + TclListObjGetElements(NULL, objv[1], &varc, &varv); + storagePtr->keyVarObj = varv[0]; + storagePtr->valueVarObj = varv[1]; + storagePtr->scriptObj = objv[3]; + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. Note that the dictionary internal rep is locked + * internally so that updates, shimmering, etc are not a problem. + */ + + Tcl_IncrRefCount(storagePtr->accumulatorObj); + Tcl_IncrRefCount(storagePtr->keyVarObj); + Tcl_IncrRefCount(storagePtr->valueVarObj); + Tcl_IncrRefCount(storagePtr->scriptObj); + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything on error. + */ + + error: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return TCL_ERROR; +} + +static int +DictMapLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + DictMapStorage *storagePtr = data[0]; + Tcl_Obj *keyObj, *valueObj; + int done; + + /* + * Process the result from the previous execution of the script body. + */ + + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"dict map\" body line %d)", + Tcl_GetErrorLine(interp))); + } + goto done; + } else { + keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL, + TCL_LEAVE_ERR_MSG); + if (keyObj == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj, + Tcl_GetObjResult(interp)); + } + + /* + * Get the next mapping from the dictionary. + */ + + Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done); + if (done) { + Tcl_SetObjResult(interp, storagePtr->accumulatorObj); + goto done; + } + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. + */ + + done: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * * DictSetCmd -- * * This function implements the "dict set" Tcl command. See the user @@ -2787,8 +3026,8 @@ DictFilterCmd( return TCL_ERROR; } if (varc != 2) { - Tcl_SetResult(interp, "must have exactly two variable names", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; @@ -2828,16 +3067,19 @@ DictFilterCmd( if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set key variable: \"%s\"", + TclGetString(keyVarObj))); result = TCL_ERROR; goto abnormalResult; } if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set value variable: \"%s\"", + TclGetString(valueVarObj))); + result = TCL_ERROR; goto abnormalResult; } @@ -3438,7 +3680,7 @@ TclInitDictCmd( { return TclMakeEnsemble(interp, "dict", implementationMap); } - + /* * Local Variables: * mode: c diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0fa6661..7a55724 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1542,7 +1542,8 @@ OpenEncodingFileChannel( } if ((NULL == chan) && (interp != NULL)) { - Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown encoding \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_DecrRefCount(fileNameObj); @@ -1616,7 +1617,8 @@ LoadEncodingFile( break; } if ((encoding == NULL) && (interp != NULL)) { - Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid encoding file \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_Close(NULL, chan); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 754e480..b76c603 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -17,6 +17,7 @@ * Declarations for functions local to this file: */ +static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); @@ -78,6 +79,19 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; +static inline Tcl_Obj * +NewNsObj( + Tcl_Namespace *namespacePtr) +{ + register Namespace *nsPtr = (Namespace *) namespacePtr; + + if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { + return Tcl_NewStringObj("::", 2); + } else { + return Tcl_NewStringObj(nsPtr->fullName, -1); + } +} + /* *---------------------------------------------------------------------- * @@ -116,9 +130,10 @@ TclNamespaceEnsembleCmd( if (nsPtr == NULL || nsPtr->flags & NS_DYING) { if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); } return TCL_ERROR; } @@ -235,9 +250,11 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } if (len < 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -250,7 +267,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); - Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); @@ -370,8 +387,7 @@ TclNamespaceEnsembleCmd( case CONF_NAMESPACE: namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_SetResult(interp, ((Namespace *) namespacePtr)->fullName, - TCL_VOLATILE); + Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); break; case CONF_PREFIX: { int flags = 0; /* silence gcc 4 warning */ @@ -411,9 +427,7 @@ TclNamespaceEnsembleCmd( -1)); namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(((Namespace *) namespacePtr)->fullName, - -1)); + Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); /* -parameters option */ Tcl_ListObjAppendElement(NULL, resultObj, @@ -515,9 +529,11 @@ TclNamespaceEnsembleCmd( goto freeMapAndError; } if (len < 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -527,8 +543,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_DuplicateObj(listObj); - Tcl_Obj *newCmd = - Tcl_NewStringObj(nsPtr->fullName, -1); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); @@ -554,7 +569,9 @@ TclNamespaceEnsembleCmd( continue; } case CONF_NAMESPACE: - Tcl_AppendResult(interp, "option -namespace is read-only", + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -namespace is read-only", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", NULL); goto freeMapAndError; case CONF_PREFIX: @@ -629,7 +646,7 @@ Tcl_CreateEnsemble( */ if (!(name[0] == ':' && name[1] == ':')) { - nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); + nameObj = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr == NULL) { Tcl_AppendStringsToObj(nameObj, name, NULL); } else { @@ -702,7 +719,9 @@ Tcl_SetEnsembleSubcommandList( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (subcmdList != NULL) { @@ -776,7 +795,9 @@ Tcl_SetEnsembleParameterList( int length; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (paramList == NULL) { @@ -850,7 +871,9 @@ Tcl_SetEnsembleMappingDict( Tcl_Obj *oldDict; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (mapDict != NULL) { @@ -873,9 +896,11 @@ Tcl_SetEnsembleMappingDict( } bytes = TclGetString(cmdObjPtr); if (bytes[0] != ':' || bytes[1] != ':') { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "UNQUALIFIED_TARGET", NULL); Tcl_DictObjDone(&search); return TCL_ERROR; } @@ -945,7 +970,9 @@ Tcl_SetEnsembleUnknownHandler( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (unknownList != NULL) { @@ -1009,7 +1036,9 @@ Tcl_SetEnsembleFlags( int wasCompiled; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -1084,7 +1113,9 @@ Tcl_GetEnsembleSubcommandList( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1124,7 +1155,9 @@ Tcl_GetEnsembleParameterList( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1164,7 +1197,9 @@ Tcl_GetEnsembleMappingDict( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1203,7 +1238,9 @@ Tcl_GetEnsembleUnknownHandler( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1242,7 +1279,9 @@ Tcl_GetEnsembleFlags( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1281,7 +1320,9 @@ Tcl_GetEnsembleNamespace( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1337,8 +1378,9 @@ Tcl_FindEnsemble( if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), - "\" is not an ensemble command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not an ensemble command", + TclGetString(cmdNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", TclGetString(cmdNameObj), NULL); } @@ -1591,6 +1633,7 @@ NsEnsembleImplementationCmdNR( * specified but not yet cached command * names. */ int reparseCount = 0; /* Number of reparses. */ + Tcl_Obj *errorObj; /* Used for building error messages. */ /* * Must recheck objc, since numParameters might have changed. Cf. test @@ -1631,8 +1674,9 @@ NsEnsembleImplementationCmdNR( */ if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, - "ensemble activated for deleted namespace", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble activated for deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); } return TCL_ERROR; } @@ -1880,35 +1924,34 @@ NsEnsembleImplementationCmdNR( */ Tcl_ResetResult(interp); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", TclGetString(objv[1+ensemblePtr->numParameters]), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown subcommand \"%s\": namespace %s does not" + " export any commands", TclGetString(objv[1+ensemblePtr->numParameters]), - "\": namespace ", ensemblePtr->nsPtr->fullName, - " does not export any commands", NULL); + ensemblePtr->nsPtr->fullName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "unknown ", - (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), - "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]), - "\": must be ", NULL); + errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), + TclGetString(objv[1+ensemblePtr->numParameters])); if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); } else { int i; for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { - Tcl_AppendResult(interp, - ensemblePtr->subcommandArrayPtr[i], ", ", NULL); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); + Tcl_AppendToObj(errorObj, ", ", 2); } - Tcl_AppendResult(interp, "or ", - ensemblePtr->subcommandArrayPtr[i], NULL); + Tcl_AppendPrintfToObj(errorObj, "or %s", + ensemblePtr->subcommandArrayPtr[i]); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); + Tcl_SetObjResult(interp, errorObj); return TCL_ERROR; } @@ -2034,7 +2077,6 @@ EnsembleUnknownCallback( { int paramc, i, result, prefixObjc; Tcl_Obj **paramv, *unknownCmd, *ensObj; - char buf[TCL_INTEGER_SPACE]; /* * Create the unknown command callback to determine what to do. @@ -2061,9 +2103,12 @@ EnsembleUnknownCallback( ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT; result = Tcl_EvalObjv(interp, paramc, paramv, 0); if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { - Tcl_SetResult(interp, - "unknown subcommand handler deleted its ensemble", - TCL_STATIC); + if (!Tcl_InterpDeleted(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler deleted its ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", + NULL); + } result = TCL_ERROR; } Tcl_Release(ensemblePtr); @@ -2112,26 +2157,26 @@ EnsembleUnknownCallback( if (!Tcl_InterpDeleted(interp)) { if (result != TCL_ERROR) { Tcl_ResetResult(interp); - Tcl_SetResult(interp, - "unknown subcommand handler returned bad code: ", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler returned bad code: ", -1)); switch (result) { case TCL_RETURN: - Tcl_AppendResult(interp, "return", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); break; case TCL_BREAK: - Tcl_AppendResult(interp, "break", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); break; case TCL_CONTINUE: - Tcl_AppendResult(interp, "continue", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); break; default: - sprintf(buf, "%d", result); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); } Tcl_AddErrorInfo(interp, "\n result of " "ensemble unknown subcommand handler: "); Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", + NULL); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); @@ -2392,7 +2437,7 @@ BuildEnsembleConfig( * the programmer's responsibility (or [::unknown] of course). */ - cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); } else { diff --git a/generic/tclEvent.c b/generic/tclEvent.c index e65862c..0b585b6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1416,7 +1416,7 @@ Tcl_VwaitObjCmd( } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); break; } } @@ -1426,8 +1426,9 @@ Tcl_VwaitObjCmd( if (!foundEvent) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't wait for variable \"", nameString, - "\": would wait forever", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't wait for variable \"%s\": would wait forever", + nameString)); Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); return TCL_ERROR; } @@ -1519,7 +1520,7 @@ Tcl_UpdateObjCmd( } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); return TCL_ERROR; } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..cf8f9e7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include "tclOOInt.h" #include "tommath.h" #include <math.h> @@ -2331,6 +2332,101 @@ TEBCresume( cleanup = 1; goto processExceptionReturn; + case INST_YIELD: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); + if (!corPtr) { + TRACE_APPEND(("ERROR: yield outside coroutine\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); + if (traceInstructions) { + fprintf(stdout, "\n"); + } +#endif + /* TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + + pc++; + cleanup = 1; + TEBC_YIELD(); + + Tcl_SetObjResult(interp, OBJ_AT_TOS); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + INT2PTR(0), NULL, NULL); + + return TCL_OK; + } + + case INST_TAILCALL: { + Tcl_Obj *listPtr, *nsObjPtr; + NRE_callback *tailcallPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { + TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + { + register int i; + + TRACE(("%d [", opnd)); + for (i=opnd-1 ; i>=0 ; i--) { + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); + if (i > 0) { + TRACE_APPEND((" ")); + } + } + TRACE_APPEND(("] => RETURN...")); + } +#endif + + /* + * Push the evaluation of the called command into the NR callback + * stack. + */ + + listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); + Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(nsObjPtr); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, + NULL, NULL); + + /* + * Unstitch ourselves and do a [return]. + */ + + tailcallPtr = TOP_CB(interp); + TOP_CB(interp) = tailcallPtr->nextPtr; + iPtr->varFramePtr->tailcallPtr = tailcallPtr; + result = TCL_RETURN; + cleanup = opnd; + goto processExceptionReturn; + } + case INST_DONE: if (tosPtr > initTosPtr) { /* @@ -3785,6 +3881,104 @@ TEBCresume( /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- + * Start of INST_ARRAY instructions. + */ + + case INST_ARRAY_EXISTS_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 0; + part1Ptr = NULL; + arrayPtr = NULL; + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doArrayExists; + case INST_ARRAY_EXISTS_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 1; + part1Ptr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, + /*createPart1*/0, /*createPart2*/0, &arrayPtr); + doArrayExists: + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + DECACHE_STACK_INFO(); + result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| + TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + } + if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + objResultPtr = TCONST(1); + } else { + objResultPtr = TCONST(0); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + case INST_ARRAY_MAKE_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 0; + part1Ptr = NULL; + arrayPtr = NULL; + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doArrayMake; + case INST_ARRAY_MAKE_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 1; + part1Ptr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + doArrayMake: + if (varPtr && !TclIsVarArray(varPtr)) { + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", + "variable isn't array", opnd); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + TRACE_APPEND(("ERROR: bad array ref: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, + TclGetVarNsPtr(varPtr)); +#ifdef TCL_COMPILE_DEBUG + TRACE_APPEND(("done\n")); + } else { + TRACE_APPEND(("nothing to do\n")); +#endif + } + NEXT_INST_V(pcAdjustment, cleanup, 0); + + /* + * End of INST_ARRAY instructions. + * ----------------------------------------------------------------- * Start of variable linking instructions. */ @@ -4045,6 +4239,136 @@ TEBCresume( /* * ----------------------------------------------------------------- + * Start of general introspector instructions. + */ + + case INST_NS_CURRENT: { + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + TclNewLiteralStringObj(objResultPtr, "::"); + } else { + TclNewStringObj(objResultPtr, currNsPtr->fullName, + strlen(currNsPtr->fullName)); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_COROUTINE_NAME: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TclNewObj(objResultPtr); + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, + objResultPtr); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_INFO_LEVEL_NUM: + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_INFO_LEVEL_ARGS: { + int level; + register CallFrame *framePtr = iPtr->varFramePtr; + register CallFrame *rootFramePtr = iPtr->rootFramePtr; + + valuePtr = OBJ_AT_TOS; + if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + TRACE(("%d => ", level)); + if (level <= 0) { + level += framePtr->level; + } + for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; + framePtr = framePtr->callerVarPtr) { + /* Empty loop body */ + } + if (framePtr == rootFramePtr) { + Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), + "\"", NULL); + TRACE_APPEND(("ERROR: bad level\n")); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + TclGetString(valuePtr), NULL); + goto gotError; + } + objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + case INST_RESOLVE_COMMAND: { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + + TclNewObj(objResultPtr); + if (cmd != NULL) { + Tcl_GetCommandFullName(interp, cmd, objResultPtr); + } + TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + } + case INST_TCLOO_SELF: { + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE(("=> ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "self may only be called from inside a method", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + goto gotError; + } + contextPtr = framePtr->clientData; + + /* + * Call out to get the name; it's expensive to compute but cached. + */ + + objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + { + Object *oPtr; + + case INST_TCLOO_IS_OBJECT: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + objResultPtr = TCONST(oPtr != NULL ? 1 : 0); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + case INST_TCLOO_CLASS: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + if (oPtr == NULL) { + TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + goto gotError; + } + objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + case INST_TCLOO_NS: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + if (oPtr == NULL) { + TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + goto gotError; + } + + /* + * TclOO objects *never* have the global namespace as their NS. + */ + + TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, + strlen(oPtr->namespacePtr->fullName)); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + } + + /* + * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ @@ -4592,6 +4916,179 @@ TEBCresume( O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); + case INST_STR_RANGE: + TRACE(("\"%.20s\" %s %s =>", + O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); + length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + goto gotError; + } + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= length) { + toIdx = length; + } + if (toIdx >= fromIdx) { + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(1, 3, 1); + + case INST_STR_RANGE_IMM: + valuePtr = OBJ_AT_TOS; + fromIdx = TclGetInt4AtPtr(pc+1); + toIdx = TclGetInt4AtPtr(pc+5); + length = Tcl_GetCharLength(valuePtr); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + + /* + * Adjust indices for end-based indexing. + */ + + if (fromIdx < -1) { + fromIdx += 1 + length; + if (fromIdx < 0) { + fromIdx = 0; + } + } else if (fromIdx >= length) { + fromIdx = length; + } + if (toIdx < -1) { + toIdx += 1 + length; + if (toIdx < 0) { + toIdx = 0; + } + } else if (toIdx >= length) { + toIdx = length - 1; + } + + /* + * Check if we can do a sane substring. + */ + + if (fromIdx <= toIdx) { + objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(9, 1, 1); + + { + Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; + int length3; + Tcl_Obj *value3Ptr; + + case INST_STR_MAP: + valuePtr = OBJ_AT_TOS; /* "Main" string. */ + value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ + value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ + if (value3Ptr == value2Ptr) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } else if (valuePtr == value2Ptr) { + objResultPtr = value3Ptr; + NEXT_INST_V(1, 3, 1); + } + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + if (length == 0) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + if (length2 > length || length2 == 0) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } else if (length2 == length) { + if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { + objResultPtr = valuePtr; + } else { + objResultPtr = value3Ptr; + } + NEXT_INST_V(1, 3, 1); + } + ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + + objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + p = ustring1; + end = ustring1 + length; + for (; ustring1 < end; ustring1++) { + if ((*ustring1 == *ustring2) && (length2==1 || + memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) + == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + } + } + if (p != ustring1) { + /* + * Put the rest of the unmapped chars onto result. + */ + + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + } + TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", + O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); + NEXT_INST_V(1, 3, 1); + + case INST_STR_FIND: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ + + match = -1; + if (length2 > 0 && length2 <= length) { + end = ustring1 + length - length2 + 1; + for (p=ustring1 ; p<end ; p++) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); + NEXT_INST_F(1, 2, 1); + + case INST_STR_FIND_LAST: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ + + match = -1; + if (length2 > 0 && length2 <= length) { + for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); + NEXT_INST_F(1, 2, 1); + } + case INST_STR_MATCH: nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ @@ -4896,8 +5393,8 @@ TEBCresume( case INST_RSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -4944,8 +5441,8 @@ TEBCresume( case INST_LSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -4967,9 +5464,8 @@ TEBCresume( * good place to draw the line. */ - Tcl_SetResult(interp, - "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", @@ -5649,41 +6145,73 @@ TEBCresume( Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; + case INST_DICT_VERIFY: + dictPtr = OBJ_AT_TOS; + TRACE(("=> ")); + if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { + TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", + O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("OK\n")); + NEXT_INST_F(1, 1, 0); + case INST_DICT_GET: + case INST_DICT_EXISTS: { + register Tcl_Interp *interp2 = interp; + opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); + if (*pc == INST_DICT_EXISTS) { + interp2 = NULL; + } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { + if (*pc == INST_DICT_EXISTS) { + goto dictNotExists; + } TRACE_WITH_OBJ(( - "%u => ERROR tracing dictionary path into \"%s\": ", - opnd, O2S(OBJ_AT_DEPTH(opnd))), + "ERROR tracing dictionary path into \"%s\": ", + O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); goto gotError; } } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { + if (*pc == INST_DICT_EXISTS) { + objResultPtr = TCONST(objResultPtr ? 1 : 0); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } if (objResultPtr) { TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); } DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); CACHE_STACK_INFO(); TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); } else { + if (*pc == INST_DICT_EXISTS) { + dictNotExists: + objResultPtr = TCONST(0); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } TRACE_WITH_OBJ(( "%u => ERROR reading leaf dictionary key \"%s\": ", opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); } goto gotError; + } case INST_DICT_SET: case INST_DICT_UNSET: @@ -6304,7 +6832,7 @@ TEBCresume( divideByZero: DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); CACHE_STACK_INFO(); goto gotError; @@ -6316,8 +6844,8 @@ TEBCresume( exponOfZero: DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "exponentiation of zero by negative power", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponentiation of zero by negative power", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); CACHE_STACK_INFO(); @@ -6693,7 +7221,8 @@ ExecuteExtendedBinaryMathOp( invalid = 0; } if (invalid) { - Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -6723,8 +7252,8 @@ ExecuteExtendedBinaryMathOp( * place to draw the line. */ - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } shift = (int)(*((const long *)ptr2)); @@ -7125,7 +7654,8 @@ ExecuteExtendedBinaryMathOp( */ if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -7363,7 +7893,8 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (big2.used > 1) { mp_clear(&big2); - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index a868fe3..33c1496 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -10,11 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #include "tclInt.h" #include "tclFileSystem.h" @@ -152,9 +147,9 @@ FileCopyRename( if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); - Tcl_AppendResult(interp, "error ", - (copyFlag ? "copying" : "renaming"), ": target \"", - TclGetString(target), "\" is not a directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error %s: target \"%s\" is not a directory", + (copyFlag?"copying":"renaming"), TclGetString(target))); result = TCL_ERROR; } else { /* @@ -304,8 +299,9 @@ TclFileMakeDirsCmd( done: if (errfile != NULL) { - Tcl_AppendResult(interp, "can't create directory \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create directory \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); result = TCL_ERROR; } if (split != NULL) { @@ -384,9 +380,9 @@ TclFileDeleteCmd( result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { - Tcl_AppendResult(interp, "error deleting \"", - TclGetString(objv[i]), "\": directory not empty", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting \"%s\": directory not empty", + TclGetString(objv[i]))); Tcl_PosixError(interp); goto done; } @@ -426,12 +422,13 @@ TclFileDeleteCmd( * We try to accomodate poor error results from our Tcl_FS calls. */ - Tcl_AppendResult(interp, "error deleting unknown file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting unknown file: %s", + Tcl_PosixError(interp))); } else { - Tcl_AppendResult(interp, "error deleting \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); } } @@ -540,17 +537,17 @@ CopyRenameOneFile( if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite file \"", - TclGetString(target), "\" with directory \"", - TclGetString(source), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't overwrite file \"%s\" with directory \"%s\"", + TclGetString(target), TclGetString(source))); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite directory \"", - TclGetString(target), "\" with file \"", - TclGetString(source), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't overwrite directory \"%s\" with file \"%s\"", + TclGetString(target), TclGetString(source))); goto done; } @@ -581,10 +578,10 @@ CopyRenameOneFile( } if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", - TclGetString(source), "\" to \"", TclGetString(target), - "\": trying to rename a volume or " - "move a directory into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error renaming \"%s\" to \"%s\": trying to rename a" + " volume or move a directory into itself", + TclGetString(source), TclGetString(target))); goto done; } else if (errno != EXDEV) { errfile = target; @@ -628,8 +625,9 @@ CopyRenameOneFile( * Actual file doesn't exist. */ - Tcl_AppendResult(interp, "error copying \"", TclGetString(source), - "\": the target of this link doesn't exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error copying \"%s\": the target of this link doesn't" + " exist", TclGetString(source))); goto done; } else { int counter = 0; @@ -764,23 +762,27 @@ CopyRenameOneFile( } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); errfile = NULL; } } done: if (errfile != NULL) { - Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"), - " \"", TclGetString(source), NULL); + Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"", + (copyFlag ? "copying" : "renaming"), TclGetString(source)); + if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL); + Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"", + TclGetString(target)); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL); + Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"", + TclGetString(errfile)); } } - Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL); + Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp)); + Tcl_SetObjResult(interp, errorMsg); } if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); @@ -983,9 +985,10 @@ TclFileAttrsCmd( * There was an error, probably that the filePtr is not * accepted by any filesystem */ - Tcl_AppendResult(interp, "could not read \"", - TclGetString(filePtr), "\": ", Tcl_PosixError(interp), - NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(filePtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1071,9 +1074,9 @@ TclFileAttrsCmd( Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), - "\", there are no file attributes in this filesystem.", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\", there are no file attributes in this" + " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } @@ -1098,9 +1101,9 @@ TclFileAttrsCmd( int i, index; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), - "\", there are no file attributes in this filesystem.", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\", there are no file attributes in this" + " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } @@ -1114,8 +1117,8 @@ TclFileAttrsCmd( TclFreeIntRep(objv[i]); } if (i + 1 == objc) { - Tcl_AppendResult(interp, "value for \"", - TclGetString(objv[i]), "\" missing", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", "NOVALUE", NULL); goto end; @@ -1224,9 +1227,9 @@ TclFileLinkCmd( */ if (errno == EEXIST) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": that path already" + " exists", TclGetString(objv[index]))); Tcl_PosixError(interp); } else if (errno == ENOENT) { /* @@ -1244,23 +1247,23 @@ TclFileLinkCmd( access = Tcl_FSAccess(dirPtr, F_OK); Tcl_DecrRefCount(dirPtr); if (access != 0) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": no such file" + " or directory", TclGetString(objv[index]))); Tcl_PosixError(interp); } else { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), "\": target \"", - TclGetString(objv[index+1]), "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": target \"%s\" " + "doesn't exist", TclGetString(objv[index]), + TclGetString(objv[index+1]))); errno = ENOENT; Tcl_PosixError(interp); } } else { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\" pointing to \"%s\": %s", + TclGetString(objv[index]), + TclGetString(objv[index+1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1275,9 +1278,9 @@ TclFileLinkCmd( contents = Tcl_FSLink(objv[index], NULL, 0); if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read link \"%s\": %s", + TclGetString(objv[index]), Tcl_PosixError(interp))); return TCL_ERROR; } } @@ -1332,8 +1335,9 @@ TclFileReadLinkCmd( contents = Tcl_FSLink(objv[1], NULL, 0); if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read link \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } Tcl_SetObjResult(interp, contents); @@ -1487,8 +1491,8 @@ TclFileTemporaryCmd( if (nameVarObj) { TclDecrRefCount(nameObj); } - Tcl_AppendResult(interp, "can't create temporary file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create temporary file: %s", Tcl_PosixError(interp))); return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); @@ -1499,7 +1503,7 @@ TclFileTemporaryCmd( return TCL_ERROR; } } - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index edb6581..5d4702b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -411,25 +411,28 @@ TclpGetNativePathType( * Paths that begin with / are absolute. */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - if (*path && (pathLen > 3) && (path[0] == '/') - && (path[1] == '/') && isdigit(UCHAR(path[2]))) { - path += 3; - while (isdigit(UCHAR(*path))) { - path++; - } - } -#endif if (path[0] == '/') { -#ifdef __CYGWIN__ + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) /* - * Check for Cygwin // network path prefix + * Check for "//" network path prefix */ - if (path[1] == '/') { - path++; + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } #endif if (driveNameLengthPtr != NULL) { @@ -437,7 +440,7 @@ TclpGetNativePathType( * We need this addition in case the QNX or Cygwin code was used. */ - *driveNameLengthPtr = (1 + path - origPath); + *driveNameLengthPtr = (path - origPath); } } else { type = TCL_PATH_RELATIVE; @@ -640,41 +643,43 @@ SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { int length; - const char *p, *elementStart; + const char *origPath = path, *elementStart; Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - - if ((path[0] == '/') && (path[1] == '/') - && isdigit(UCHAR(path[2]))) { /* INTL: digit */ - path += 3; - while (isdigit(UCHAR(*path))) { /* INTL: digit */ - path++; - } - } -#endif - - p = path; - if (*p == '/') { - Tcl_Obj *rootElt = Tcl_NewStringObj("/", 1); - p++; -#ifdef __CYGWIN__ + if (*path == '/') { + Tcl_Obj *rootElt; + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) /* - * Check for Cygwin // network path prefix + * Check for "//" network path prefix */ - if (*p == '/') { - Tcl_AppendToObj(rootElt, "/", 1); - p++; + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } #endif + rootElt = Tcl_NewStringObj(origPath, path - origPath); Tcl_ListObjAppendElement(NULL, result, rootElt); + while (*path == '/') { + ++path; + } } /* @@ -683,14 +688,14 @@ SplitUnixPath( */ for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; + elementStart = path; + while ((*path != '\0') && (*path != '/')) { + path++; } - length = p - elementStart; + length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != path)) { + if ((elementStart[0] == '~') && (elementStart != origPath)) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -698,7 +703,7 @@ SplitUnixPath( } Tcl_ListObjAppendElement(NULL, result, nextElt); } - if (*p++ == '\0') { + if (*path++ == '\0') { break; } } @@ -1174,9 +1179,10 @@ DoTildeSubst( dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment " - "variable to expand path", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment " + "variable to expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); } return NULL; } @@ -1185,8 +1191,9 @@ DoTildeSubst( } else if (TclpGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); } return NULL; } @@ -1329,9 +1336,9 @@ Tcl_GlobObjCmd( endOfForLoop: if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-tails\" must be used with either " - "\"-directory\" or \"-path\"", NULL); + "\"-directory\" or \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; @@ -1625,20 +1632,23 @@ Tcl_GlobObjCmd( } if (length == 0) { - Tcl_AppendResult(interp, "no files matched glob pattern", - (join || (objc == 1)) ? " \"" : "s \"", NULL); + Tcl_Obj *errorMsg = + Tcl_ObjPrintf("no files matched glob pattern%s \"", + (join || (objc == 1)) ? "" : "s"); + if (join) { - Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL); + Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); } else { const char *sep = ""; for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); - Tcl_AppendResult(interp, sep, string, NULL); + Tcl_AppendPrintfToObj(errorMsg, "%s%s", + sep, Tcl_GetString(objv[i])); sep = " "; } } - Tcl_AppendResult(interp, "\"", NULL); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", NULL); result = TCL_ERROR; @@ -1769,6 +1779,7 @@ TclGlob( if (c != '\0') { tail++; } + Tcl_DStringFree(&buffer); } else { tail = pattern; } @@ -2206,15 +2217,15 @@ DoGlob( closeBrace = p; break; } - Tcl_SetResult(interp, "unmatched open-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", NULL); return TCL_ERROR; } else if (*p == '}') { - Tcl_SetResult(interp, "unmatched close-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched close-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", NULL); return TCL_ERROR; diff --git a/generic/tclIO.c b/generic/tclIO.c index ea6c2d7..0cb9fa9 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -427,7 +427,10 @@ TclFinalizeIOSubsystem(void) statePtr != NULL; statePtr = statePtr->nextCSPtr) { chanPtr = statePtr->topChanPtr; - if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD) + if (GotFlag(statePtr, CHANNEL_DEAD)) { + continue; + } + if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED ) || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); active = 1; @@ -876,19 +879,25 @@ CheckForStdChannelsBeingClosed( ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if ((chan == tsdPtr->stdinChannel) && tsdPtr->stdinInitialized) { + if (tsdPtr->stdinInitialized + && tsdPtr->stdinChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdinChannel = NULL; return; } - } else if ((chan == tsdPtr->stdoutChannel) && tsdPtr->stdoutInitialized) { + } else if (tsdPtr->stdoutInitialized + && tsdPtr->stdoutChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdoutChannel = NULL; return; } - } else if ((chan == tsdPtr->stderrChannel) && tsdPtr->stderrInitialized) { + } else if (tsdPtr->stderrInitialized + && tsdPtr->stderrChannel != NULL + && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; @@ -1024,8 +1033,9 @@ Tcl_UnregisterChannel( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp != NULL) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -1260,8 +1270,8 @@ Tcl_GetChannel( hTblPtr = GetChannelTable(interp); hPtr = Tcl_FindHashEntry(hTblPtr, name); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find channel named \"", chanName, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find channel named \"%s\"", chanName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL); return NULL; } @@ -1581,8 +1591,9 @@ Tcl_StackChannel( if (statePtr == NULL) { if (interp) { - Tcl_AppendResult(interp, "couldn't find state for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find state for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1602,9 +1613,9 @@ Tcl_StackChannel( if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { if (interp) { - Tcl_AppendResult(interp, - "reading and writing both disallowed for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "reading and writing both disallowed for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1627,8 +1638,9 @@ Tcl_StackChannel( statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; if (interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1781,9 +1793,9 @@ Tcl_UnstackChannel( */ if (!TclChanCaughtErrorBypass(interp, chan) && interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName((Tcl_Channel) chanPtr))); } return TCL_ERROR; } @@ -2315,8 +2327,8 @@ CheckForDeadChannel( Tcl_SetErrno(EINVAL); if (interp) { - Tcl_AppendResult(interp, "unable to access channel: invalid channel", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to access channel: invalid channel", -1)); } return 1; } @@ -3048,8 +3060,9 @@ Tcl_Close( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -3207,8 +3220,9 @@ Tcl_CloseEx( */ if (!chanPtr->typePtr->close2Proc) { - Tcl_AppendResult(interp, "Half-close of channels not supported by ", - chanPtr->typePtr->typeName, "s", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "half-close of channels not supported by %ss", + chanPtr->typePtr->typeName)); return TCL_ERROR; } @@ -3217,9 +3231,8 @@ Tcl_CloseEx( */ if (chanPtr != statePtr->topChanPtr) { - Tcl_AppendResult(interp, - "Half-close not applicable to stack of transformations", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "half-close not applicable to stack of transformations", -1)); return TCL_ERROR; } @@ -3237,9 +3250,9 @@ Tcl_CloseEx( } else { msg = "write"; } - Tcl_AppendResult(interp, "Half-close of ", msg, - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened or" + " already closed", msg)); return TCL_ERROR; } @@ -3250,8 +3263,9 @@ Tcl_CloseEx( if (statePtr->flags & CHANNEL_INCLOSE) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -7544,6 +7558,7 @@ Tcl_BadChannelOption( const char **argv; int argc, i; Tcl_DString ds; + Tcl_Obj *errObj; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); @@ -7556,13 +7571,14 @@ Tcl_BadChannelOption( Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, - "\": should be one of ", NULL); + errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", + optionName); argc--; for (i = 0; i < argc; i++) { - Tcl_AppendResult(interp, "-", argv[i], ", ", NULL); + Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); } - Tcl_AppendResult(interp, "or -", argv[i], NULL); + Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); + Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); ckfree(argv); } @@ -7840,8 +7856,9 @@ Tcl_SetChannelOption( if (statePtr->csPtrR || statePtr->csPtrW) { if (interp) { - Tcl_AppendResult(interp, "unable to set channel options: " - "background copy in progress", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to set channel options: background copy in" + " progress", -1)); } return TCL_ERROR; } @@ -7890,8 +7907,9 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_LINEBUFFERED); SetFlag(statePtr, CHANNEL_UNBUFFERED); } else if (interp) { - Tcl_AppendResult(interp, "bad value for -buffering: " - "must be one of full, line, or none", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -buffering: must be one of" + " full, line, or none", -1)); return TCL_ERROR; } return TCL_OK; @@ -7946,8 +7964,9 @@ Tcl_SetChannelOption( if (inValue & 0x80 || outValue & 0x80) { if (interp) { - Tcl_AppendResult(interp, "bad value for -eofchar: ", - "must be non-NUL ASCII character", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -eofchar: must be non-NUL ASCII" + " character", -1)); } ckfree(argv); return TCL_ERROR; @@ -7960,9 +7979,9 @@ Tcl_SetChannelOption( } } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: should be a list of zero," - " one, or two elements", NULL); + " one, or two elements", -1)); } ckfree(argv); return TCL_ERROR; @@ -7994,9 +8013,9 @@ Tcl_SetChannelOption( writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL; } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" - " element list", NULL); + " element list", -1)); } ckfree(argv); return TCL_ERROR; @@ -8024,10 +8043,9 @@ Tcl_SetChannelOption( translation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8075,10 +8093,9 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8822,6 +8839,7 @@ TclChannelEventScriptInvoker( */ Tcl_Preserve(interp); + Tcl_Preserve(chanPtr); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* @@ -8838,6 +8856,7 @@ TclChannelEventScriptInvoker( } Tcl_BackgroundException(interp, result); } + Tcl_Release(chanPtr); Tcl_Release(interp); } @@ -8896,8 +8915,8 @@ Tcl_FileEventObjCmd( chanPtr = (Channel *) chan; statePtr = chanPtr->state; if ((statePtr->flags & mask) == 0) { - Tcl_AppendResult(interp, "channel is not ", - (mask == TCL_READABLE) ? "readable" : "writable", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", + (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; } @@ -9018,15 +9037,15 @@ TclCopyChannel( if (BUSY_STATE(inStatePtr, TCL_READABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(inChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(inChan))); } return TCL_ERROR; } if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(outChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(outChan))); } return TCL_ERROR; } @@ -10152,8 +10171,9 @@ SetBlockMode( */ if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error setting blocking mode: %s", + Tcl_PosixError(interp))); } } else { /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 59856d0..005713d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -174,9 +174,10 @@ Tcl_PutsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -201,8 +202,8 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", TclGetString(chanObjPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -244,9 +245,10 @@ Tcl_FlushObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -259,9 +261,9 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error flushing \"", - TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error flushing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -306,9 +308,10 @@ Tcl_GetsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -326,10 +329,9 @@ Tcl_GetsObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -411,9 +413,10 @@ Tcl_ReadObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } i++; /* Consumed channel name. */ @@ -436,11 +439,11 @@ Tcl_ReadObjCmd( if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { #endif - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected non-negative integer but got \"", - TclGetString(objv[i]), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected non-negative integer but got \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; #if TCL_MAJOR_VERSION < 9 } newline = 1; @@ -460,10 +463,9 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -552,9 +554,9 @@ Tcl_SeekObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error during seek on \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during seek on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -679,9 +681,9 @@ Tcl_CloseObjCmd( */ if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_AppendResult(interp, "Half-close of ", dirOptions[index], - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened" + " or already closed", dirOptions[index])); return TCL_ERROR; } @@ -977,9 +979,9 @@ Tcl_ExecObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading output from command: %s", + Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -1048,9 +1050,10 @@ Tcl_FblockedObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -1174,7 +1177,7 @@ Tcl_OpenObjCmd( return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1479,8 +1482,8 @@ Tcl_SocketObjCmd( switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } async = 1; @@ -1488,8 +1491,8 @@ Tcl_SocketObjCmd( case SKT_MYADDR: a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myaddr option", -1)); return TCL_ERROR; } myaddr = TclGetString(objv[a]); @@ -1499,8 +1502,8 @@ Tcl_SocketObjCmd( a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myport option", -1)); return TCL_ERROR; } myPortName = TclGetString(objv[a]); @@ -1511,15 +1514,15 @@ Tcl_SocketObjCmd( } case SKT_SERVER: if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -server option", -1)); return TCL_ERROR; } script = TclGetString(objv[a]); @@ -1531,8 +1534,8 @@ Tcl_SocketObjCmd( if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "option -myport is not valid for servers", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -myport is not valid for servers", -1)); return TCL_ERROR; } } else if (a < objc) { @@ -1599,9 +1602,9 @@ Tcl_SocketObjCmd( return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_RegisterChannel(interp, chan); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1651,17 +1654,19 @@ Tcl_FcopyObjCmd( if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(objv[2]))); return TCL_ERROR; } @@ -1745,14 +1750,14 @@ ChanPendingObjCmd( switch ((enum options) index) { case PENDING_INPUT: - if ((mode & TCL_READABLE) == 0) { + if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: - if ((mode & TCL_WRITABLE) == 0) { + if (!(mode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); @@ -1806,8 +1811,8 @@ ChanTruncateObjCmd( return TCL_ERROR; } if (length < 0) { - Tcl_AppendResult(interp, - "cannot truncate to negative length of file", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot truncate to negative length of file", -1)); return TCL_ERROR; } } else { @@ -1817,18 +1822,17 @@ ChanTruncateObjCmd( length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { - Tcl_AppendResult(interp, - "could not determine current location in \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not determine current location in \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_AppendResult(interp, "error during truncate on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during truncate on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 6f80c25..bfe6a10 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -284,8 +284,8 @@ TclChannelTransform( dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr, mode, chan); if (dataPtr->self == NULL) { - Tcl_AppendResult(interp, "\nfailed to stack channel \"", - Tcl_GetChannelName(chan), "\"", NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), + "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); ckfree(dataPtr); diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 6fec40a..cb0282a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -404,25 +404,25 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ FreeReceivedError(p) #define PassReceivedError(c,p) \ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); @@ -739,7 +739,8 @@ TclChanCreateObjCmd( * Return handle as result of command. */ - Tcl_SetResult(interp, (char *)chanPtr->state->channelName, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(chanPtr->state->channelName, -1)); return TCL_OK; error: @@ -774,13 +775,15 @@ TclChanCreateObjCmd( */ typedef struct ReflectEvent { - Tcl_Event header; - ReflectedChannel* rcPtr; - int events; + Tcl_Event header; + ReflectedChannel *rcPtr; + int events; } ReflectEvent; static int -ReflectEventRun (Tcl_Event* ev, int flags) +ReflectEventRun( + Tcl_Event *ev, + int flags) { /* OWNER thread * @@ -789,14 +792,16 @@ ReflectEventRun (Tcl_Event* ev, int flags) * accomplishing that. */ - ReflectEvent* e = (ReflectEvent*) ev; + ReflectEvent *e = (ReflectEvent *) ev; - Tcl_NotifyChannel (e->rcPtr->chan, e->events); + Tcl_NotifyChannel(e->rcPtr->chan, e->events); return 1; } static int -ReflectEventDelete (Tcl_Event* ev, ClientData cd) +ReflectEventDelete( + Tcl_Event *ev, + ClientData cd) { /* OWNER thread * @@ -805,11 +810,9 @@ ReflectEventDelete (Tcl_Event* ev, ClientData cd) * invalid channel. */ - ReflectEvent* e = (ReflectEvent*) ev; + ReflectEvent *e = (ReflectEvent *) ev; - if ((ev->proc != ReflectEventRun) || - ((cd != NULL) && - (cd != e->rcPtr))) { + if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) { return 0; } return 1; @@ -867,8 +870,8 @@ TclChanPostEventObjCmd( hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find reflected channel named \"", - chanId, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find reflected channel named \"%s\"", chanId)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); return TCL_ERROR; } @@ -925,8 +928,9 @@ TclChanPostEventObjCmd( */ if (events & ~rcPtr->interest) { - Tcl_AppendResult(interp, "tried to post events channel \"", chanId, - "\" is not interested in", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "tried to post events channel \"%s\" is not interested in", + chanId)); return TCL_ERROR; } @@ -937,10 +941,11 @@ TclChanPostEventObjCmd( #ifdef TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - Tcl_NotifyChannel (chan, events); + Tcl_NotifyChannel(chan, events); #ifdef TCL_THREADS } else { - ReflectEvent* ev = ckalloc (sizeof (ReflectEvent)); + ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); + ev->header.proc = ReflectEventRun; ev->events = events; ev->rcPtr = rcPtr; @@ -957,7 +962,8 @@ TclChanPostEventObjCmd( * The teardown of unprocessed events is currently coupled to the * thread reflected channel map */ - (void) GetThreadReflectedChannelMap (); + + (void) GetThreadReflectedChannelMap(); /* XXX Race condition !! * XXX The destination thread may not exist anymore already. @@ -965,8 +971,9 @@ TclChanPostEventObjCmd( * XXX Can we detect this ? (check the validity of the owner threadid ?) * XXX Actually, in that case the channel should be dead also ! */ - Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL); - Tcl_ThreadAlert (rcPtr->owner); + + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(rcPtr->owner); } #endif @@ -1156,8 +1163,11 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* Now squash the pending reflection events for this channel. */ - Tcl_DeleteEvents (ReflectEventDelete, rcPtr); + /* + * Now squash the pending reflection events for this channel. + */ + + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); if (result != TCL_OK) { FreeReceivedError(&p); @@ -1165,7 +1175,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1177,7 +1187,7 @@ ReflectClose( */ if (rcPtr->methods == 0) { - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1192,10 +1202,13 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* Now squash the pending reflection events for this channel. */ - Tcl_DeleteEvents (ReflectEventDelete, rcPtr); + /* + * Now squash the pending reflection events for this channel. + */ + + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -1240,7 +1253,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); #ifdef TCL_THREADS } #endif @@ -1348,7 +1361,7 @@ ReflectInput( *errorCodePtr = EOK; if (bytec > 0) { - memcpy(buf, bytev, (size_t)bytec); + memcpy(buf, bytev, (size_t) bytec); } stop: @@ -1549,12 +1562,13 @@ ReflectSeekWide( Tcl_Preserve(rcPtr); offObj = Tcl_NewWideIntObj(offset); - baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : - ((seekMode == SEEK_CUR) ? "current" : "end"), -1); + baseObj = Tcl_NewStringObj( + (seekMode == SEEK_SET) ? "start" : + (seekMode == SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1760,7 +1774,9 @@ ReflectBlock( */ static void -ReflectThread(ClientData clientData, int action) +ReflectThread( + ClientData clientData, + int action) { ReflectedChannel *rcPtr = clientData; @@ -1772,7 +1788,7 @@ ReflectThread(ClientData clientData, int action) rcPtr->owner = NULL; break; default: - Tcl_Panic ("Unknown thread action code."); + Tcl_Panic("Unknown thread action code."); break; } } @@ -2046,7 +2062,8 @@ EncodeEventMask( } if (listc < 1) { - Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s list: is empty", objName)); return TCL_ERROR; } @@ -2807,7 +2824,7 @@ DeleteThreadReflectedChannelMap( * actually. */ - Tcl_DeleteEvents (ReflectEventDelete, NULL); + Tcl_DeleteEvents(ReflectEventDelete, NULL); /* * Get the map of all channels handled by the current thread. This is a @@ -2978,9 +2995,8 @@ ForwardProc( Tcl_Interp *interp = rcPtr->interp; ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - ReflectedChannelMap *rcmPtr; - /* Map of reflected channels with handlers in - * this interp. */ + ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in + * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ /* @@ -3023,12 +3039,12 @@ ForwardProc( rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); FreeReflectedChannelArgs(rcPtr); @@ -3063,7 +3079,7 @@ ForwardProc( paramPtr->input.toRead = -1; } else { if (bytec > 0) { - memcpy(paramPtr->input.buf, bytev, (size_t)bytec); + memcpy(paramPtr->input.buf, bytev, (size_t) bytec); } paramPtr->input.toRead = bytec; } @@ -3075,7 +3091,7 @@ ForwardProc( case ForwardedOutput: { Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) - paramPtr->output.buf, paramPtr->output.toWrite); + paramPtr->output.buf, paramPtr->output.toWrite); Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); @@ -3115,8 +3131,8 @@ ForwardProc( case ForwardedSeek: { Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); Tcl_Obj *baseObj = Tcl_NewStringObj( - (paramPtr->seek.seekMode==SEEK_SET) ? "start" : - (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); + (paramPtr->seek.seekMode==SEEK_SET) ? "start" : + (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); @@ -3166,11 +3182,11 @@ ForwardProc( case ForwardedBlock: { Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); - Tcl_IncrRefCount(blockObj); + Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3186,7 +3202,7 @@ ForwardProc( Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3201,8 +3217,8 @@ ForwardProc( */ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); - Tcl_IncrRefCount(optionObj); + Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 8f111b0..2b9efb9 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -363,33 +363,43 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ - } + do { \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ + } \ + } while (0) #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ - FreeReceivedError(p) + do { \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ + FreeReceivedError(p); \ + } while (0) #define PassReceivedError(c,p) \ - Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ - FreeReceivedError(p) + do { \ + Tcl_SetChannelError((c), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + FreeReceivedError(p); \ + } while (0) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); - static ReflectedTransformMap * GetThreadReflectedTransformMap(void); -static void DeleteThreadReflectedTransformMap(ClientData clientData); - +static void DeleteThreadReflectedTransformMap( + ClientData clientData); #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ @@ -513,7 +523,6 @@ TclChanPushObjCmd( int result; /* Result code for 'initialize' */ Tcl_Obj *resObj; /* Result data for 'initialize' */ int methods; /* Bitmask for supported methods. */ - Tcl_Obj *err; /* Error message */ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers * in this interp. */ @@ -608,11 +617,10 @@ TclChanPushObjCmd( while (listc > 0) { if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned ", -1); - Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned %s", + Tcl_GetString(cmdObj), + Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } @@ -695,13 +703,14 @@ TclChanPushObjCmd( rtmPtr = GetThreadReflectedTransformMap(); hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); -#endif +#endif /* TCL_THREADS */ /* * Return the channel as the result of the command. */ - Tcl_AppendResult(interp, Tcl_GetChannelName(rtPtr->chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetChannelName(rtPtr->chan), -1)); return TCL_OK; error: @@ -710,7 +719,7 @@ TclChanPushObjCmd( * structure. */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return TCL_ERROR; #undef CHAN @@ -913,9 +922,9 @@ ReflectClose( FreeReceivedError(&p); } } -#endif +#endif /* TCL_THREADS */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return EOK; } @@ -931,11 +940,11 @@ ReflectClose( if (!TransformDrain(rtPtr, &errorCode)) { #ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree (rtPtr, + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } -#endif +#endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; } @@ -945,11 +954,11 @@ ReflectClose( if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { #ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree (rtPtr, + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } -#endif +#endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; } @@ -966,7 +975,7 @@ ReflectClose( ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -974,7 +983,7 @@ ReflectClose( } return EOK; } -#endif +#endif /* TCL_THREADS */ /* * Do the actual invokation of "finalize" now; we're in the right thread. @@ -1022,7 +1031,7 @@ ReflectClose( if (hPtr) { Tcl_DeleteHashEntry(hPtr); } -#endif +#endif /* TCL_THREADS */ } Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -1348,7 +1357,7 @@ ReflectSeekWide( * transformation. */ - if ((rtPtr->methods & FLAG(METH_CLEAR))) { + if (rtPtr->methods & FLAG(METH_CLEAR)) { TransformClear(rtPtr); } @@ -2140,7 +2149,7 @@ DeleteReflectedTransformMap( ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; -#endif +#endif /* TCL_THREADS */ /* * Delete all entries. The channels may have been closed already, or will @@ -2232,8 +2241,7 @@ DeleteReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } Tcl_MutexUnlock(&rtForwardMutex); - -#endif +#endif /* TCL_THREADS */ } #ifdef TCL_THREADS @@ -2631,7 +2639,7 @@ ForwardProc( break; } - case ForwardedDrain: { + case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2656,9 +2664,8 @@ ForwardProc( } } break; - } - case ForwardedFlush: { + case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2684,12 +2691,10 @@ ForwardProc( } } break; - } - case ForwardedClear: { + case ForwardedClear: (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); break; - } case ForwardedLimit: if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { @@ -2795,7 +2800,7 @@ ForwardSetObjError( ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); } -#endif +#endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- @@ -3092,7 +3097,7 @@ TransformRead( ckfree(p.transform.buf); return 1; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ @@ -3153,7 +3158,7 @@ TransformWrite( p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */ /* ASSERT: rtPtr->mode & TCL_WRITABLE */ @@ -3215,7 +3220,7 @@ TransformDrain( ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3270,7 +3275,7 @@ TransformFlush( } ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3311,7 +3316,7 @@ TransformClear( ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p); return; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 018f9f5..694501f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -64,8 +64,8 @@ TclSockGetPort( return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_AppendResult(interp, "couldn't open socket: port number too high", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't open socket: port number too high", -1)); return TCL_ERROR; } return TCL_OK; @@ -100,16 +100,20 @@ TclSockMinimumBuffers( socklen_t len; len = sizeof(int); - getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) &size, len); } len = sizeof(int); - getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) &size, len); } return TCL_OK; } @@ -147,24 +151,34 @@ TclCreateSocketAddress( struct addrinfo *p; struct addrinfo *v4head = NULL, *v4ptr = NULL; struct addrinfo *v6head = NULL, *v6ptr = NULL; - char *native = NULL, portstring[TCL_INTEGER_SPACE]; + char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring; const char *family = NULL; Tcl_DString ds; int result, i; - TclFormatInt(portstring, port); - if (host != NULL) { native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); } + + /* + * Workaround for OSX's apparent inability to resolve "localhost", "0" + * when the loopback device is the only available network interface. + */ + if (host != NULL && port == 0) { + portstring = NULL; + } else { + TclFormatInt(portbuf, port); + portstring = portbuf; + } (void) memset(&hints, 0, sizeof(hints)); - hints.ai_family = AF_UNSPEC; + /* * Magic variable to enforce a certain address family - to be superseded * by a TIP that adds explicit switches to [socket] */ + if (interp != NULL) { family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0); if (family != NULL) { @@ -182,7 +196,7 @@ TclCreateSocketAddress( /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve - * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of + * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of * using AI_ADDRCONFIG in situations where it works, is probably low, * we'll leave it out for now. After all, it is just an optimisation. * @@ -206,12 +220,11 @@ TclCreateSocketAddress( } if (result != 0) { -#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ - if (result == EAI_SYSTEM) - *errorMsgPtr = Tcl_PosixError(interp); - else -#endif - *errorMsgPtr = gai_strerror(result); + *errorMsgPtr = +#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ + (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : +#endif /* EAI_SYSTEM */ + gai_strerror(result); return 0; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 41a5aac..ab08353 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -182,8 +182,8 @@ const Tcl_Filesystem tclNativeFilesystem = { TclpObjRenameFile, TclpObjCopyDirectory, TclpObjLstat, - TclpDlopen, - /* Needs a cast since we're using version_2. */ + /* Needs casts since we're using version_2. */ + (Tcl_FSLoadFileProc *) TclpDlopen, (Tcl_FSGetCwdProc *) TclpGetNativeCwd, TclpObjChdir }; @@ -460,6 +460,7 @@ FsThrExitProc( ckfree(fsRecPtr); fsRecPtr = tmpFsRecPtr; } + tsdPtr->filesystemList = NULL; tsdPtr->initialized = 0; } @@ -647,23 +648,26 @@ TclFSEpochOk( } static void -Claim() +Claim(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + tsdPtr->claims++; } static void -Disclaim() +Disclaim(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + tsdPtr->claims--; } int -TclFSEpoch() +TclFSEpoch(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + return tsdPtr->filesystemEpoch; } @@ -1094,8 +1098,9 @@ Tcl_FSMatchInDirectory( cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetResult(interp, "glob couldn't determine " - "the current working directory", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "glob couldn't determine the current working directory", + -1)); } return TCL_ERROR; } @@ -1572,8 +1577,8 @@ TclGetOpenModeEx( *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); } return -1; } @@ -1622,8 +1627,9 @@ TclGetOpenModeEx( mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } ckfree(modeArgv); return -1; @@ -1634,8 +1640,9 @@ TclGetOpenModeEx( mode |= O_NONBLOCK; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } ckfree(modeArgv); return -1; @@ -1648,9 +1655,10 @@ TclGetOpenModeEx( } else { if (interp != NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid access mode \"%s\": must be RDONLY, WRONLY, " + "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," + " or TRUNC", flag)); } ckfree(modeArgv); return -1; @@ -1661,8 +1669,9 @@ TclGetOpenModeEx( if (!gotRW) { if (interp != NULL) { - Tcl_AppendResult(interp, "access mode must include either" - " RDONLY, WRONLY, or RDWR", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "access mode must include either RDONLY, WRONLY, or RDWR", + -1)); } return -1; } @@ -1721,15 +1730,16 @@ Tcl_FSEvalFileEx( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1763,8 +1773,9 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } string = Tcl_GetString(objPtr); @@ -1777,8 +1788,9 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1852,15 +1864,16 @@ TclNREvalFile( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1894,8 +1907,9 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -1909,8 +1923,9 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2246,9 +2261,9 @@ Tcl_FSOpenFileChannel( if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) < (Tcl_WideInt) 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not seek to end of file " - "while opening \"", Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not seek to end of file while opening \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; @@ -2265,8 +2280,9 @@ Tcl_FSOpenFileChannel( Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2684,9 +2700,9 @@ Tcl_FSGetCwd( Disclaim(); goto cdDidNotChange; } else if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } } Disclaim(); @@ -2760,9 +2776,9 @@ Tcl_FSGetCwd( retCd = proc2(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } if (retCd == tsdPtr->cwdClientData) { @@ -3104,7 +3120,7 @@ Tcl_LoadFile( * code. */ const char *const symbols[],/* Names of functions to look up in the file's * symbol table. */ - int flags, /* Flags (unused) */ + int flags, /* Flags */ void *procVPtrs, /* Where to return the addresses corresponding * to symbols[]. */ Tcl_LoadHandle *handlePtr) /* Filled with token for shared library @@ -3129,8 +3145,8 @@ Tcl_LoadFile( } if (fsPtr->loadFileProc != NULL) { - int retVal = fsPtr->loadFileProc(interp, pathPtr, handlePtr, - &unloadProcPtr); + int retVal = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc)) + (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { if (*handlePtr == NULL) { @@ -3152,8 +3168,9 @@ Tcl_LoadFile( */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -3195,7 +3212,7 @@ Tcl_LoadFile( ret = Tcl_Read(data, buffer, size); Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - &unloadProcPtr); + &unloadProcPtr, flags); if (ret == TCL_OK && *handlePtr != NULL) { goto resolveSymbols; } @@ -3203,7 +3220,7 @@ Tcl_LoadFile( mustCopyToTempAnyway: Tcl_ResetResult(interp); -#endif +#endif /* TCL_LOAD_FROM_MEMORY */ /* * Get a temporary filename to use, first to copy the file into, and then @@ -3223,8 +3240,8 @@ Tcl_LoadFile( Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); return TCL_ERROR; } @@ -3266,7 +3283,7 @@ Tcl_LoadFile( Tcl_ResetResult(interp); - retVal = Tcl_LoadFile(interp, copyToPtr, symbols, 0, procPtrs, + retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, &newLoadHandle); if (retVal != TCL_OK) { /* @@ -3498,50 +3515,6 @@ DivertUnloadFile( } /* - * This function used to be in the platform specific directories, but it has - * now been made to work cross-platform. - */ - -int -TclpLoadFile( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Name of the file containing the desired - * code (UTF-8). */ - const char *sym1, const char *sym2, - /* Names of two functions to look up in the - * file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr, /* Filled with token for dynamically loaded - * file which will be passed back to - * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr) - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for this - * file. */ -{ - Tcl_LoadHandle handle = NULL; - int res; - - res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); - - if (res != TCL_OK) { - return res; - } - - if (handle == NULL) { - return TCL_ERROR; - } - - *clientDataPtr = handle; - - *proc1Ptr = (Tcl_PackageInitProc*) Tcl_FindSymbol(interp, handle, sym1); - *proc2Ptr = (Tcl_PackageInitProc*) Tcl_FindSymbol(interp, handle, sym2); - return TCL_OK; -} - -/* *---------------------------------------------------------------------- * * Tcl_FindSymbol -- diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 85e0730..731d759 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -600,8 +600,9 @@ PrefixMatchObjCmd( flags |= TCL_EXACT; break; case PRFMATCH_MESSAGE: - if (i > (objc - 4)) { - Tcl_AppendResult(interp, "missing message", NULL); + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value for -message", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } @@ -610,7 +611,8 @@ PrefixMatchObjCmd( break; case PRFMATCH_ERROR: if (i > objc-4) { - Tcl_AppendResult(interp, "missing error options", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value for -error", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } @@ -620,8 +622,9 @@ PrefixMatchObjCmd( return TCL_ERROR; } if ((errorLength % 2) != 0) { - Tcl_AppendResult(interp, "error options must have an even" - " number of elements", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error options must have an even number of elements", + -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); return TCL_ERROR; } @@ -1174,8 +1177,8 @@ Tcl_ParseArgsObjv( goto gotMatch; } if (matchPtr != NULL) { - Tcl_AppendResult(interp, "ambiguous option \"", str, "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "ambiguous option \"%s\"", str)); goto error; } matchPtr = infoPtr; @@ -1187,8 +1190,8 @@ Tcl_ParseArgsObjv( */ if (remObjv == NULL) { - Tcl_AppendResult(interp, "unrecognized argument \"", str, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unrecognized argument \"%s\"", str)); goto error; } @@ -1213,9 +1216,9 @@ Tcl_ParseArgsObjv( } if (Tcl_GetIntFromObj(interp, objv[srcIndex], (int *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected integer argument for \"", - infoPtr->keyStr, "\" but got \"", - Tcl_GetString(objv[srcIndex]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer argument for \"%s\" but got \"%s\"", + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1246,9 +1249,9 @@ Tcl_ParseArgsObjv( } if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], (double *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected floating-point argument ", - "for \"", infoPtr->keyStr, "\" but got \"", - Tcl_GetString(objv[srcIndex]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected floating-point argument for \"%s\" but got \"%s\"", + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1322,8 +1325,8 @@ Tcl_ParseArgsObjv( */ missingArg: - Tcl_AppendResult(interp, "\"", str, - "\" option requires an additional argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { ckfree(leftovers); @@ -1361,6 +1364,7 @@ PrintUsage( #define NUM_SPACES 20 static const char spaces[] = " "; char tmp[TCL_DOUBLE_SPACE]; + Tcl_Obj *msg; /* * First, compute the width of the widest option key, so that we can make @@ -1384,39 +1388,39 @@ PrintUsage( * Now add the option information, with pretty-printing. */ - Tcl_AppendResult(interp, "Command-specific options:", NULL); + msg = Tcl_NewStringObj("Command-specific options:", -1); for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) { - Tcl_AppendResult(interp, "\n", infoPtr->helpStr, NULL); + Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr); continue; } - Tcl_AppendResult(interp, "\n ", infoPtr->keyStr, ":", NULL); + Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr); numSpaces = width + 1 - strlen(infoPtr->keyStr); while (numSpaces > 0) { if (numSpaces >= NUM_SPACES) { - Tcl_AppendResult(interp, spaces, NULL); + Tcl_AppendToObj(msg, spaces, NUM_SPACES); } else { - Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, NULL); + Tcl_AppendToObj(msg, spaces, numSpaces); } numSpaces -= NUM_SPACES; } - Tcl_AppendResult(interp, infoPtr->helpStr, NULL); + Tcl_AppendToObj(msg, infoPtr->helpStr, -1); switch (infoPtr->type) { case TCL_ARGV_INT: - sprintf(tmp, "%d", *((int *) infoPtr->dstPtr)); - Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL); + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d", + *((int *) infoPtr->dstPtr)); break; case TCL_ARGV_FLOAT: + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", + *((double *) infoPtr->dstPtr)); sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); - Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL); break; case TCL_ARGV_STRING: { - char *string; + char *string = *((char **) infoPtr->dstPtr); - string = *((char **) infoPtr->dstPtr); if (string != NULL) { - Tcl_AppendResult(interp, "\n\t\tDefault value: \"", string, - "\"", NULL); + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"", + string); } break; } @@ -1424,6 +1428,7 @@ PrintUsage( break; } } + Tcl_SetObjResult(interp, msg); } /* @@ -1435,8 +1440,8 @@ PrintUsage( * * Results: * Returns TCL_ERROR if the value is an invalid completion code. - * Otherwise, returns TCL_OK, and writes the completion code to - * the pointer provided. + * Otherwise, returns TCL_OK, and writes the completion code to the + * pointer provided. * * Side effects: * None. @@ -1448,30 +1453,30 @@ int TclGetCompletionCodeFromObj( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *value, - int *code) /* Argument objects. */ + int *codePtr) /* Argument objects. */ { static const char *const returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; if ((value->typePtr != &indexType) - && (TCL_OK == TclGetIntFromObj(NULL, value, code))) { + && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } - if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, - TCL_EXACT, code)) { + if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, + codePtr) == TCL_OK) { return TCL_OK; } + /* * Value is not a legal completion code. */ if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad completion code \"", - TclGetString(value), - "\": must be ok, error, return, break, " - "continue, or an integer", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad completion code \"%s\": must be" + " ok, error, return, break, continue, or an integer", + TclGetString(value))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); } return TCL_ERROR; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 9f73a31..8f8b992 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1219,6 +1219,12 @@ declare 14 unix { const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } +# Added in 8.6; core of TclpOpenTemporaryFile +declare 20 unix { + int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) +} + ################################ # Mac OS X specific functions diff --git a/generic/tclInt.h b/generic/tclInt.h index feb7fd4..9e062ad 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -801,13 +801,17 @@ typedef struct VarInHash { #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount++;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount--;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ } /* @@ -2467,6 +2471,14 @@ typedef struct List { (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) /* + * Modes for collecting (or not) in the implementations of TclNRForeachCmd, + * TclNRLmapCmd and their compilations. + */ + +#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ +#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ + +/* * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. * @@ -2536,6 +2548,8 @@ typedef struct List { #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); +typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file @@ -2758,6 +2772,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -2766,7 +2781,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; +MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; @@ -3053,12 +3070,6 @@ MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); -MODULE_SCOPE int TclpLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, - const char *sym1, const char *sym2, - Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, - ClientData *clientDataPtr, - Tcl_FSUnloadFileProc **unloadProcPtr); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); MODULE_SCOPE void TclpMasterUnlock(void); @@ -3137,13 +3148,13 @@ MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr); + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, int size, int codeSize, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr); + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); #endif MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); @@ -3326,6 +3337,9 @@ MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3461,6 +3475,15 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3473,6 +3496,12 @@ MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3485,9 +3514,18 @@ MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3509,15 +3547,36 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3536,6 +3595,9 @@ MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3545,15 +3607,36 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3566,21 +3649,36 @@ MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3599,6 +3697,9 @@ MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index d01d10a..df5ac97 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -604,7 +604,7 @@ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, typedef struct TclIntStubs { int magic; - const struct TclIntStubHooks *hooks; + void *hooks; void (*reserved0)(void); void (*reserved1)(void); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 7322a37..f265e7e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -84,7 +84,10 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ -/* Slot 20 is reserved */ +/* 20 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -225,7 +228,10 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ +/* 20 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -240,7 +246,7 @@ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); typedef struct TclIntPlatStubs { int magic; - const struct TclIntPlatStubHooks *hooks; + void *hooks; #if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ @@ -263,7 +269,7 @@ typedef struct TclIntPlatStubs { void (*reserved17)(void); void (*reserved18)(void); void (*reserved19)(void); - void (*reserved20)(void); + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 20 */ void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); @@ -327,7 +333,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 20 */ void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); @@ -389,7 +395,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ -/* Slot 20 is reserved */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 20 */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -501,7 +508,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 20 */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -525,7 +533,10 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError -#if !defined(__WIN32__) && !defined(__CYGWIN__) +#if defined(__WIN32__) || defined(__CYGWIN__) +# undef TclWinNToHS +# define TclWinNToHS ntohs +#else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 5b6d14f..0b0f652 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1043,18 +1043,18 @@ Tcl_InterpObjCmd( iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", - Tcl_GetString(objv[2]), "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" in path \"%s\" not found", + aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "target interpreter for alias \"%s\" in path \"%s\" is " + "not my descendant", aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", NULL); return TCL_ERROR; @@ -1234,7 +1234,8 @@ Tcl_GetAlias( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1295,7 +1296,8 @@ Tcl_GetAliasObj( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1383,9 +1385,9 @@ TclPreventAliasLoop( * [Bug #641195] */ - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": interpreter deleted", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": interpreter deleted", + Tcl_GetCommandName(cmdInterp, cmd))); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; @@ -1398,9 +1400,9 @@ TclPreventAliasLoop( } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": would create a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": would create a loop", + Tcl_GetCommandName(cmdInterp, cmd))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "ALIASLOOP", NULL); return TCL_ERROR; @@ -1621,8 +1623,8 @@ AliasDelete( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr), - "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; @@ -2154,17 +2156,19 @@ Tcl_GetInterpPath( InterpInfo *iiPtr; if (targetInterp == askingInterp) { + Tcl_SetObjResult(askingInterp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), + Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr), -1)); return TCL_OK; } @@ -2218,8 +2222,8 @@ GetInterp( } } if (searchInterp == NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - TclGetString(pathPtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } @@ -2256,8 +2260,8 @@ SlaveBgerror( if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cmdPrefix must be list of length >= 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BGERRORFORMAT", NULL); return TCL_ERROR; @@ -2326,8 +2330,9 @@ SlaveCreate( hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" already exists, cannot create", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "interpreter named \"%s\" already exists, cannot create", + path)); return NULL; } @@ -2860,8 +2865,8 @@ SlaveRecursionLimit( if (objc) { if (Tcl_IsSafe(interp)) { - Tcl_AppendResult(interp, "permission denied: " - "safe interpreters cannot change recursion limit", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " + "safe interpreters cannot change recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", NULL); return TCL_ERROR; @@ -3320,8 +3325,8 @@ Tcl_LimitCheck( if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command count limit exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; @@ -3346,8 +3351,8 @@ Tcl_LimitCheck( iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time limit exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; @@ -4353,8 +4358,9 @@ SlaveCommandLimitCmd( */ if (interp == slaveInterp) { - Tcl_AppendResult(interp, - "limits on current interpreter inaccessible", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4450,8 +4456,8 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4467,8 +4473,8 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (limit < 0) { - Tcl_AppendResult(interp, "command limit value must be at " - "least 0", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command limit value must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4540,8 +4546,9 @@ SlaveTimeLimitCmd( */ if (interp == slaveInterp) { - Tcl_AppendResult(interp, - "limits on current interpreter inaccessible", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4658,8 +4665,8 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4675,13 +4682,13 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "milliseconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "milliseconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.usec = ((long)tmp)*1000; + limitMoment.usec = ((long) tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4693,8 +4700,8 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "seconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "seconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4711,15 +4718,17 @@ SlaveTimeLimitCmd( */ if (secObj != NULL && secLen == 0 && milliLen > 0) { - Tcl_AppendResult(interp, "may only set -milliseconds " - "if -seconds is not also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only set -milliseconds if -seconds is not " + "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { - Tcl_AppendResult(interp, "may only reset -milliseconds " - "if -seconds is also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only reset -milliseconds if -seconds is " + "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADUSAGE", NULL); return TCL_ERROR; diff --git a/generic/tclLoad.c b/generic/tclLoad.c index ce4d6a4..5cacab1 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -132,9 +132,34 @@ Tcl_LoadObjCmd( Tcl_LoadHandle loadHandle; Tcl_UniChar ch; unsigned len; + int index, flags = 0; + Tcl_Obj *const *savedobjv = objv; + static const char *const options[] = { + "-global", "-lazy", "--", NULL + }; + enum options { + LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST + }; + while (objc > 2) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (LOAD_GLOBAL == (enum options) index) { + flags |= TCL_LOAD_GLOBAL; + } else if (LOAD_LAZY == (enum options) index) { + flags |= TCL_LOAD_LAZY; + } else { + break; + } + } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -157,9 +182,8 @@ Tcl_LoadObjCmd( } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -225,9 +249,9 @@ Tcl_LoadObjCmd( * Can't have two different packages loaded from the same file. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" is already loaded for package \"", - pkgPtr->packageName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" is already loaded for package \"%s\"", + fullFileName, pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; @@ -263,8 +287,8 @@ Tcl_LoadObjCmd( */ if (fullFileName[0] == 0) { - Tcl_AppendResult(interp, "package \"", packageName, - "\" isn't loaded statically", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" isn't loaded statically", packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -321,9 +345,9 @@ Tcl_LoadObjCmd( } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); - Tcl_AppendResult(interp, - "couldn't figure out package name for ", - fullFileName, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't figure out package name for %s", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "WHATPACKAGE", NULL); code = TCL_ERROR; @@ -366,7 +390,7 @@ Tcl_LoadObjCmd( symbols[1] = NULL; Tcl_MutexLock(&packageMutex); - code = Tcl_LoadFile(interp, objv[1], symbols, 0, &initProc, + code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, &loadHandle); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { @@ -392,7 +416,7 @@ Tcl_LoadObjCmd( pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeUnloadName)); pkgPtr->interpRefCount = 0; @@ -418,9 +442,9 @@ Tcl_LoadObjCmd( if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc == NULL) { - Tcl_AppendResult(interp, - "can't use package in a safe interpreter: no ", - pkgPtr->packageName, "_SafeInit procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't use package in a safe interpreter: no" + " %s_SafeInit procedure", pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; @@ -429,9 +453,9 @@ Tcl_LoadObjCmd( code = pkgPtr->safeInitProc(target); } else { if (pkgPtr->initProc == NULL) { - Tcl_AppendResult(interp, - "can't attach package to interpreter: no ", - pkgPtr->packageName, "_Init procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't attach package to interpreter: no %s_Init procedure", + pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; @@ -581,9 +605,8 @@ Tcl_UnloadObjCmd( } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -655,8 +678,9 @@ Tcl_UnloadObjCmd( * It's an error to try unload a static package. */ - Tcl_AppendResult(interp, "package \"", packageName, - "\" is loaded statically and cannot be unloaded", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" is loaded statically and cannot be unloaded", + packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; @@ -667,8 +691,8 @@ Tcl_UnloadObjCmd( * The DLL pointed by the provided filename has never been loaded. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", NULL); code = TCL_ERROR; @@ -696,8 +720,9 @@ Tcl_UnloadObjCmd( * The package has not been loaded in this interpreter. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded in this interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded in this interpreter", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", NULL); code = TCL_ERROR; @@ -712,8 +737,9 @@ Tcl_UnloadObjCmd( if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a safe interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a safe interpreter", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", NULL); code = TCL_ERROR; @@ -722,8 +748,9 @@ Tcl_UnloadObjCmd( unloadProc = pkgPtr->safeUnloadProc; } else { if (pkgPtr->unloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a trusted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a trusted interpreter", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", NULL); code = TCL_ERROR; @@ -862,8 +889,9 @@ Tcl_UnloadObjCmd( } } #else - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: unloading disabled", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded: unloading disabled", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", NULL); code = TCL_ERROR; diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index ac094e6..f030d89 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -39,14 +39,15 @@ TclpDlopen( Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr) + Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ + int flags) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "dynamic loading is not currently available on this system", - TCL_STATIC); + -1)); return TCL_ERROR; } diff --git a/generic/tclMain.c b/generic/tclMain.c index 88b4e51..f445383 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -16,11 +16,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/** - * On Windows, this file needs to be compiled twice, once with - * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW - * can be implemented, sharing the same source code. +/* + * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN + * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing + * the same source code. */ + #if defined(TCL_ASCII_MAIN) # ifdef UNICODE # undef UNICODE @@ -40,12 +41,12 @@ #define DEFAULT_PRIMARY_PROMPT "% " /* - * This file can be compiled on Windows in UNICODE mode, as well as - * on all other platforms using the native encoding. This is done - * by using the normal Windows functions like _tcscmp, but on - * platforms which don't have <tchar.h> we have to translate that - * to strcmp here. + * This file can be compiled on Windows in UNICODE mode, as well as on all + * other platforms using the native encoding. This is done by using the normal + * Windows functions like _tcscmp, but on platforms which don't have <tchar.h> + * we have to translate that to strcmp here. */ + #ifndef __WIN32__ # define TCHAR char # define TEXT(arg) arg @@ -128,10 +129,11 @@ typedef struct InteractiveState { MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); -static void FreeMainInterp(ClientData clientData); +static void FreeMainInterp(ClientData clientData); #ifndef TCL_ASCII_MAIN static Tcl_ThreadDataKey dataKey; + /* *---------------------------------------------------------------------- * @@ -332,13 +334,14 @@ Tcl_MainEx( */ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) - && (TEXT('-') != argv[3][0])) { - Tcl_Obj *value = NewNativeObj(argv[2], -1); - Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); + && ('-' != argv[3][0])) { + Tcl_Obj *value = NewNativeObj(argv[2], -1); + Tcl_SetStartupScript(NewNativeObj(argv[3], -1), + Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; - } else if ((argc > 1) && (TEXT('-') != argv[1][0])) { + } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; @@ -395,8 +398,9 @@ Tcl_MainEx( /* * Arrange for final deletion of the main interp */ - /* ARGH Munchhausen effect */ - Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp); + + /* ARGH Munchhausen effect */ + Tcl_CreateExitHandler(FreeMainInterp, interp); } /* @@ -458,6 +462,7 @@ Tcl_MainEx( mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { int length; + if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { @@ -523,7 +528,8 @@ Tcl_MainEx( Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); + code = Tcl_RecordAndEvalObj(interp, is.commandPtr, + TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_NewObj(); @@ -557,7 +563,8 @@ Tcl_MainEx( Prompt(interp, &is); } - Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); + Tcl_CreateChannelHandler(is.input, TCL_READABLE, + StdinProc, &is); } mainLoopProc(); @@ -568,24 +575,23 @@ Tcl_MainEx( } is.input = Tcl_GetStdChannel(TCL_STDIN); } -#ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ +#ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } -#endif +#endif /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); - if ((exitCode == 0) && (mainLoopProc != NULL) - && !Tcl_LimitExceeded(interp)) { + if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at @@ -605,21 +611,21 @@ Tcl_MainEx( * exit. The Tcl_EvalObjEx call should never return. */ - if (!Tcl_InterpDeleted(interp)) { - if (!Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { + Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); - Tcl_IncrRefCount(cmd); - Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmd); - } + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); } - /* - * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual - * is happening. Maybe interp has been deleted; maybe [exit] was - * redefined, maybe we've blown up because of an exceeded limit. We - * still want to cleanup and exit. - */ + + /* + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is + * happening. Maybe interp has been deleted; maybe [exit] was redefined, + * maybe we've blown up because of an exceeded limit. We still want to + * cleanup and exit. + */ + Tcl_Exit(exitCode); } @@ -637,7 +643,7 @@ Tcl_Main( Tcl_FindExecutable(argv[0]); Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); } -#endif +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -711,6 +717,7 @@ TclGetMainLoop(void) * *---------------------------------------------------------------------- */ + MODULE_SCOPE int TclFullFinalizationRequested(void) { @@ -727,7 +734,7 @@ TclFullFinalizationRequested(void) Tcl_DStringFree(&ds); } return finalize; -#endif +#endif /* PURIFY */ } #endif /* !TCL_ASCII_MAIN */ @@ -866,9 +873,8 @@ StdinProc( static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - InteractiveState *isPtr) /* InteractiveState. Filled - * with PROMPT_NONE after a prompt is - * printed. */ + InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE + * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; @@ -879,7 +885,7 @@ Prompt( } promptCmdPtr = Tcl_GetVar2Ex(interp, - ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { @@ -920,8 +926,8 @@ Prompt( * * FreeMainInterp -- * - * Exit handler used to cleanup the main interpreter and ancillary startup - * script storage at exit. + * Exit handler used to cleanup the main interpreter and ancillary + * startup script storage at exit. * *---------------------------------------------------------------------- */ @@ -930,13 +936,13 @@ static void FreeMainInterp( ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *) clientData; + Tcl_Interp *interp = clientData; - /*if (TclInExit()) return;*/ + /*if (TclInExit()) return;*/ - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } Tcl_SetStartupScript(NULL, NULL); Tcl_Release(interp); } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6a241f0..02d517f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -104,7 +104,7 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NRNamespaceEvalCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, @@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = { */ static const EnsembleImplMap defaultNamespaceMap[] = { - {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, - {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0}, - {"current", NamespaceCurrentCmd, NULL, NULL, NULL, 0}, - {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, - {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, - {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, - {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, - {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, - {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, - {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, - {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, - {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, - {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, - {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0}, - {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0}, - {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, - {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, - {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0}, + {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, + {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, + {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, + {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -423,7 +423,7 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { - TclSpliceTailcall(interp, framePtr->tailcallPtr); + TclSpliceTailcall(interp, framePtr->tailcallPtr); } } @@ -687,11 +687,10 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't create namespace \"\": " - "only global namespace can have empty name", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEGLOBAL", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" + " \"\": only global namespace can have empty name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -725,10 +724,10 @@ Tcl_CreateNamespace( Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } @@ -1336,9 +1335,9 @@ Tcl_Export( &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendResult(interp, "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", NULL); - Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1543,7 +1542,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1551,22 +1550,22 @@ Tcl_Import( &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace in import pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in import pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendResult(interp, - "no namespace specified in import pattern \"", pattern, - "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no namespace specified in import pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", NULL); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" tries to import from namespace" + " \"%s\" into itself", pattern, importNsPtr->name)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1684,11 +1683,12 @@ DoImport( dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" would create a loop containing command \"", - Tcl_DStringValue(&ds), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" would create a loop" + " containing command \"%s\"", + pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } @@ -1726,9 +1726,9 @@ DoImport( return TCL_OK; } } - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't import command \"%s\": already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -1796,9 +1796,9 @@ Tcl_ForgetImport( &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendResult(interp, - "unknown namespace in namespace forget pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in namespace forget pattern \"%s\"", + pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } @@ -2402,8 +2402,8 @@ Tcl_FindNamespace( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; @@ -2589,8 +2589,8 @@ Tcl_FindCommand( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown command \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } return NULL; @@ -3170,9 +3170,9 @@ NamespaceDeleteCmd( namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[i]), - "\" in namespace delete command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\" in namespace delete command", + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); return TCL_ERROR; @@ -3285,12 +3285,12 @@ NRNamespaceEvalCmd( } if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; + framePtr->objc = objc; + framePtr->objv = objv; } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; } if (objc == 3) { @@ -3748,12 +3748,12 @@ NRNamespaceInscopeCmd( } if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; + framePtr->objc = objc; + framePtr->objv = objv; } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; } /* @@ -3834,8 +3834,8 @@ NamespaceOriginCmd( command = Tcl_GetCommandFromObj(interp, objv[1]); if (command == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -3958,15 +3958,15 @@ NamespacePathCmd( */ if (objc == 1) { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj = Tcl_NewObj(); for (i=0 ; i<nsPtr->commandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( - nsPtr->commandPathArray[i].nsPtr->fullName, -1)); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( + nsPtr->commandPathArray[i].nsPtr->fullName, -1)); } } - Tcl_SetObjResult(interp, resultObj); + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -4843,8 +4843,8 @@ TclLogCommandInfo( int length, /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ const unsigned char *pc, /* Current pc of bytecode execution context */ - Tcl_Obj **tosPtr) /* Current stack of bytecode execution - * context */ + Tcl_Obj **tosPtr) /* Current stack of bytecode execution + * context */ { register const char *p; Interp *iPtr = (Interp *) interp; @@ -4861,55 +4861,55 @@ TclLogCommandInfo( } if (command != NULL) { - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - if (length < 0) { - length = strlen(command); - } - overflow = (length > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + if (length < 0) { + length = strlen(command); + } + overflow = (length > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), (overflow ? limit : length), command, (overflow ? "..." : ""))); - varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, + varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, NULL, 0, 0, &arrayPtr); - if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { - /* - * Should not happen. - */ - - return; - } else { - Tcl_HashEntry *hPtr + if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { + /* + * Should not happen. + */ + + return; + } else { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); - if (tracePtr->traceProc != EstablishErrorInfoTraces) { - /* - * The most recent trace set on ::errorInfo is not the one the - * core itself puts on last. This means some other code is + if (tracePtr->traceProc != EstablishErrorInfoTraces) { + /* + * The most recent trace set on ::errorInfo is not the one the + * core itself puts on last. This means some other code is * tracing the variable, and the additional trace(s) might be * write traces that expect the timing of writes to * ::errorInfo that existed Tcl releases before 8.5. To * satisfy that compatibility need, we write the current * -errorinfo value to the ::errorInfo variable. - */ + */ - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); - } - } + } + } } /* @@ -4917,60 +4917,60 @@ TclLogCommandInfo( */ if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { int len; - iPtr->resetErrorStack = 0; + iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); - if (pc != NULL) { - Tcl_Obj *innerContext; - - innerContext = TclGetInnerContext(interp, pc, tosPtr); - if (innerContext != NULL) { - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); - } - } else if (command != NULL) { - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - Tcl_NewStringObj(command, length)); - } + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; + + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); + } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(command, length)); + } } if (!iPtr->framePtr->objc) { - /* - * Special frame, nothing to report. - */ + /* + * Special frame, nothing to report. + */ } else if (iPtr->varFramePtr != iPtr->framePtr) { - /* - * uplevel case, [lappend errorstack UP $relativelevel] - */ + /* + * uplevel case, [lappend errorstack UP $relativelevel] + */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { - /* - * normal case, [lappend errorstack CALL [info level 0]] - */ + /* + * normal case, [lappend errorstack CALL [info level 0]] + */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( iPtr->framePtr->objc, iPtr->framePtr->objv)); } } @@ -4980,8 +4980,8 @@ TclLogCommandInfo( * * TclErrorStackResetIf -- * - * The TIP 348 reset/no-bc part of TLCI, for specific use by - * TclCompileSyntaxError. + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. * * Results: * None. @@ -5002,27 +5002,27 @@ TclErrorStackResetIf( Interp *iPtr = (Interp *) interp; if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { int len; - iPtr->resetErrorStack = 0; + iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* - * Reset while keeping the list intrep as much as possible. - */ + /* + * Reset while keeping the list intrep as much as possible. + */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - Tcl_NewStringObj(msg, length)); + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(msg, length)); } } @@ -5065,6 +5065,5 @@ Tcl_LogCommandInfo( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclOO.c b/generic/tclOO.c index 821befd..d6d2d6a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3,7 +3,7 @@ * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -81,6 +81,7 @@ static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static inline void SquelchCachedName(Object *oPtr); static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, @@ -313,6 +314,7 @@ InitFoundation( Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; Tcl_DString buffer; + Command *cmdPtr; int i; /* @@ -439,8 +441,9 @@ InitFoundation( NULL); Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, - NULL); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", + TclOOSelfObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectSelfCmd; Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, @@ -704,6 +707,27 @@ AllocObject( /* * ---------------------------------------------------------------------- * + * SquelchCachedName -- + * + * Encapsulates how to throw away a cached object name. Called from + * object rename traces and at object destruction. + * + * ---------------------------------------------------------------------- + */ + +static inline void +SquelchCachedName( + Object *oPtr) +{ + if (oPtr->cachedNameObj) { + Tcl_DecrRefCount(oPtr->cachedNameObj); + oPtr->cachedNameObj = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * * MyDeleted -- * * This callback is triggered when the object's [my] command is deleted @@ -778,10 +802,7 @@ ObjectRenamedTrace( */ if (flags & TCL_TRACE_RENAME) { - if (oPtr->cachedNameObj) { - TclDecrRefCount(oPtr->cachedNameObj); - oPtr->cachedNameObj = NULL; - } + SquelchCachedName(oPtr); return; } @@ -1138,10 +1159,7 @@ ObjectNamespaceDeleted( TclOODeleteChainCache(oPtr->chainCache); } - if (oPtr->cachedNameObj) { - TclDecrRefCount(oPtr->cachedNameObj); - oPtr->cachedNameObj = NULL; - } + SquelchCachedName(oPtr); if (oPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; @@ -1566,8 +1584,9 @@ Tcl_NewObjectInstance( if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, TCL_NAMESPACE_ONLY)) { - Tcl_AppendResult(interp, "can't create object \"", nameStr, - "\": command already exists with that name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return NULL; } @@ -1633,8 +1652,8 @@ Tcl_NewObjectInstance( */ if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetResult(interp, "object deleted in constructor", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } @@ -1689,8 +1708,9 @@ TclNRNewObjectInstance( if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, TCL_NAMESPACE_ONLY)) { - Tcl_AppendResult(interp, "can't create object \"", nameStr, - "\": command already exists with that name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return TCL_ERROR; } @@ -1778,7 +1798,8 @@ FinalizeAlloc( */ if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } @@ -1835,7 +1856,8 @@ Tcl_CopyObjectInstance( */ if (IsRootClass(oPtr)) { - Tcl_AppendResult(interp, "may not clone the class of classes", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not clone the class of classes", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); return NULL; } @@ -2498,9 +2520,9 @@ TclOOObjectCmdCore( flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", TclGetString(methodNamePtr), NULL); return TCL_ERROR; @@ -2514,9 +2536,9 @@ TclOOObjectCmdCore( contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, flags | (oPtr->flags & FILTER_HANDLING), NULL); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(methodNamePtr), NULL); return TCL_ERROR; @@ -2542,8 +2564,8 @@ TclOOObjectCmdCore( } } if (contextPtr->index >= contextPtr->callPtr->numChain) { - Tcl_SetResult(interp, "no valid method implementation", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no valid method implementation", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(methodNamePtr), NULL); TclOODeleteContext(contextPtr); @@ -2624,8 +2646,8 @@ Tcl_ObjectContextInvokeNext( methodType = "method"; } - Tcl_AppendResult(interp, "no next ", methodType, " implementation", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); return TCL_ERROR; } @@ -2693,8 +2715,8 @@ TclNRObjectContextInvokeNext( methodType = "method"; } - Tcl_AppendResult(interp, "no next ", methodType, " implementation", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); return TCL_ERROR; } @@ -2771,8 +2793,8 @@ Tcl_GetObjectFromObj( return cmdPtr->objClientData; notAnObject: - Tcl_AppendResult(interp, TclGetString(objPtr), - " does not refer to an object", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to an object", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), NULL); return NULL; diff --git a/generic/tclOO.h b/generic/tclOO.h index fef2bd0..280481c 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -4,7 +4,7 @@ * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2010 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -34,11 +34,12 @@ extern const char *TclOOInitializeStubs( * version in the files: * * tests/oo.test + * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.6.3" +#define TCLOO_VERSION "0.7" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 35ad1eb..0676618 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -168,8 +168,8 @@ TclOO_Class_Create( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -186,7 +186,8 @@ TclOO_Class_Create( objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { - Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -232,8 +233,8 @@ TclOO_Class_CreateNs( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -250,14 +251,16 @@ TclOO_Class_CreateNs( objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { - Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { - Tcl_AppendResult(interp, "namespace name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "namespace name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -301,8 +304,8 @@ TclOO_Class_New( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -504,6 +507,7 @@ TclOO_Object_Unknown( Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj *errorMsg; /* * If no method name, generate an error asking for a method name. (Only by @@ -529,31 +533,34 @@ TclOO_Object_Unknown( if (numMethodNames == 0) { Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr); + const char *piece; - Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL); if (contextPtr->callPtr->flags & PUBLIC_METHOD) { - Tcl_AppendResult(interp, "\" has no visible methods", NULL); + piece = "visible methods"; } else { - Tcl_AppendResult(interp, "\" has no methods", NULL); + piece = "methods"; } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" has no %s", TclGetString(tmpBuf), piece)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]), - "\": must be ", NULL); + errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ", + TclGetString(objv[skip])); for (i=0 ; i<numMethodNames-1 ; i++) { if (i) { - Tcl_AppendResult(interp, ", ", NULL); + Tcl_AppendToObj(errorMsg, ", ", -1); } - Tcl_AppendResult(interp, methodNames[i], NULL); + Tcl_AppendToObj(errorMsg, methodNames[i], -1); } if (i) { - Tcl_AppendResult(interp, " or ", NULL); + Tcl_AppendToObj(errorMsg, " or ", -1); } - Tcl_AppendResult(interp, methodNames[i], NULL); + Tcl_AppendToObj(errorMsg, methodNames[i], -1); ckfree(methodNames); + Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), NULL); return TCL_ERROR; @@ -609,8 +616,9 @@ TclOO_Object_LinkVar( */ if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "variable name \"", varName, - "\" illegal: must not contain namespace separator", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable name \"%s\" illegal: must not contain namespace" + " separator", varName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } @@ -784,8 +792,9 @@ TclOONextObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -822,8 +831,9 @@ TclOONextToObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -843,8 +853,9 @@ TclOONextToObjCmd( } classPtr = ((Object *)object)->classPtr; if (classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); return TCL_ERROR; } @@ -881,14 +892,15 @@ TclOONextToObjCmd( struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { - Tcl_AppendResult(interp, "method implementation by \"", - TclGetString(objv[1]), "\" not reachable from here", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method implementation by \"%s\" not reachable from here", + TclGetString(objv[1]))); return TCL_ERROR; } } - Tcl_AppendResult(interp, "method has no non-filter implementation by \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method has no non-filter implementation by \"%s\"", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -948,8 +960,9 @@ TclOOSelfObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -983,7 +996,8 @@ TclOOSelfObjCmd( Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; if (clsPtr == NULL) { - Tcl_AppendResult(interp, "method not defined by a class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method not defined by a class", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } @@ -1003,7 +1017,8 @@ TclOOSelfObjCmd( return TCL_OK; case SELF_FILTER: if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "not inside a filtering context", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { @@ -1028,7 +1043,8 @@ TclOOSelfObjCmd( case SELF_CALLER: if ((framePtr->callerVarPtr == NULL) || !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ - Tcl_AppendResult(interp, "caller is not an object", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "caller is not an object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } else { @@ -1045,7 +1061,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } @@ -1076,7 +1093,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } @@ -1093,7 +1111,8 @@ TclOOSelfObjCmd( return TCL_OK; case SELF_TARGET: if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "not inside a filtering context", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { @@ -1119,7 +1138,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } result[0] = TclOOObjectName(interp, declarerPtr); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 760bd7b..a79e4fa 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -4,7 +4,7 @@ * This file contains the method call chain management code for the * object-system core. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 6316303..58871c6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -100,13 +100,13 @@ TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); -typedef struct TclOOStubHooks { +typedef struct { const struct TclOOIntStubs *tclOOIntStubs; } TclOOStubHooks; typedef struct TclOOStubs { int magic; - const struct TclOOStubHooks *hooks; + const TclOOStubHooks *hooks; Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 0 */ Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 69cffb0..bacab38 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -423,8 +423,8 @@ RenameDeleteMethod( if (!useClass) { if (!oPtr->methodsPtr) { noSuchMethod: - Tcl_AppendResult(interp, "method ", TclGetString(fromPtr), - " does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method %s does not exist", TclGetString(fromPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(fromPtr), NULL); return TCL_ERROR; @@ -438,14 +438,15 @@ RenameDeleteMethod( &isNew); if (hPtr == newHPtr) { renameToSelf: - Tcl_AppendResult(interp, "cannot rename method to itself", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot rename method to itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); return TCL_ERROR; } else if (!isNew) { renameToExisting: - Tcl_AppendResult(interp, "method called ", - TclGetString(toPtr), " already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method called %s already exists", + TclGetString(toPtr))); Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL); return TCL_ERROR; } @@ -513,7 +514,8 @@ TclOOUnknownDefinition( const char *soughtStr, *matchedStr = NULL; if (objc < 2) { - Tcl_AppendResult(interp, "bad call of unknown handler", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad call of unknown handler", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL); return TCL_ERROR; } @@ -558,7 +560,8 @@ TclOOUnknownDefinition( } noMatch: - Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", soughtStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL); return TCL_ERROR; } @@ -646,9 +649,9 @@ InitDefineContext( int result; if (namespacePtr == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot process definitions; support namespace deleted", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -686,16 +689,17 @@ TclOOGetDefineCmdContext( if ((iPtr->varFramePtr == NULL) || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { - Tcl_AppendResult(interp, "this command may only be called from within" - " the context of an ::oo::define or ::oo::objdefine command", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command may only be called from within the context of" + " an ::oo::define or ::oo::objdefine command", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } object = iPtr->varFramePtr->clientData; if (Tcl_ObjectDeleted(object)) { - Tcl_AppendResult(interp, "this command cannot be called when the " - "object has been deleted", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command cannot be called when the object has been" + " deleted", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } @@ -736,7 +740,7 @@ GetClassInOuterContext( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(className), NULL); return NULL; @@ -816,8 +820,8 @@ TclOODefineObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, TclGetString(objv[1]), - " does not refer to a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to a class",TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -1161,14 +1165,14 @@ TclOODefineClassObjCmd( return TCL_ERROR; } if (oPtr->flags & ROOT_OBJECT) { - Tcl_AppendResult(interp, - "may not modify the class of the root object class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the root object class", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } if (oPtr->flags & ROOT_CLASS) { - Tcl_AppendResult(interp, - "may not modify the class of the class of classes", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the class of classes", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1194,9 +1198,10 @@ TclOODefineClassObjCmd( */ if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_AppendResult(interp, "may not change a ", - (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ", - (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "may not change a %sclass object into a %sclass object", + (oPtr->classPtr==NULL ? "non-" : ""), + (oPtr->classPtr==NULL ? "" : "non-"))); Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); return TCL_ERROR; } @@ -1317,7 +1322,8 @@ TclOODefineDeleteMethodObjCmd( return TCL_ERROR; } if (!isInstanceDeleteMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1440,7 +1446,8 @@ TclOODefineExportObjCmd( } clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1531,7 +1538,8 @@ TclOODefineForwardObjCmd( return TCL_ERROR; } if (!isInstanceForward && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1588,7 +1596,8 @@ TclOODefineMethodObjCmd( return TCL_ERROR; } if (!isInstanceMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1639,7 +1648,8 @@ TclOODefineMixinObjCmd( return TCL_ERROR; } if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1653,7 +1663,8 @@ TclOODefineMixinObjCmd( goto freeAndError; } if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } @@ -1704,7 +1715,8 @@ TclOODefineRenameMethodObjCmd( return TCL_ERROR; } if (!isInstanceRenameMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1764,7 +1776,8 @@ TclOODefineUnexportObjCmd( } clsPtr = oPtr->classPtr; if (!isInstanceUnexport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1949,7 +1962,8 @@ ClassFilterGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1984,7 +1998,8 @@ ClassFilterSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, @@ -2027,7 +2042,8 @@ ClassMixinGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -2065,7 +2081,8 @@ ClassMixinSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, @@ -2082,7 +2099,8 @@ ClassMixinSet( goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { - Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } @@ -2128,7 +2146,8 @@ ClassSuperGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -2165,12 +2184,13 @@ ClassSuperSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { - Tcl_AppendResult(interp, - "may not modify the superclass of the root object", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the superclass of the root object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, @@ -2196,15 +2216,15 @@ ClassSuperSet( } for (j=0 ; j<i ; j++) { if (superclasses[j] == superclasses[i]) { - Tcl_AppendResult(interp, - "class should only be a direct superclass once",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "class should only be a direct superclass once", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL); goto failedAfterAlloc; } } if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { - Tcl_AppendResult(interp, - "attempt to form circular dependency graph", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: ckfree((char *) superclasses); @@ -2265,7 +2285,8 @@ ClassVarsGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -2301,7 +2322,8 @@ ClassVarsSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, @@ -2313,15 +2335,16 @@ ClassVarsSet( const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not contain namespace separators", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not refer to an array element", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } @@ -2591,15 +2614,16 @@ ObjVarsSet( const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not contain namespace separators", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not refer to an array element", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index f298320..e09ee4e 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -43,47 +43,45 @@ static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; -struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; - /* * List of commands that are used to implement the [info object] subcommands. */ -static const struct NameProcMap infoObjectCmds[] = { - {"::oo::InfoObject::call", InfoObjectCallCmd}, - {"::oo::InfoObject::class", InfoObjectClassCmd}, - {"::oo::InfoObject::definition", InfoObjectDefnCmd}, - {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, - {"::oo::InfoObject::forward", InfoObjectForwardCmd}, - {"::oo::InfoObject::isa", InfoObjectIsACmd}, - {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, - {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd}, - {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, - {"::oo::InfoObject::namespace", InfoObjectNsCmd}, - {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, - {"::oo::InfoObject::vars", InfoObjectVarsCmd}, - {NULL, NULL} +static const EnsembleImplMap infoObjectCmds[] = { + {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0}, + {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0}, + {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0}, + {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0}, + {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, + {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0}, + {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0}, + {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0}, + {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0}, + {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* * List of commands that are used to implement the [info class] subcommands. */ -static const struct NameProcMap infoClassCmds[] = { - {"::oo::InfoClass::call", InfoClassCallCmd}, - {"::oo::InfoClass::constructor", InfoClassConstrCmd}, - {"::oo::InfoClass::definition", InfoClassDefnCmd}, - {"::oo::InfoClass::destructor", InfoClassDestrCmd}, - {"::oo::InfoClass::filters", InfoClassFiltersCmd}, - {"::oo::InfoClass::forward", InfoClassForwardCmd}, - {"::oo::InfoClass::instances", InfoClassInstancesCmd}, - {"::oo::InfoClass::methods", InfoClassMethodsCmd}, - {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd}, - {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, - {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, - {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, - {"::oo::InfoClass::variables", InfoClassVariablesCmd}, - {NULL, NULL} +static const EnsembleImplMap infoClassCmds[] = { + {"call", InfoClassCallCmd, NULL, NULL, NULL, 0}, + {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0}, + {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0}, + {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0}, + {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0}, + {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0}, + {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0}, + {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0}, + {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0}, + {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0}, + {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0}, + {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -101,33 +99,14 @@ void TclOOInitInfo( Tcl_Interp *interp) { - Tcl_Namespace *nsPtr; Tcl_Command infoCmd; - int i; - - /* - * Build the ensemble used to implement [info object]. - */ - - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoObjectCmds[i].name, - infoObjectCmds[i].proc, NULL, NULL); - } /* - * Build the ensemble used to implement [info class]. + * Build the ensembles used to implement [info object] and [info class]. */ - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoClassCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoClassCmds[i].name, - infoClassCmds[i].proc, NULL, NULL); - } + TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds); + TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* * Install into the master [info] ensemble. @@ -177,8 +156,8 @@ GetClassFromObj( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objPtr), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objPtr), NULL); return NULL; @@ -279,16 +258,16 @@ InfoObjectDefnCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -390,17 +369,17 @@ InfoObjectForwardCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -491,7 +470,8 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be mixins", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } else { @@ -516,7 +496,8 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be types", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be types", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } @@ -651,8 +632,8 @@ InfoObjectMethodTypeCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -878,8 +859,8 @@ InfoClassConstrCmd( } procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } @@ -937,16 +918,16 @@ InfoClassDefnCmd( } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1006,8 +987,8 @@ InfoClassDestrCmd( } procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } @@ -1085,17 +1066,17 @@ InfoClassForwardCmd( } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1269,8 +1250,8 @@ InfoClassMethodTypeCmd( hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1494,7 +1475,8 @@ InfoObjectCallCmd( contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, @@ -1538,7 +1520,8 @@ InfoClassCallCmd( callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); if (callPtr == NULL) { - Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 631961f..ab54964 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -4,7 +4,7 @@ * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2011 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index c751838..acafb18 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -90,7 +90,7 @@ TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, typedef struct TclOOIntStubs { int magic; - const struct TclOOIntStubHooks *hooks; + void *hooks; Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 877c3db..28820e0 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,7 +3,7 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1329,8 +1329,8 @@ TclOONewForwardInstanceMethod( return NULL; } if (prefixLen < 1) { - Tcl_AppendResult(interp, "method forward prefix must be non-empty", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method forward prefix must be non-empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } @@ -1371,8 +1371,8 @@ TclOONewForwardMethod( return NULL; } if (prefixLen < 1) { - Tcl_AppendResult(interp, "method forward prefix must be non-empty", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method forward prefix must be non-empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 3b6ce37..55f2378 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -53,8 +53,9 @@ TclOOInitializeStubs( if (clientData == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", - "package not present or incomplete", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s package; package not present or incomplete", + packageName)); return NULL; } else { const TclOOStubs * const stubsPtr = clientData; @@ -76,9 +77,9 @@ TclOOInitializeStubs( error: Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package", - " (requested version '", version, "', loaded version '", - actualVersion, "'): ", errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package" + " (requested version '%s', loaded version '%s'): %s", + packageName, version, actualVersion, errMsg)); return NULL; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index 099b67d..74cb29e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4462,11 +4462,8 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char refcountBuffer[TCL_INTEGER_SPACE+1]; - char objPtrBuffer[TCL_INTEGER_SPACE+3]; - char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2]; -#define TCLOBJ_TRUNCATE_STRINGREP 16 - char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1]; + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; + Tcl_Obj *descObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); @@ -4479,27 +4476,30 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - sprintf(refcountBuffer, "%d", objv[1]->refCount); - sprintf(objPtrBuffer, "%p", (void *)objv[1]); - Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ? - objv[1]->typePtr->name : "pure string", " with a refcount of ", - refcountBuffer, ", object pointer at ", objPtrBuffer, NULL); + sprintf(ptrBuffer, "%p", (void *) objv[1]); + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," + " object pointer at %s", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, ptrBuffer); + if (objv[1]->typePtr) { - sprintf(internalRepBuffer, "%p:%p", - (void *)objv[1]->internalRep.twoPtrValue.ptr1, - (void *)objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendResult(interp, ", internal representation ", - internalRepBuffer, NULL); + sprintf(ptrBuffer, "%p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + Tcl_AppendPrintfToObj(descObj, ", internal representation %s", + ptrBuffer); } + if (objv[1]->bytes) { - strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP); - stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0; - Tcl_AppendResult(interp, ", string representation \"", - stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ? - "\"..." : "\".", NULL); + Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, + 16, "..."); + Tcl_AppendToObj(descObj, "\"", -1); } else { - Tcl_AppendResult(interp, ", no string representation.", NULL); + Tcl_AppendToObj(descObj, ", no string representation", -1); } + + Tcl_SetObjResult(interp, descObj); return TCL_OK; } diff --git a/generic/tclParse.c b/generic/tclParse.c index f0050c6..309e232 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -258,7 +258,8 @@ Tcl_ParseCommand( if ((start == NULL) && (numBytes != 0)) { if (interp != NULL) { - Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't parse a NULL pointer", -1)); } return TCL_ERROR; } @@ -568,14 +569,14 @@ Tcl_ParseCommand( } if (src[-1] == '"') { if (interp != NULL) { - Tcl_SetResult(interp, "extra characters after close-quote", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); } parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; } else { if (interp != NULL) { - Tcl_SetResult(interp, "extra characters after close-brace", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); } parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; } @@ -1175,8 +1176,8 @@ ParseTokens( } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, - "missing close-bracket", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-bracket", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; @@ -1411,8 +1412,8 @@ Tcl_ParseVarName( } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, - "missing close-brace for variable name", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-brace for variable name", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; parsePtr->term = tokenPtr->start-1; @@ -1479,8 +1480,8 @@ Tcl_ParseVarName( } if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, "missing )", - TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing )", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_PAREN; parsePtr->term = src; @@ -1755,7 +1756,8 @@ Tcl_ParseBraces( goto error; } - Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-brace", -1)); /* * Guess if the problem is due to comments by searching the source string @@ -1777,8 +1779,8 @@ Tcl_ParseBraces( break; case '#' : if (openBrace && TclIsSpaceProc(src[-1])) { - Tcl_AppendResult(parsePtr->interp, - ": possible unbalanced brace in comment", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp), + ": possible unbalanced brace in comment", -1); goto error; } break; @@ -1857,7 +1859,8 @@ Tcl_ParseQuotedString( } if (*parsePtr->term != '"') { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing \"", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; parsePtr->term = start; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 8bae4fb..2b9ff87 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1492,9 +1492,8 @@ MakePathFromNormalized( if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object" - "string representation", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't find object string representation", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", NULL); } @@ -1765,7 +1764,7 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int cwdLen, pathType; + int tailLen, cwdLen, pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1777,7 +1776,12 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - copy = AppendPath(dir, fsPathPtr->normPathPtr); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + if (tailLen) { + copy = AppendPath(dir, fsPathPtr->normPathPtr); + } else { + copy = Tcl_DuplicateObj(dir); + } Tcl_IncrRefCount(dir); Tcl_IncrRefCount(copy); @@ -2368,9 +2372,9 @@ SetFsPathFromAny( dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment " - "variable to expand path", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "HOMELESS", NULL); } @@ -2387,9 +2391,8 @@ SetFsPathFromAny( Tcl_DStringInit(&temp); if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", name+1, - "\" doesn't exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", name+1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", NULL); } diff --git a/generic/tclPipe.c b/generic/tclPipe.c index d0b136d..83fb818 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -106,9 +106,10 @@ FileForRedirect( if (msg) { Tcl_SetObjResult(interp, msg); } else { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(chan), "\" wasn't opened for ", - ((writing) ? "writing" : "reading"), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for %s", + Tcl_GetChannelName(chan), + ((writing) ? "writing" : "reading"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADCHAN", NULL); } @@ -141,9 +142,10 @@ FileForRedirect( file = TclpOpenFile(name, flags); Tcl_DStringFree(&nameString); if (file == NULL) { - Tcl_AppendResult(interp, "couldn't ", - ((writing) ? "write" : "read"), " file \"", spec, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't %s file \"%s\": %s", + (writing ? "write" : "read"), spec, + Tcl_PosixError(interp))); return NULL; } *closePtr = 1; @@ -151,8 +153,8 @@ FileForRedirect( return file; badLastArg: - Tcl_AppendResult(interp, "can't specify \"", arg, - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't specify \"%s\" as last word in command", arg)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } @@ -304,8 +306,8 @@ TclCleanupChildren( msg = "child process lost (is SIGCHLD ignored or trapped?)"; } - Tcl_AppendResult(interp, "error waiting for process to exit: ", - msg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg)); } continue; } @@ -335,16 +337,17 @@ TclCleanupChildren( p = Tcl_SignalMsg(WTERMSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child killed: %s\n", p)); } else if (WIFSTOPPED(waitStatus)) { p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_AppendResult(interp, "child suspended: ", p, "\n", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child suspended: %s\n", p)); } else { - Tcl_AppendResult(interp, - "child wait status didn't make sense\n", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child wait status didn't make sense\n", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "ODDWAITRESULT", msg1, NULL); } @@ -374,8 +377,9 @@ TclCleanupChildren( result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading stderr output file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading stderr output file: %s", + Tcl_PosixError(interp))); } else if (count > 0) { anyErrorInfo = 1; Tcl_SetObjResult(interp, objPtr); @@ -393,7 +397,8 @@ TclCleanupChildren( */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { - Tcl_AppendResult(interp, "child process exited abnormally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child process exited abnormally", -1)); } return result; } @@ -542,8 +547,8 @@ TclCreatePipeline( } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { - Tcl_SetResult(interp, "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -570,8 +575,9 @@ TclCreatePipeline( if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { - Tcl_AppendResult(interp, "can't specify \"", argv[i], - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't specify \"%s\" as last word in command", + argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -680,8 +686,9 @@ TclCreatePipeline( */ if (i != argc-1) { - Tcl_AppendResult(interp, "must specify \"", argv[i], - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "must specify \"%s\" as last word in command", + argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -722,8 +729,8 @@ TclCreatePipeline( * We had a bar followed only by redirections. */ - Tcl_SetResult(interp, "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -739,9 +746,9 @@ TclCreatePipeline( inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create input file for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create input file for command: %s", + Tcl_PosixError(interp))); goto error; } inputClose = 1; @@ -752,9 +759,9 @@ TclCreatePipeline( */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { - Tcl_AppendResult(interp, - "couldn't create input pipe for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create input pipe for command: %s", + Tcl_PosixError(interp))); goto error; } inputClose = 1; @@ -781,9 +788,9 @@ TclCreatePipeline( */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { - Tcl_AppendResult(interp, - "couldn't create output pipe for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create output pipe for command: %s", + Tcl_PosixError(interp))); goto error; } outputClose = 1; @@ -821,9 +828,9 @@ TclCreatePipeline( errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create error file for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create error file for command: %s", + Tcl_PosixError(interp))); goto error; } *errFilePtr = errorFile; @@ -894,8 +901,8 @@ TclCreatePipeline( } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } } @@ -1074,15 +1081,17 @@ Tcl_OpenCommandChannel( if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { - Tcl_AppendResult(interp, "can't read output from command:" - " standard output was redirected", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't read output from command:" + " standard output was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { - Tcl_AppendResult(interp, "can't write input to command:" - " standard input was redirected", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't write input to command:" + " standard input was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADREDIRECT", NULL); goto error; @@ -1093,8 +1102,8 @@ Tcl_OpenCommandChannel( numPids, pidPtr); if (channel == NULL) { - Tcl_AppendResult(interp, "pipe for command could not be created", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "pipe for command could not be created", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 382ffe3..9b6e942 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -154,8 +154,9 @@ Tcl_PkgProvideEx( } return TCL_OK; } - Tcl_AppendResult(interp, "conflicting versions provided for package \"", - name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "conflicting versions provided for package \"%s\": %s, then %s", + name, pkgPtr->version, version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -284,9 +285,9 @@ Tcl_PkgRequireEx( */ tclEmptyStringRep = &tclEmptyString; - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not " - "compiled with stub support", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Cannot load package \"%s\" in standalone executable:" + " This package is not compiled with stub support", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -374,9 +375,10 @@ PkgRequireCore( */ if (pkgPtr->clientData != NULL) { - Tcl_AppendResult(interp, "circular package dependency: " - "attempt to provide ", name, " ", - (char *) pkgPtr->clientData, " requires ", name, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; @@ -494,10 +496,10 @@ PkgRequireCore( Tcl_ResetResult(interp); if (pkgPtr->version == NULL) { code = TCL_ERROR; - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, - " failed: no version of package ", name, - " provided", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", NULL); } else { @@ -517,11 +519,11 @@ PkgRequireCore( ckfree(vi); if (res != 0) { code = TCL_ERROR; - Tcl_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -530,10 +532,10 @@ PkgRequireCore( } else if (code != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "attempt to provide package ", name, - " ", versionToProvide, " failed: bad return code: ", - TclGetString(codePtr), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; @@ -591,13 +593,9 @@ PkgRequireCore( Tcl_DStringFree(&command); if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad return code: ", - TclGetString(codePtr), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", code)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } if (code == TCL_ERROR) { @@ -610,7 +608,8 @@ PkgRequireCore( } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; @@ -628,8 +627,9 @@ PkgRequireCore( ckfree(pkgVersionI); if (!satisfies) { - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -721,10 +721,11 @@ Tcl_PkgPresentEx( } if (version != NULL) { - Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s %s is not present", name, version)); } else { - Tcl_AppendResult(interp, "package ", name, " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s is not present", name)); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; @@ -850,7 +851,8 @@ Tcl_PackageObjCmd( if (res == 0){ if (objc == 4) { ckfree(argv3i); - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); @@ -955,7 +957,8 @@ Tcl_PackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPtr->version, -1)); } } return TCL_OK; @@ -1017,7 +1020,8 @@ Tcl_PackageObjCmd( if (objc == 2) { if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(iPtr->packageUnknown, -1)); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { @@ -1351,8 +1355,8 @@ CheckVersionAndConvert( error: ckfree(ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", string, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected version number but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1614,8 +1618,8 @@ CheckRequirement( * More dashes found after the first. This is wrong. */ - Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", - string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected versionMin-versionMax but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } @@ -1667,19 +1671,17 @@ AddRequirementsToResult( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + Tcl_Obj *result = Tcl_GetObjResult(interp); + int i, length; - for (i = 0; i < reqc; i++) { - int length; - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + for (i = 0; i < reqc; i++) { + const char *v = Tcl_GetStringFromObj(reqv[i], &length); - if ((length & 0x1) && (v[length/2] == '-') - && (strncmp(v, v+((length+1)/2), length/2) == 0)) { - Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); - } else { - Tcl_AppendResult(interp, " ", v, NULL); - } + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); + } else { + Tcl_AppendPrintfToObj(result, " %s", v); } } } @@ -1708,9 +1710,9 @@ AddRequirementsToDString( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + int i; + if (reqc > 0) { for (i = 0; i < reqc; i++) { TclDStringAppendLiteral(dsPtr, " "); TclDStringAppendObj(dsPtr, reqv[i]); diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 48ad390..e9b92fe 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -69,7 +69,7 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( typedef struct TclPlatStubs { int magic; - const struct TclPlatStubHooks *hooks; + void *hooks; #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 537008c..933e7d2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -152,22 +152,24 @@ Tcl_ProcObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": bad procedure name", + fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -518,16 +520,17 @@ TclCreateProc( } if (fieldCount > 2) { ckfree(fieldValues); - Tcl_AppendResult(interp, - "too many fields in argument specifier \"", - argArray[i], "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "too many fields in argument specifier \"%s\"", + argArray[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree(fieldValues); - Tcl_AppendResult(interp, "argument with no name", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; @@ -553,16 +556,18 @@ TclCreateProc( } while (*q != '\0'); q--; if (*q == ')') { /* We have an array element. */ - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], "\" is an array element", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is an array element", + fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], "\" is not a simple name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is not a simple name", + fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); @@ -767,8 +772,7 @@ TclGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -900,8 +904,7 @@ TclObjGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -1879,10 +1882,9 @@ InterpProcNR2( * transform to an error now. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((result == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invoked \"%s\" outside of a loop", + ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; @@ -1999,8 +2001,8 @@ TclProcCompileProc( if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "a precompiled script jumped interps", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; @@ -2932,8 +2934,8 @@ Tcl_DisassembleObjCmd( procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -2982,8 +2984,8 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -3017,16 +3019,16 @@ Tcl_DisassembleObjCmd( methodBody: if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", - TclGetString(objv[3]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "body not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "METHODTYPE", NULL); return TCL_ERROR; @@ -3061,7 +3063,8 @@ Tcl_DisassembleObjCmd( if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 53d7153..6c1dc08 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -714,14 +714,14 @@ TclRegError( int status) /* Status code to report. */ { char buf[100]; /* ample in practice */ - char cbuf[100]; /* lots in practice */ + char cbuf[TCL_INTEGER_SPACE]; size_t n; const char *p; Tcl_ResetResult(interp); n = TclReError(status, NULL, buf, sizeof(buf)); p = (n > sizeof(buf)) ? "..." : ""; - Tcl_AppendResult(interp, msg, buf, p, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p)); sprintf(cbuf, "%d", status); (void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf)); diff --git a/generic/tclResult.c b/generic/tclResult.c index 693c650..b8f9c92 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -812,9 +812,7 @@ Tcl_SetObjErrorCode( * * Tcl_GetErrorLine -- * - * Results: - * - * Side effects: + * Returns the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -831,9 +829,7 @@ Tcl_GetErrorLine( * * Tcl_SetErrorLine -- * - * Results: - * - * Side effects: + * Sets the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -980,7 +976,8 @@ TclProcessReturn( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], + &valuePtr); if (valuePtr != NULL) { int infoLen; @@ -991,7 +988,8 @@ TclProcessReturn( iPtr->flags |= ERR_ALREADY_LOGGED; } } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], + &valuePtr); if (valuePtr != NULL) { int len, valueObjc; Tcl_Obj **valueObjv; @@ -1004,26 +1002,36 @@ TclProcessReturn( Tcl_IncrRefCount(newObj); iPtr->errorStack = newObj; } + /* * List extraction done after duplication to avoid moving the rug * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { + + if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, + valueObjv); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], + &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", NULL); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], + &valuePtr); if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } @@ -1096,10 +1104,9 @@ TclMergeReturnOptions( * Value is not a legal dictionary. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", compare, - " value: expected dictionary but got \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s value: expected dictionary but got \"%s\"", + compare, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); goto error; @@ -1128,7 +1135,8 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if (valuePtr != NULL) { - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) { + if (TclGetCompletionCodeFromObj(interp, valuePtr, + &code) == TCL_ERROR) { goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); @@ -1146,10 +1154,9 @@ TclMergeReturnOptions( * Value is not a legal level. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -level value: " - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -level value: expected non-negative integer but got" + " \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); goto error; } @@ -1168,10 +1175,10 @@ TclMergeReturnOptions( /* * Value is not a list, which is illegal for -errorcode. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorcode value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -errorcode value: expected a list but got \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", NULL); goto error; @@ -1190,10 +1197,10 @@ TclMergeReturnOptions( /* * Value is not a list, which is illegal for -errorstack. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", TclGetString(valuePtr), - "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -errorstack value: expected a list but got \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); goto error; @@ -1202,10 +1209,10 @@ TclMergeReturnOptions( /* * Errorstack must always be an even-sized list */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "forbidden odd-sized list for -errorstack: \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); goto error; @@ -1307,7 +1314,8 @@ Tcl_GetReturnOptions( * * TclNoErrorStack -- * - * Removes the -errorstack entry from an options dict to avoid reference cycles + * Removes the -errorstack entry from an options dict to avoid reference + * cycles. * * Results: * The (unshared) argument options dict, modified in -place. @@ -1316,12 +1324,13 @@ Tcl_GetReturnOptions( */ Tcl_Obj * -TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options) +TclNoErrorStack( + Tcl_Interp *interp, + Tcl_Obj *options) { Tcl_Obj **keys = GetKeys(); Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); - return options; } @@ -1356,9 +1365,8 @@ Tcl_SetReturnOptions( Tcl_IncrRefCount(options); if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) || (objc % 2)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected dict but got \"", - TclGetString(options), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected dict but got \"%s\"", TclGetString(options))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, diff --git a/generic/tclScan.c b/generic/tclScan.c index d21bfaf..ef7eedf 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -261,6 +261,10 @@ ValidateFormat( int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; + Tcl_Obj *errorMsg; /* Place to build an error messages. Note that + * these are messy operations because we do + * not want to use the formatting engine; + * we're inside there! */ /* * Initialize an array that records the number of times a variable is @@ -328,9 +332,9 @@ ValidateFormat( gotSequential = 1; if (gotXpg) { mixedXPG: - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot mix \"%\" and \"%n$\" conversion specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); goto error; } @@ -375,9 +379,9 @@ ValidateFormat( switch (ch) { case 'c': if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "field width may not be specified in %c conversion", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } @@ -389,9 +393,11 @@ ValidateFormat( if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, - "field size modifier may not be specified in %", buf, - " conversion", NULL); + errorMsg = Tcl_NewStringObj( + "field size modifier may not be specified in %", -1); + Tcl_AppendToObj(errorMsg, buf, -1); + Tcl_AppendToObj(errorMsg, " conversion", -1); + Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); goto error; } @@ -409,8 +415,8 @@ ValidateFormat( break; case 'u': if (flags & SCAN_BIG) { - Tcl_SetResult(interp, - "unsigned bignum scans are invalid", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); goto error; } @@ -446,15 +452,18 @@ ValidateFormat( } break; badSet: - Tcl_SetResult(interp, "unmatched [ in format string", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched [ in format string", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad scan conversion character \"", buf, - "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); + errorMsg = Tcl_NewStringObj( + "bad scan conversion character \"", -1); + Tcl_AppendToObj(errorMsg, buf, -1); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -498,9 +507,9 @@ ValidateFormat( } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is assigned by multiple \"%n$\" conversion specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { @@ -509,9 +518,9 @@ ValidateFormat( * and/or numVars != 0), then too many vars were given */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is not assigned by any conversion specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } @@ -522,13 +531,13 @@ ValidateFormat( badIndex: if (gotXpg) { - Tcl_SetResult(interp, "\"%n$\" argument index out of range", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"%n$\" argument index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); } else { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "different numbers of variable names and field specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 87cd4eb..0bede56 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -53,6 +53,15 @@ static int TclSockMinimumBuffersOld(int sock, int size) } #endif + +#if defined(_WIN32) || defined(__CYGWIN__) +#undef TclWinNToHS +#define TclWinNToHS winNToHS +static unsigned short TclWinNToHS(unsigned short ns) { + return ntohs(ns); +} +#endif + #ifdef __WIN32__ # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 @@ -89,12 +98,6 @@ void *TclWinGetTclInstance() return hInstance; } -unsigned short -TclWinNToHS(unsigned short ns) -{ - return ntohs(ns); -} - int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) @@ -166,14 +169,6 @@ Tcl_WinTCharToUtf( string, len, dsPtr); } -#define TclMacOSXGetFileAttribute (int (*) (Tcl_Interp *, \ - int, Tcl_Obj *, Tcl_Obj **)) TclpCreateProcess -#define TclMacOSXMatchType (int (*) (Tcl_Interp *, const char *, \ - const char *, Tcl_StatBuf *, Tcl_GlobTypeData *)) TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*) (const void *)) TclpOpenFile -#define TclpLocaltime_unix (struct tm *(*) (const time_t *)) TclGetAndDetachPids -#define TclpGmtime_unix (struct tm *(*) (const time_t *)) TclpCloseFile - #else /* UNIX and MAC */ # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime @@ -470,7 +465,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 17 */ 0, /* 18 */ 0, /* 19 */ - 0, /* 20 */ + TclUnixOpenTemporaryFile, /* 20 */ 0, /* 21 */ 0, /* 22 */ 0, /* 23 */ @@ -534,7 +529,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ + TclUnixOpenTemporaryFile, /* 20 */ 0, /* 21 */ 0, /* 22 */ 0, /* 23 */ @@ -1292,6 +1287,7 @@ const TclStubs tclStubs = { Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ + Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 5337b99..484f851 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,11 +15,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS @@ -306,11 +301,8 @@ static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestfinexitObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -382,7 +374,8 @@ static Tcl_FSRenameFileProc TestReportRenameFile; static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; -static Tcl_FSLoadFileProc TestReportLoadFile; +static int TestReportLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); static Tcl_FSLinkProc TestReportLink; static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; @@ -415,7 +408,7 @@ static int TestInterpResolverCmd(ClientData clientData, #if defined(HAVE_CPUID) || defined(__WIN32__) static int TestcpuidCmd(ClientData dummy, Tcl_Interp* interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); #endif static const Tcl_Filesystem testReportingFilesystem = { @@ -447,7 +440,7 @@ static const Tcl_Filesystem testReportingFilesystem = { TestReportRenameFile, TestReportCopyDirectory, TestReportLstat, - TestReportLoadFile, + (Tcl_FSLoadFileProc *) TestReportLoadFile, NULL /* cwd */, TestReportChdir }; @@ -631,7 +624,6 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); @@ -863,6 +855,7 @@ TestasyncCmd( || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -871,6 +864,7 @@ TestasyncCmd( } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); + Tcl_MutexUnlock(&asyncTestMutex); return code; #ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { @@ -880,6 +874,7 @@ TestasyncCmd( if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -888,11 +883,13 @@ TestasyncCmd( INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } break; } } + Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, mark, or marklater", NULL); @@ -4540,47 +4537,6 @@ TestpanicCmd( return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * TestfinexitObjCmd -- - * - * Calls a variant of [exit] including the full finalization path. - * - * Results: - * Error, or doesn't return. - * - * Side effects: - * Exits application. - * - *---------------------------------------------------------------------- - */ - -static int -TestfinexitObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int value; - - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); - return TCL_ERROR; - } - - if (objc == 1) { - value = 0; - } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - Tcl_Finalize(); - TclpExit(value); - /*NOTREACHED*/ - return TCL_ERROR; /* Better not ever reach this! */ -} - static int TestfileCmd( ClientData dummy, /* Not used. */ diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 36adaad..6b17825 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -829,8 +829,9 @@ Tcl_AfterObjCmd( if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": must be cancel, idle, info, or an integer", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument \"%s\": must be" + " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", arg, NULL); return TCL_ERROR; @@ -968,8 +969,8 @@ Tcl_AfterObjCmd( if (afterPtr == NULL) { const char *eventStr = TclGetString(objv[2]); - Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "event \"%s\" doesn't exist", eventStr)); Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; } else { diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 4f6c3bf..ef22153 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -278,7 +278,7 @@ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); typedef struct TclTomMathStubs { int magic; - const struct TclTomMathStubHooks *hooks; + void *hooks; int (*tclBN_epoch) (void); /* 0 */ int (*tclBN_revision) (void); /* 1 */ diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index e7e4aea..a3bc4b3 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -73,10 +73,10 @@ TclTomMathInitializeStubs( tclTomMathStubsPtr = stubsPtr; return actualVersion; } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s (requested version %s, actual version %s): %s", + packageName, version, actualVersion, errMsg)); return NULL; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 529c38a..519f201 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -366,8 +366,9 @@ Tcl_TraceObjCmd( return TCL_OK; badVarOps: - Tcl_AppendResult(interp, "bad operations \"", flagOps, - "\": should be one or more of rwua", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad operations \"%s\": should be one or more of rwua", + flagOps)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); return TCL_ERROR; } @@ -434,9 +435,9 @@ TraceExecutionObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of enter, leave, enterstep, or leavestep", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " enter, leave, enterstep, or leavestep", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", NULL); return TCL_ERROR; @@ -677,8 +678,9 @@ TraceCommandObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of delete or rename", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " delete or rename", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", NULL); return TCL_ERROR; @@ -875,8 +877,9 @@ TraceVariableObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of array, read, unset, or write", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " array, read, unset, or write", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", NULL); return TCL_ERROR; @@ -2715,7 +2718,8 @@ TclCallVarTraces( if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); } else { - Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC); + Tcl_SetObjResult((Tcl_Interp *)iPtr, + Tcl_NewStringObj(result, -1)); } Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 2fabe58..5c88639 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -882,7 +882,7 @@ static const unsigned char groupMap[] = { 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, diff --git a/generic/tclUtf.c b/generic/tclUtf.c index f0d08e7..4b5b37b 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1516,6 +1516,9 @@ Tcl_UniCharIsSpace( if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { return isspace(UCHAR(ch)); /* INTL: ISO space */ + } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b + || (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) { + return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5c62cb7..0cbb7c9 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -26,9 +26,9 @@ static ProcessGlobalValue executableName = { }; /* - * The following values are used in the flags arguments of Tcl*Scan*Element and - * Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and TCL_DONT_QUOTE_HASH - * are defined in tcl.h, like so: + * The following values are used in the flags arguments of Tcl*Scan*Element + * and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and + * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so: * #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 @@ -54,8 +54,8 @@ static ProcessGlobalValue executableName = { * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * - * CONVERT_NONE The element needs no quoting. Its literal string - * is suitable as is. + * CONVERT_NONE The element needs no quoting. Its literal string is + * suitable as is. * CONVERT_BRACE The conversion should be enclosing the literal string * in braces. * CONVERT_ESCAPE The conversion should be using backslashes to escape @@ -63,19 +63,19 @@ static ProcessGlobalValue executableName = { * CONVERT_MASK A mask value used to extract the conversion mode from * the flags argument. * Also indicates a strange conversion mode where all - * special characters are escaped with backslashes - * *except for braces*. This is a strange and unnecessary + * special characters are escaped with backslashes + * *except for braces*. This is a strange and unnecessary * case, but it's part of the historical way in which - * lists have been formatted in Tcl. To experiment with + * lists have been formatted in Tcl. To experiment with * removing this case, set the value of COMPAT to 0. * - * One last flag value is used only by callers of TclScanElement(). The flag + * One last flag value is used only by callers of TclScanElement(). The flag * value produced by a call to Tcl*Scan*Element() will never leave this bit * set. * - * CONVERT_ANY The caller of TclScanElement() declares it can make - * no promise about what public flags will be passed to - * the matching call of TclConvertElement(). As such, + * CONVERT_ANY The caller of TclScanElement() declares it can make no + * promise about what public flags will be passed to the + * matching call of TclConvertElement(). As such, * TclScanElement() has to determine the worst case * destination buffer length over all possibilities, and * in other cases this means an overestimate of the @@ -129,17 +129,17 @@ const Tcl_ObjType tclEndOffsetType = { /* * * STRING REPRESENTATION OF LISTS * * * * - * The next several routines implement the conversions of strings to and - * from Tcl lists. To understand their operation, the rules of parsing - * and generating the string representation of lists must be known. Here - * we describe them in one place. + * The next several routines implement the conversions of strings to and from + * Tcl lists. To understand their operation, the rules of parsing and + * generating the string representation of lists must be known. Here we + * describe them in one place. * - * A list is made up of zero or more elements. Any string is a list if - * it is made up of alternating substrings of element-separating ASCII - * whitespace and properly formatted elements. + * A list is made up of zero or more elements. Any string is a list if it is + * made up of alternating substrings of element-separating ASCII whitespace + * and properly formatted elements. * - * The ASCII characters which can make up the whitespace between list - * elements are: + * The ASCII characters which can make up the whitespace between list elements + * are: * * \u0009 \t TAB * \u000A \n NEWLINE @@ -158,69 +158,68 @@ const Tcl_ObjType tclEndOffsetType = { * * Unlike command parsing, the BACKSLASH NEWLINE sequence is not * considered to be a whitespace character. * - * * Other Unicode whitespace characters (recognized by - * [string is space] or Tcl_UniCharIsSpace()) do not play any role - * as element separators in Tcl lists. + * * Other Unicode whitespace characters (recognized by [string is space] + * or Tcl_UniCharIsSpace()) do not play any role as element separators + * in Tcl lists. * * * The NUL byte ought not appear, as it is not in strings properly * encoded for Tcl, but if it is present, it is not treated as - * separating whitespace, or a string terminator. It is just - * another character in a list element. - * - * The interpretaton of a formatted substring as a list element follows - * rules similar to the parsing of the words of a command in a Tcl script. - * Backslash substitution plays a key role, and is defined exactly as it is - * in command parsing. The same routine, TclParseBackslash() is used in both - * command parsing and list parsing. - * - * NOTE: This means that if and when backslash substitution rules ever - * change for command parsing, the interpretation of strings as lists also - * changes. + * separating whitespace, or a string terminator. It is just another + * character in a list element. + * + * The interpretaton of a formatted substring as a list element follows rules + * similar to the parsing of the words of a command in a Tcl script. Backslash + * substitution plays a key role, and is defined exactly as it is in command + * parsing. The same routine, TclParseBackslash() is used in both command + * parsing and list parsing. + * + * NOTE: This means that if and when backslash substitution rules ever change + * for command parsing, the interpretation of strings as lists also changes. * * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH - * with a single character. The one character escape sequent case happens - * only when BACKSLASH is the last character in the string. In all other - * cases, the escape sequence is at least two characters long. + * with a single character. The one character escape sequent case happens only + * when BACKSLASH is the last character in the string. In all other cases, the + * escape sequence is at least two characters long. * - * The formatted substrings are interpreted as element values according to - * the following cases: + * The formatted substrings are interpreted as element values according to the + * following cases: * * * If the first character of a formatted substring is * \u007b { OPEN BRACE * then the end of the substring is the matching * \u007d } CLOSE BRACE - * character, where matching is determined by counting nesting levels, - * and not including any brace characters that are contained within a - * backslash escape sequence in the nesting count. Having found the - * matching brace, all characters between the braces are the string - * value of the element. If no matching close brace is found before the - * end of the string, the string is not a Tcl list. If the character - * following the close brace is not an element separating whitespace - * character, or the end of the string, then the string is not a Tcl list. - * - * NOTE: this differs from a brace-quoted word in the parsing of a - * Tcl command only in its treatment of the backslash-newline sequence. - * In a list element, the literal characters in the backslash-newline - * sequence become part of the element value. In a script word, - * conversion to a single SPACE character is done. + * character, where matching is determined by counting nesting levels, and + * not including any brace characters that are contained within a backslash + * escape sequence in the nesting count. Having found the matching brace, + * all characters between the braces are the string value of the element. + * If no matching close brace is found before the end of the string, the + * string is not a Tcl list. If the character following the close brace is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. + * + * NOTE: this differs from a brace-quoted word in the parsing of a Tcl + * command only in its treatment of the backslash-newline sequence. In a + * list element, the literal characters in the backslash-newline sequence + * become part of the element value. In a script word, conversion to a + * single SPACE character is done. * * NOTE: Most list element values can be represented by a formatted - * substring using brace quoting. The exceptions are any element value - * that includes an unbalanced brace not in a backslash escape sequence, - * and any value that ends with a backslash not itself in a backslash - * escape sequence. + * substring using brace quoting. The exceptions are any element value that + * includes an unbalanced brace not in a backslash escape sequence, and any + * value that ends with a backslash not itself in a backslash escape + * sequence. * * * If the first character of a formatted substring is * \u0022 " QUOTE * then the end of the substring is the next QUOTE character, not counting * any QUOTE characters that are contained within a backslash escape - * sequence. If no next QUOTE is found before the end of the string, the - * string is not a Tcl list. If the character following the closing QUOTE - * is not an element separating whitespace character, or the end of the - * string, then the string is not a Tcl list. Having found the limits - * of the substring, the element value is produced by performing backslash + * sequence. If no next QUOTE is found before the end of the string, the + * string is not a Tcl list. If the character following the closing QUOTE is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. Having found the limits of the + * substring, the element value is produced by performing backslash * substitution on the character sequence between the open and close QUOTEs. * * NOTE: Any element value can be represented by this style of formatting, @@ -231,7 +230,7 @@ const Tcl_ObjType tclEndOffsetType = { * of the substring, the element value is produced by performing backslash * substitution on it. * - * NOTE: Any element value can be represented by this style of formatting, + * NOTE: Any element value can be represented by this style of formatting, * given suitable choice of backslash escape sequences, with one exception. * The empty string cannot be represented as a list element without the use * of either braces or quotes to delimit it. @@ -239,32 +238,32 @@ const Tcl_ObjType tclEndOffsetType = { * This collection of parsing rules is implemented in the routine * TclFindElement(). * - * In order to produce lists that can be parsed by these rules, we need - * the ability to distinguish between characters that are part of a list - * element value from characters providing syntax that define the structure - * of the list. This means that our code that generates lists must at a - * minimum be able to produce escape sequences for the 10 characters - * identified above that have significance to a list parser. + * In order to produce lists that can be parsed by these rules, we need the + * ability to distinguish between characters that are part of a list element + * value from characters providing syntax that define the structure of the + * list. This means that our code that generates lists must at a minimum be + * able to produce escape sequences for the 10 characters identified above + * that have significance to a list parser. * - * * * CANONICAL LISTS * * * * * + * * * CANONICAL LISTS * * * * * * * In addition to the basic rules for parsing strings into Tcl lists, there * are additional properties to be met by the set of list values that are * generated by Tcl. Such list values are often said to be in "canonical * form": * - * * When any canonical list is evaluated as a Tcl script, it is a script - * of either zero commands (an empty list) or exactly one command. The - * command word is exactly the first element of the list, and each argument - * word is exactly one of the following elements of the list. This means - * that any characters that have special meaning during script evaluation - * need special treatment when canonical lists are produced: + * * When any canonical list is evaluated as a Tcl script, it is a script of + * either zero commands (an empty list) or exactly one command. The command + * word is exactly the first element of the list, and each argument word is + * exactly one of the following elements of the list. This means that any + * characters that have special meaning during script evaluation need + * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON - * must be BRACEd, QUOTEd, or escaped so that it does not terminate - * the command prematurely. + * must be BRACEd, QUOTEd, or escaped so that it does not terminate the + * command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET @@ -274,11 +273,10 @@ const Tcl_ObjType tclEndOffsetType = { * \u0023 # HASH * that HASH character must be BRACEd, QUOTEd, or escaped so that it * does not convert the command into a comment. - * * Any list element that contains the character sequence - * BACKSLASH NEWLINE cannot be formatted with BRACEs. The - * BACKSLASH character must be represented by an escape - * sequence, and unless QUOTEs are used, the NEWLINE must - * be as well. + * * Any list element that contains the character sequence BACKSLASH + * NEWLINE cannot be formatted with BRACEs. The BACKSLASH character + * must be represented by an escape sequence, and unless QUOTEs are + * used, the NEWLINE must be as well. * * * It is also guaranteed that one can use a canonical list as a building * block of a larger script within command substitution, as in this example: @@ -289,66 +287,66 @@ const Tcl_ObjType tclEndOffsetType = { * * * Finally it is guaranteed that enclosing a canonical list in braces * produces a new value that is also a canonical list. This new list has - * length 1, and its only element is the original canonical list. This - * same guarantee also makes it possible to construct scripts where an - * argument word is given a list value by enclosing the canonical form - * of that list in braces: + * length 1, and its only element is the original canonical list. This same + * guarantee also makes it possible to construct scripts where an argument + * word is given a list value by enclosing the canonical form of that list + * in braces: * set script "puts {[list $one $two $three]}"; eval $script * This sort of coding was once fairly common, though it's become more * idiomatic to see the following instead: * set script [list puts [list $one $two $three]]; eval $script - * In order to support this guarantee, every canonical list must have + * In order to support this guarantee, every canonical list must have * balance when counting those braces that are not in escape sequences. * * Within these constraints, the canonical list generation routines - * TclScanElement() and TclConvertElement() attempt to generate the string - * for any list that is easiest to read. When an element value is itself + * TclScanElement() and TclConvertElement() attempt to generate the string for + * any list that is easiest to read. When an element value is itself * acceptable as the formatted substring, it is usually used (CONVERT_NONE). - * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) - * is usually preferred over the use of escape sequences (CONVERT_ESCAPE). - * There are some exceptions to both of these preferences for reasons of - * code simplicity, efficiency, and continuation of historical habits. - * Canonical lists never use the QUOTE formatting to delimit their elements - * because that form of quoting does not nest, which makes construction of - * nested lists far too much trouble. Canonical lists always use only a - * single SPACE character for element-separating whitespace. + * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is + * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There + * are some exceptions to both of these preferences for reasons of code + * simplicity, efficiency, and continuation of historical habits. Canonical + * lists never use the QUOTE formatting to delimit their elements because that + * form of quoting does not nest, which makes construction of nested lists far + * too much trouble. Canonical lists always use only a single SPACE character + * for element-separating whitespace. * * * * FUTURE CONSIDERATIONS * * * * * When a list element requires quoting or escaping due to a CLOSE BRACKET * character or an internal QUOTE character, a strange formatting mode is - * recommended. For example, if the value "a{b]c}d" is converted by the - * usual modes: + * recommended. For example, if the value "a{b]c}d" is converted by the usual + * modes: * * CONVERT_BRACE: a{b]c}d => {a{b]c}d} * CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d * - * we get perfectly usable formatted list elements. However, this is not - * what Tcl releases have been producing. Instead, we have: + * we get perfectly usable formatted list elements. However, this is not what + * Tcl releases have been producing. Instead, we have: * * CONVERT_MASK: a{b]c}d => a{b\]c}d * - * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same - * effect can be seen replacing ] with " in this example. There does not - * appear to be any functional or aesthetic purpose for this strange - * additional mode. The sole purpose I can see for preserving it is to - * keep generating the same formatted lists programmers have become accustomed - * to, and perhaps written tests to expect. That is, compatibility only. - * The additional code complexity required to support this mode is significant. - * The lines of code supporting it are delimited in the routines below with - * #if COMPAT directives. This makes it easy to experiment with eliminating - * this formatting mode simply with "#define COMPAT 0" above. I believe - * this is worth considering. + * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect + * can be seen replacing ] with " in this example. There does not appear to be + * any functional or aesthetic purpose for this strange additional mode. The + * sole purpose I can see for preserving it is to keep generating the same + * formatted lists programmers have become accustomed to, and perhaps written + * tests to expect. That is, compatibility only. The additional code + * complexity required to support this mode is significant. The lines of code + * supporting it are delimited in the routines below with #if COMPAT + * directives. This makes it easy to experiment with eliminating this + * formatting mode simply with "#define COMPAT 0" above. I believe this is + * worth considering. * - * Another consideration is the treatment of QUOTE characters in list elements. - * TclConvertElement() must have the ability to produce the escape sequence - * \" so that when a list element begins with a QUOTE we do not confuse - * that first character with a QUOTE used as list syntax to define list - * structure. However, that is the only place where QUOTE characters need - * quoting. In this way, handling QUOTE could really be much more like - * the way we handle HASH which also needs quoting and escaping only in - * particular situations. Following up this could increase the set of - * list elements that can use the CONVERT_NONE formatting mode. + * Another consideration is the treatment of QUOTE characters in list + * elements. TclConvertElement() must have the ability to produce the escape + * sequence \" so that when a list element begins with a QUOTE we do not + * confuse that first character with a QUOTE used as list syntax to define + * list structure. However, that is the only place where QUOTE characters need + * quoting. In this way, handling QUOTE could really be much more like the way + * we handle HASH which also needs quoting and escaping only in particular + * situations. Following up this could increase the set of list elements that + * can use the CONVERT_NONE formatting mode. * * More speculative is that the demands of canonical list form require brace * balance for the list as a whole, while the current implementation achieves @@ -366,15 +364,15 @@ const Tcl_ObjType tclEndOffsetType = { * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. - * Not a full list parser. Typically used to get a quick and dirty - * overestimate of length size in order to allocate space for an - * actual list parser to operate with. + * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a + * full list parser. Typically used to get a quick and dirty overestimate + * of length size in order to allocate space for an actual list parser to + * operate with. * * Results: - * Returns the largest number of list elements that could possibly - * be in this string, interpreted as a Tcl list. If 'endPtr' is not - * NULL, writes a pointer to the end of the string scanned there. + * Returns the largest number of list elements that could possibly be in + * this string, interpreted as a Tcl list. If 'endPtr' is not NULL, + * writes a pointer to the end of the string scanned there. * * Side effects: * None. @@ -395,16 +393,25 @@ TclMaxListLength( goto done; } - /* No list element before leading white space */ + /* + * No list element before leading white space. + */ + count += 1 - TclIsSpaceProc(*bytes); - /* Count white space runs as potential element separators */ + /* + * Count white space runs as potential element separators. + */ + while (numBytes) { if ((numBytes == -1) && (*bytes == '\0')) { break; } if (TclIsSpaceProc(*bytes)) { - /* Space run started; bump count */ + /* + * Space run started; bump count. + */ + count++; do { bytes++; @@ -413,16 +420,22 @@ TclMaxListLength( if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { break; } - /* (*bytes) is non-space; return to counting state */ + + /* + * (*bytes) is non-space; return to counting state. + */ } bytes++; numBytes -= (numBytes != -1); } - /* No list element following trailing white space */ + /* + * No list element following trailing white space. + */ + count -= TclIsSpaceProc(bytes[-1]); - done: + done: if (endPtr) { *endPtr = bytes; } @@ -449,18 +462,18 @@ TclMaxListLength( * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, - * *sizePtr is filled in with the number of bytes in the element. If - * the element is in braces, then *elementPtr will point to the character + * *sizePtr is filled in with the number of bytes in the element. If the + * element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, * and both *elementPtr and *nextPtr will point just after the last * character in the list. If literalPtr is non-NULL, *literalPtr is set - * to a boolean value indicating whether the substring returned as - * the values of **elementPtr and *sizePtr is the literal value of - * a list element. If not, a call to TclCopyAndCollapse() is needed - * to produce the actual value of the list element. Note: this function - * does NOT collapse backslash sequences, but uses *literalPtr to tell - * callers when it is required for them to do so. + * to a boolean value indicating whether the substring returned as the + * values of **elementPtr and *sizePtr is the literal value of a list + * element. If not, a call to TclCopyAndCollapse() is needed to produce + * the actual value of the list element. Note: this function does NOT + * collapse backslash sequences, but uses *literalPtr to tell callers + * when it is required for them to do so. * * Side effects: * None. @@ -587,9 +600,10 @@ TclFindElement( /* * A backslash sequence not within a brace quoted element * means the value of the element is different from the - * substring we are parsing. A call to TclCopyAndCollapse() - * is needed to produce the element value. Inform the caller. + * substring we are parsing. A call to TclCopyAndCollapse() is + * needed to produce the element value. Inform the caller. */ + literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); @@ -655,16 +669,16 @@ TclFindElement( if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open brace in list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open brace in list", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open quote in list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open quote in list", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", NULL); } @@ -697,9 +711,9 @@ TclFindElement( * * Results: * Count bytes get copied from src to dst. Along the way, backslash - * sequences are substituted in the copy. After scanning count bytes - * from src, a null character is placed at the end of dst. Returns - * the number of bytes that got written to dst. + * sequences are substituted in the copy. After scanning count bytes from + * src, a null character is placed at the end of dst. Returns the number + * of bytes that got written to dst. * * Side effects: * None. @@ -717,6 +731,7 @@ TclCopyAndCollapse( while (count > 0) { char c = *src; + if (c == '\\') { int numRead; int backslashCount = TclParseBackslash(src, count, &numRead, dst); @@ -780,12 +795,11 @@ Tcl_SplitList( int length, size, i, result, elSize; /* - * Allocate enough space to work in. A (const char *) for each - * (possible) list element plus one more for terminating NULL, - * plus as many bytes as in the original string value, plus one - * more for a terminating '\0'. Space used to hold element separating - * white space in the original string gets re-purposed to hold '\0' - * characters in the argv array. + * Allocate enough space to work in. A (const char *) for each (possible) + * list element plus one more for terminating NULL, plus as many bytes as + * in the original string value, plus one more for a terminating '\0'. + * Space used to hold element separating white space in the original + * string gets re-purposed to hold '\0' characters in the argv array. */ size = TclMaxListLength(list, -1, &end) + 1; @@ -810,8 +824,8 @@ Tcl_SplitList( if (i >= size) { ckfree(argv); if (interp != NULL) { - Tcl_SetResult(interp, "internal error in Tcl_SplitList", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "internal error in Tcl_SplitList", -1)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); } @@ -844,9 +858,9 @@ Tcl_SplitList( * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of bytes that - * will be needed by Tcl_ConvertElement to produce a valid list element - * from src. The word at *flagPtr is filled in with a value needed by + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertElement to produce a valid list element from + * src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: @@ -876,10 +890,10 @@ Tcl_ScanElement( * to the first null byte. * * Results: - * The return value is an overestimate of the number of bytes that - * will be needed by Tcl_ConvertCountedElement to produce a valid list - * element from src. The word at *flagPtr is filled in with a value - * needed by Tcl_ConvertCountedElement when doing the actual conversion. + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertCountedElement to produce a valid list element + * from src. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. @@ -906,24 +920,24 @@ Tcl_ScanCountedElement( * * TclScanElement -- * - * This function is a companion function to TclConvertElement. It - * scans a string to see what needs to be done to it (e.g. add - * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned from src up - * to the first null byte. A NULL value for src is treated as an - * empty string. The incoming value of *flagPtr is a report from the - * caller what additional flags it will pass to TclConvertElement(). + * This function is a companion function to TclConvertElement. It scans a + * string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. If + * length is -1, then the string is scanned from src up to the first null + * byte. A NULL value for src is treated as an empty string. The incoming + * value of *flagPtr is a report from the caller what additional flags it + * will pass to TclConvertElement(). * * Results: - * The recommended formatting mode for the element is determined and - * a value is written to *flagPtr indicating that recommendation. This + * The recommended formatting mode for the element is determined and a + * value is written to *flagPtr indicating that recommendation. This * recommendation is combined with the incoming flag values in *flagPtr * set by the caller to determine how many bytes will be needed by * TclConvertElement() in which to write the formatted element following - * the recommendation modified by the flag values. This number of bytes - * is the return value of the routine. In some situations it may be - * an overestimate, but so long as the caller passes the same flags - * to TclConvertElement(), it will be large enough. + * the recommendation modified by the flag values. This number of bytes + * is the return value of the routine. In some situations it may be an + * overestimate, but so long as the caller passes the same flags to + * TclConvertElement(), it will be large enough. * * Side effects: * None. @@ -941,7 +955,7 @@ TclScanElement( const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something - needs protection or escape. */ + * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some * reason bare or brace-quoted form fails. */ int extra = 0; /* Count of number of extra bytes needed for @@ -953,10 +967,13 @@ TclScanElement( int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ -#endif +#endif /* COMPAT */ if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { - /* Empty string element must be brace quoted. */ + /* + * Empty string element must be brace quoted. + */ + *flagPtr = CONVERT_BRACE; return 2; } @@ -966,10 +983,11 @@ TclScanElement( * Must escape or protect so leading character of value is not * misinterpreted as list element delimiting syntax. */ + forbidNone = 1; #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ } while (length) { @@ -978,18 +996,21 @@ TclScanElement( case '{': /* TYPE_BRACE */ #if COMPAT braceCount++; -#endif +#endif /* COMPAT */ extra++; /* Escape '{' => '\{' */ nestingLevel++; break; case '}': /* TYPE_BRACE */ #if COMPAT braceCount++; -#endif +#endif /* COMPAT */ extra++; /* Escape '}' => '\}' */ nestingLevel--; if (nestingLevel < 0) { - /* Unbalanced braces! Cannot format with brace quoting. */ + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + requireEscape = 1; } break; @@ -1002,7 +1023,7 @@ TclScanElement( break; #else /* FLOW THROUGH */ -#endif +#endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ @@ -1016,18 +1037,25 @@ TclScanElement( extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { - /* Final backslash. Cannot format with brace quoting. */ + /* + * Final backslash. Cannot format with brace quoting. + */ + requireEscape = 1; break; } if (p[1] == '\n') { extra++; /* Escape newline => '\n', one byte longer */ - /* Backslash newline sequence. Brace quoting not permitted. */ + + /* + * Backslash newline sequence. Brace quoting not permitted. + */ + requireEscape = 1; length -= (length > 0); p++; @@ -1041,7 +1069,7 @@ TclScanElement( forbidNone = 1; #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ if (length == -1) { @@ -1055,22 +1083,33 @@ TclScanElement( p++; } - endOfString: + endOfString: if (nestingLevel != 0) { - /* Unbalanced braces! Cannot format with brace quoting. */ + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + requireEscape = 1; } - /* We need at least as many bytes as are in the element value... */ + /* + * We need at least as many bytes as are in the element value... + */ + bytesNeeded = p - src; if (requireEscape) { /* - * We must use escape sequences. Add all the extra bytes needed - * to have room to create them. + * We must use escape sequences. Add all the extra bytes needed to + * have room to create them. */ + bytesNeeded += extra; - /* Make room to escape leading #, if needed. */ + + /* + * Make room to escape leading #, if needed. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } @@ -1080,12 +1119,13 @@ TclScanElement( if (*flagPtr & CONVERT_ANY) { /* * The caller has not let us know what flags it will pass to - * TclConvertElement() so compute the max size we might need for - * any possible choice. Normally the formatting using escape - * sequences is the longer one, and a minimum "extra" value of 2 - * makes sure we don't request too small a buffer in those edge - * cases where that's not true. + * TclConvertElement() so compute the max size we might need for any + * possible choice. Normally the formatting using escape sequences is + * the longer one, and a minimum "extra" value of 2 makes sure we + * don't request too small a buffer in those edge cases where that's + * not true. */ + if (extra < 2) { extra = 2; } @@ -1093,59 +1133,78 @@ TclScanElement( *flagPtr |= TCL_DONT_USE_BRACES; } if (forbidNone) { - /* We must request some form of quoting of escaping... */ + /* + * We must request some form of quoting of escaping... + */ + #if COMPAT if (preferEscape && !preferBrace) { /* - * If we are quoting solely due to ] or internal " characters - * use the CONVERT_MASK mode where we escape all special - * characters except for braces. "extra" counted space needed - * to escape braces too, so substract "braceCount" to get our - * actual needs. + * If we are quoting solely due to ] or internal " characters use + * the CONVERT_MASK mode where we escape all special characters + * except for braces. "extra" counted space needed to escape + * braces too, so substract "braceCount" to get our actual needs. */ + bytesNeeded += (extra - braceCount); /* Make room to escape leading #, if needed. */ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } + /* * If the caller reports it will direct TclConvertElement() to * use full escapes on the element, add back the bytes needed to * escape the braces. */ + if (*flagPtr & TCL_DONT_USE_BRACES) { bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; goto overflowCheck; } -#endif +#endif /* COMPAT */ if (*flagPtr & TCL_DONT_USE_BRACES) { /* * If the caller reports it will direct TclConvertElement() to * use escapes, add the extra bytes needed to have room for them. */ + bytesNeeded += extra; - /* Make room to escape leading #, if needed. */ + + /* + * Make room to escape leading #, if needed. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } } else { - /* Add 2 bytes for room for the enclosing braces. */ + /* + * Add 2 bytes for room for the enclosing braces. + */ + bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; goto overflowCheck; } - /* So far, no need to quote or escape anything. */ + /* + * So far, no need to quote or escape anything. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { - /* If we need to quote a leading #, make room to enclose in braces. */ + /* + * If we need to quote a leading #, make room to enclose in braces. + */ + bytesNeeded += 2; } *flagPtr = CONVERT_NONE; - overflowCheck: + overflowCheck: if (bytesNeeded < 0) { Tcl_Panic("TclScanElement: string length overflow"); } @@ -1220,9 +1279,9 @@ Tcl_ConvertCountedElement( * * TclConvertElement -- * - * This is a companion function to TclScanElement. Given the - * information produced by TclScanElement, this function converts - * a string to a list element equal to that string. + * This is a companion function to TclScanElement. Given the information + * produced by TclScanElement, this function converts a string to a list + * element equal to that string. * * Results: * Information is copied to *dst in the form of a list element identical @@ -1236,7 +1295,8 @@ Tcl_ConvertCountedElement( *---------------------------------------------------------------------- */ -int TclConvertElement( +int +TclConvertElement( register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ @@ -1245,19 +1305,28 @@ int TclConvertElement( int conversion = flags & CONVERT_MASK; char *p = dst; - /* Let the caller demand we use escape sequences rather than braces. */ + /* + * Let the caller demand we use escape sequences rather than braces. + */ + if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { conversion = CONVERT_ESCAPE; } - /* No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || ((*src == '\0') && (length == -1))) { + /* + * No matter what the caller demands, empty string must be braced! + */ + + if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { src = tclEmptyStringRep; length = 0; conversion = CONVERT_BRACE; } - /* Escape leading hash as needed and requested. */ + /* + * Escape leading hash as needed and requested. + */ + if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { if (conversion == CONVERT_ESCAPE) { p[0] = '\\'; @@ -1270,7 +1339,10 @@ int TclConvertElement( } } - /* No escape or quoting needed. Copy the literal string value. */ + /* + * No escape or quoting needed. Copy the literal string value. + */ + if (conversion == CONVERT_NONE) { if (length == -1) { /* TODO: INT_MAX overflow? */ @@ -1284,7 +1356,10 @@ int TclConvertElement( } } - /* Formatted string is original string enclosed in braces. */ + /* + * Formatted string is original string enclosed in braces. + */ + if (conversion == CONVERT_BRACE) { *p = '{'; p++; @@ -1304,7 +1379,10 @@ int TclConvertElement( /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ - /* Formatted string is original string converted to escape sequences. */ + /* + * Formatted string is original string converted to escape sequences. + */ + for ( ; length; src++, length -= (length > 0)) { switch (*src) { case ']': @@ -1320,13 +1398,12 @@ int TclConvertElement( case '{': case '}': #if COMPAT - if (conversion == CONVERT_ESCAPE) { -#endif + if (conversion == CONVERT_ESCAPE) +#endif /* COMPAT */ + { *p = '\\'; p++; -#if COMPAT } -#endif break; case '\f': *p = '\\'; @@ -1362,13 +1439,15 @@ int TclConvertElement( if (length == -1) { return p - dst; } + /* - * If we reach this point, there's an embedded NULL in the - * string range being processed, which should not happen when - * the encoding rules for Tcl strings are properly followed. - * If the day ever comes when we stop tolerating such things, - * this is where to put the Tcl_Panic(). + * If we reach this point, there's an embedded NULL in the string + * range being processed, which should not happen when the + * encoding rules for Tcl strings are properly followed. If the + * day ever comes when we stop tolerating such things, this is + * where to put the Tcl_Panic(). */ + break; } *p = *src; @@ -1402,17 +1481,18 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -# define LOCAL_SIZE 20 +#define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; const int maxFlags = UINT_MAX / sizeof(int); + /* + * Handle empty list case first, so logic of the general case can be + * simpler. + */ + if (argc == 0) { - /* - * Handle empty list case first, so logic of the general case - * can be simpler. - */ result = ckalloc(1); result[0] = '\0'; return result; @@ -1426,17 +1506,17 @@ Tcl_Merge( flagPtr = localFlags; } else if (argc > maxFlags) { /* - * We cannot allocate a large enough flag array to format this - * list in one pass. We could imagine converting this routine - * to a multi-pass implementation, but for sizeof(int) == 4, - * the limit is a max of 2^30 list elements and since each element - * is at least one byte formatted, and requires one byte space - * between it and the next one, that a minimum space requirement - * of 2^31 bytes, which is already INT_MAX. If we tried to format - * a list of > maxFlags elements, we're just going to overflow - * the size limits on the formatted string anyway, so just issue - * that same panic early. + * We cannot allocate a large enough flag array to format this list in + * one pass. We could imagine converting this routine to a multi-pass + * implementation, but for sizeof(int) == 4, the limit is a max of + * 2^30 list elements and since each element is at least one byte + * formatted, and requires one byte space between it and the next one, + * that a minimum space requirement of 2^31 bytes, which is already + * INT_MAX. If we tried to format a list of > maxFlags elements, we're + * just going to overflow the size limits on the formatted string + * anyway, so just issue that same panic early. */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { flagPtr = ckalloc(argc * sizeof(int)); @@ -1511,9 +1591,10 @@ Tcl_Backslash( *---------------------------------------------------------------------- * * TclTrimRight -- - * Takes two counted strings in the Tcl encoding which must both be - * null terminated. Conceptually trims from the right side of the - * first string all characters found in the second string. + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the right side of the first string + * all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. @@ -1526,10 +1607,10 @@ Tcl_Backslash( int TclTrimRight( - const char *bytes, /* String to be trimmed... */ - int numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - int numTrim) /* ...and its length in bytes */ + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ { const char *p = bytes + numBytes; int pInc; @@ -1538,12 +1619,18 @@ TclTrimRight( Tcl_Panic("TclTrimRight works only on null-terminated strings"); } - /* Empty strings -> nothing to do */ + /* + * Empty strings -> nothing to do. + */ + if ((numBytes == 0) || (numTrim == 0)) { return 0; } - /* Outer loop: iterate over string to be trimmed */ + /* + * Outer loop: iterate over string to be trimmed. + */ + do { Tcl_UniChar ch1; const char *q = trim; @@ -1552,7 +1639,10 @@ TclTrimRight( p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); - /* Inner loop: scan trim string for match to current character */ + /* + * Inner loop: scan trim string for match to current character. + */ + do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); @@ -1566,7 +1656,10 @@ TclTrimRight( } while (bytesLeft); if (bytesLeft == 0) { - /* No match; trim task done; *p is last non-trimmed char */ + /* + * No match; trim task done; *p is last non-trimmed char. + */ + p += pInc; break; } @@ -1579,9 +1672,10 @@ TclTrimRight( *---------------------------------------------------------------------- * * TclTrimLeft -- - * Takes two counted strings in the Tcl encoding which must both be - * null terminated. Conceptually trims from the left side of the - * first string all characters found in the second string. + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the left side of the first string + * all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. @@ -1594,10 +1688,10 @@ TclTrimRight( int TclTrimLeft( - const char *bytes, /* String to be trimmed... */ - int numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - int numTrim) /* ...and its length in bytes */ + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ { const char *p = bytes; @@ -1605,19 +1699,28 @@ TclTrimLeft( Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } - /* Empty strings -> nothing to do */ + /* + * Empty strings -> nothing to do. + */ + if ((numBytes == 0) || (numTrim == 0)) { return 0; } - /* Outer loop: iterate over string to be trimmed */ + /* + * Outer loop: iterate over string to be trimmed. + */ + do { Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; - /* Inner loop: scan trim string for match to current character */ + /* + * Inner loop: scan trim string for match to current character. + */ + do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); @@ -1631,7 +1734,10 @@ TclTrimLeft( } while (bytesLeft); if (bytesLeft == 0) { - /* No match; trim task done; *p is first non-trimmed char */ + /* + * No match; trim task done; *p is first non-trimmed char. + */ + break; } @@ -1673,14 +1779,20 @@ Tcl_Concat( int i, needSpace = 0, bytesNeeded = 0; char *result, *p; - /* Dispose of the empty result corner case first to simplify later code */ + /* + * Dispose of the empty result corner case first to simplify later code. + */ + if (argc == 0) { result = (char *) ckalloc(1); result[0] = '\0'; return result; } - /* First allocate the result buffer at the size required */ + /* + * First allocate the result buffer at the size required. + */ + for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); if (bytesNeeded < 0) { @@ -1689,13 +1801,18 @@ Tcl_Concat( } if (bytesNeeded + argc - 1 < 0) { /* - * Panic test could be tighter, but not going to bother for - * this legacy routine. + * Panic test could be tighter, but not going to bother for this + * legacy routine. */ + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } - /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ - result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); + + /* + * All element bytes + (argc - 1) spaces + 1 terminating NULL. + */ + + result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { int trim, elemLength; @@ -1704,26 +1821,35 @@ Tcl_Concat( element = argv[i]; elemLength = strlen(argv[i]); - /* Trim away the leading whitespace */ + /* + * Trim away the leading whitespace. + */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* - * Trim away the trailing whitespace. Do not permit trimming - * to expose a final backslash character. + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; - /* If we're left with empty element after trimming, do nothing */ + /* + * If we're left with empty element after trimming, do nothing. + */ + if (elemLength == 0) { continue; } - /* Append to the result with space if needed */ + /* + * Append to the result with space if needed. + */ + if (needSpace) { *p++ = ' '; } @@ -1802,9 +1928,10 @@ Tcl_ConcatObj( /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. + * + * First try to pre-allocate the size required. */ - /* First try to pre-allocate the size required */ for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); bytesNeeded += elemLength; @@ -1812,11 +1939,13 @@ Tcl_ConcatObj( break; } } + /* - * Does not matter if this fails, will simply try later to build up - * the string with each Append reallocating as needed with the usual - * string append algorithm. When that fails it will report the error. + * Does not matter if this fails, will simply try later to build up the + * string with each Append reallocating as needed with the usual string + * append algorithm. When that fails it will report the error. */ + TclNewObj(resPtr); Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); @@ -1826,26 +1955,35 @@ Tcl_ConcatObj( element = TclGetStringFromObj(objv[i], &elemLength); - /* Trim away the leading whitespace */ + /* + * Trim away the leading whitespace. + */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* - * Trim away the trailing whitespace. Do not permit trimming - * to expose a final backslash character. + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; - /* If we're left with empty element after trimming, do nothing */ + /* + * If we're left with empty element after trimming, do nothing. + */ + if (elemLength == 0) { continue; } - /* Append to the result with space if needed */ + /* + * Append to the result with space if needed. + */ + if (needSpace) { Tcl_AppendToObj(resPtr, " ", 1); } @@ -2249,6 +2387,7 @@ TclByteArrayMatch( /* * Matches ranges of form [a-z] or [z-a]. */ + break; } } else if (startChar == ch1) { @@ -2295,9 +2434,9 @@ TclByteArrayMatch( * * TclStringMatchObj -- * - * See if a particular string matches a particular pattern. - * Allows case insensitivity. This is the generic multi-type handler - * for the various matching algorithms. + * See if a particular string matches a particular pattern. Allows case + * insensitivity. This is the generic multi-type handler for the various + * matching algorithms. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The @@ -2898,12 +3037,12 @@ Tcl_PrintDouble( * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: * - * % expr 0.1 - * 0.10000000000000001 - * % expr 0.01 - * 0.01 - * % expr 1e-7 - * 9.9999999999999995e-08 + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer @@ -2916,8 +3055,8 @@ Tcl_PrintDouble( */ digits = TclDoubleDigits(value, *precisionPtr, - TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, - &exponent, &signum, &end); + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, + &exponent, &signum, &end); } if (signum) { *dst++ = '-'; @@ -3173,10 +3312,10 @@ TclNeedSpace( */ int -TclFormatInt(buffer, n) - char *buffer; /* Points to the storage into which the +TclFormatInt( + char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n; /* The integer to format. */ + long n) /* The integer to format. */ { long intVal; int i; @@ -3194,9 +3333,9 @@ TclFormatInt(buffer, n) } /* - * Check whether "n" is the maximum negative value. This is - * -2^(m-1) for an m-bit word, and has no positive equivalent; - * negating it produces the same value. + * Check whether "n" is the maximum negative value. This is -2^(m-1) for + * an m-bit word, and has no positive equivalent; negating it produces the + * same value. */ intVal = -n; /* [Bug 3390638] Workaround for*/ @@ -3228,6 +3367,7 @@ TclFormatInt(buffer, n) for (j = 0; j < i; j++, i--) { char tmp = buffer[i]; + buffer[i] = buffer[j]; buffer[j] = tmp; } @@ -3333,16 +3473,10 @@ TclGetIntForIndex( parseError: if (interp != NULL) { - /* - * The result might not be empty; this resets it which should be both - * a cheap operation, and of little problem because this is an - * error-generation path anyway. - */ - bytes = Tcl_GetString(objPtr); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } @@ -3434,9 +3568,8 @@ SetEndOffsetFromAny( if ((*bytes != 'e') || (strncmp(bytes, "end", (size_t)((length > 3) ? 3 : length)) != 0)) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -3470,9 +3603,8 @@ SetEndOffsetFromAny( badIndexFormat: if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -3548,8 +3680,8 @@ TclCheckBadOctal( * be added to an existing error message as extra info. */ - Tcl_AppendResult(interp, " (looks like invalid octal number)", - NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + " (looks like invalid octal number)", -1); } return 1; } @@ -3701,7 +3833,7 @@ TclSetProcessGlobalValue( if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { - Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); @@ -4165,7 +4297,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { - Tcl_AppendResult(interp, msg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); diff --git a/generic/tclVar.c b/generic/tclVar.c index e92dc5f..1c01e41 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3065,7 +3065,8 @@ ArrayStartSearchCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", varName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); return TCL_ERROR; } @@ -3160,8 +3161,8 @@ ArrayAnyMoreCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3266,8 +3267,8 @@ ArrayNextElementCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3376,8 +3377,8 @@ ArrayDoneSearchCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -4019,8 +4020,8 @@ ArrayStatsCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -4028,7 +4029,8 @@ ArrayStatsCmd( stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); if (stats == NULL) { - Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error reading array statistics", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); @@ -4222,15 +4224,15 @@ TclInitArrayCmd( static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0}, - {"exists", ArrayExistsCmd, NULL, NULL, NULL, 0}, + {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, {"get", ArrayGetCmd, NULL, NULL, NULL, 0}, {"names", ArrayNamesCmd, NULL, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0}, - {"set", ArraySetCmd, NULL, NULL, NULL, 0}, + {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, {"size", ArraySizeCmd, NULL, NULL, NULL, 0}, {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0}, {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0}, - {"unset", ArrayUnsetCmd, NULL, NULL, NULL, 0}, + {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -4317,10 +4319,10 @@ ObjMakeUpvar( || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - TclGetString(myNamePtr), "\": upvar won't create " + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "bad variable name \"%s\": upvar won't create " "namespace variable that refers to procedure variable", - NULL); + TclGetString(myNamePtr))); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } @@ -4418,9 +4420,10 @@ TclPtrObjMakeUpvar( * myName looks like an array reference. */ - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create a scalar variable " - "that looks like an array element", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "bad variable name \"%s\": upvar won't create a" + " scalar variable that looks like an array element", + myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; @@ -4447,15 +4450,15 @@ TclPtrObjMakeUpvar( } if (varPtr == otherPtr) { - Tcl_SetResult((Tcl_Interp *) iPtr, - "can't upvar from variable to itself", TCL_STATIC); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj( + "can't upvar from variable to itself", -1)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL); return TCL_ERROR; } if (TclIsVarTraced(varPtr)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "variable \"%s\" has traces: can't use for upvar", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { @@ -4469,8 +4472,8 @@ TclPtrObjMakeUpvar( */ if (!TclIsVarLink(varPtr)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "variable \"%s\" already exists", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL); return TCL_ERROR; } @@ -4968,8 +4971,8 @@ Tcl_UpvarObjCmd( * for this particular case. */ - Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(levelObj))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); return TCL_ERROR; } @@ -4978,8 +4981,8 @@ Tcl_UpvarObjCmd( * We've now finished with parsing levels; skip to the variable names. */ - objc -= hasLevel+1; - objv += hasLevel+1; + objc -= hasLevel + 1; + objv += hasLevel + 1; /* * Iterate over each (other variable, local variable) pair. Divide the @@ -5060,8 +5063,8 @@ SetArraySearchObj( return TCL_OK; syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return TCL_ERROR; } @@ -5126,10 +5129,9 @@ ParseSearchId( */ if (strcmp(string+offset, varName) != 0) { - Tcl_AppendResult(interp, "search identifier \"", string, - "\" isn't for variable \"", varName, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + string, varName)); goto badLookup; } @@ -5153,7 +5155,8 @@ ParseSearchId( } } } - Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", string)); badLookup: Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; @@ -5894,8 +5897,8 @@ ObjFindNamespaceVar( Tcl_DecrRefCount(simpleNamePtr); } if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown variable \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); } return (Tcl_Var) varPtr; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a799639..11490f1 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -5,7 +5,7 @@ * * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net> * Copyright (C) 2005 Unitas Software B.V. - * Copyright (c) 2008-2009 Donal K. Fellows + * Copyright (c) 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. @@ -74,8 +74,27 @@ typedef struct { int wbits; /* The encoded compression mode, so we can * restart the stream if necessary. */ Tcl_Command cmd; /* Token for the associated Tcl command. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ + int flags; /* Miscellaneous flag bits. */ + GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header + * structure. */ } ZlibStreamHandle; +#define DICT_TO_SET 0x1 /* If we need to set a compression dictionary + * in the low-level engine at the next + * opportunity. */ + +/* + * Macros to make it clearer in some of the twiddlier accesses what is + * happening. + */ + +#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW) +#define HaveDictToSet(zshPtr) ((zshPtr)->flags & DICT_TO_SET) +#define DictWasSet(zshPtr) ((zshPtr)->flags |= ~DICT_TO_SET) + /* * Structure used for stacked channel compression and decompression. */ @@ -88,6 +107,11 @@ typedef struct { * for compression on output, or * TCL_ZLIB_STREAM_INFLATE for decompression * on input. */ + int format; /* What format of data is going on the wire. + * Needed so that the correct [fconfigure] + * options can be enabled. */ + int readAheadLimit; /* The maximum number of bytes to read from + * the underlying stream in one go. */ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of @@ -101,6 +125,9 @@ typedef struct { * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ Tcl_DString decompressed; /* Buffer for decompression results. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ } ZlibChannelData; /* @@ -117,10 +144,15 @@ typedef struct { #define OUT_HEADER 0x4 /* - * Size of buffers allocated by default. Should be enough... + * Size of buffers allocated by default, and the range it can be set to. The + * same sorts of values apply to streams, except with different limits (they + * permit byte-level activity). Channels always use bytes unless told to use + * larger buffers. */ #define DEFAULT_BUFFER_SIZE 4096 +#define MIN_NONSTREAM_BUFFER_SIZE 16 +#define MAX_BUFFER_SIZE 65536 /* * Prototypes for private procedures defined later in this file: @@ -138,19 +170,29 @@ static Tcl_DriverSetOptionProc ZlibTransformSetOption; static Tcl_DriverWatchProc ZlibTransformWatch; static Tcl_ObjCmdProc ZlibCmd; static Tcl_ObjCmdProc ZlibStreamCmd; +static Tcl_ObjCmdProc ZlibStreamAddCmd; +static Tcl_ObjCmdProc ZlibStreamHeaderCmd; +static Tcl_ObjCmdProc ZlibStreamPutCmd; -static void ConvertError(Tcl_Interp *interp, int code); +static void ConvertError(Tcl_Interp *interp, int code, + uLong adler); +static Tcl_Obj * ConvertErrorToList(int code, uLong adler); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); +static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static inline int ResultCopy(ZlibChannelData *cd, char *buf, int toRead); static int ResultGenerate(ZlibChannelData *cd, int n, int flush, int *errorCodePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, - int mode, int format, int level, - Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr); + int mode, int format, int level, int limit, + Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, + Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); +static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); @@ -198,38 +240,139 @@ static void ConvertError( Tcl_Interp *interp, /* Interpreter to store the error in. May be * NULL, in which case nothing happens. */ - int code) /* The zlib error code. */ + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ { + const char *codeStr, *codeStr2 = NULL; + char codeStrBuf[TCL_INTEGER_SPACE]; + if (interp == NULL) { return; } - if (code == Z_ERRNO) { + switch (code) { + /* + * Firstly, the case that is *different* because it's really coming + * from the OS and is just being reported via zlib. It should be + * really uncommon because Tcl handles all I/O rather than delegating + * it to zlib, but proving it can't happen is hard. + */ + + case Z_ERRNO: Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1)); - } else { - const char *codeStr, *codeStr2 = NULL; - char codeStrBuf[TCL_INTEGER_SPACE]; - - switch (code) { - case Z_STREAM_ERROR: codeStr = "STREAM"; break; - case Z_DATA_ERROR: codeStr = "DATA"; break; - case Z_MEM_ERROR: codeStr = "MEM"; break; - case Z_BUF_ERROR: codeStr = "BUF"; break; - case Z_VERSION_ERROR: codeStr = "VERSION"; break; - default: - codeStr = "unknown"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%d", code); - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + return; + + /* + * Normal errors/conditions, some of which have additional detail and + * some which don't. (This is not defined by array lookup because zlib + * error codes are sometimes negative.) + */ + + case Z_STREAM_ERROR: + codeStr = "STREAM"; + break; + case Z_DATA_ERROR: + codeStr = "DATA"; + break; + case Z_MEM_ERROR: + codeStr = "MEM"; + break; + case Z_BUF_ERROR: + codeStr = "BUF"; + break; + case Z_VERSION_ERROR: + codeStr = "VERSION"; + break; + case Z_NEED_DICT: + codeStr = "NEED_DICT"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%lu", adler); + break; + + /* + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); + + /* + * Anything else is bad news; it's unexpected. Convert to generic + * error. + */ + + default: + codeStr = "UNKNOWN"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%d", code); + break; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + + /* + * Tricky point! We might pass NULL twice here (and will when the error + * type is known). + */ + + Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); +} + +static Tcl_Obj * +ConvertErrorToList( + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ +{ + Tcl_Obj *objv[4]; + + TclNewLiteralStringObj(objv[0], "TCL"); + TclNewLiteralStringObj(objv[1], "ZLIB"); + switch (code) { + case Z_STREAM_ERROR: + TclNewLiteralStringObj(objv[2], "STREAM"); + return Tcl_NewListObj(3, objv); + case Z_DATA_ERROR: + TclNewLiteralStringObj(objv[2], "DATA"); + return Tcl_NewListObj(3, objv); + case Z_MEM_ERROR: + TclNewLiteralStringObj(objv[2], "MEM"); + return Tcl_NewListObj(3, objv); + case Z_BUF_ERROR: + TclNewLiteralStringObj(objv[2], "BUF"); + return Tcl_NewListObj(3, objv); + case Z_VERSION_ERROR: + TclNewLiteralStringObj(objv[2], "VERSION"); + return Tcl_NewListObj(3, objv); + case Z_ERRNO: + TclNewLiteralStringObj(objv[2], "POSIX"); + objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + return Tcl_NewListObj(4, objv); + case Z_NEED_DICT: + TclNewLiteralStringObj(objv[2], "NEED_DICT"); + objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler); + return Tcl_NewListObj(4, objv); + + /* + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); /* - * Tricky point! We might pass NULL twice here (and will when the - * error type is known). + * Catch-all. Should be unreachable because all cases are already + * listed above. */ - Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); + default: + TclNewLiteralStringObj(objv[2], "UNKNOWN"); + TclNewIntObj(objv[3], code); + return Tcl_NewListObj(4, objv); } } @@ -301,7 +444,9 @@ GenerateHeader( NULL); headerPtr->nativeCommentBuf[len] = '\0'; headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) { @@ -319,7 +464,9 @@ GenerateHeader( headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { @@ -441,6 +588,34 @@ ExtractHeader( } } +static int +SetInflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return inflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + +static int +SetDeflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return deflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + /* *---------------------------------------------------------------------- * @@ -479,6 +654,7 @@ Tcl_ZlibStreamInit( ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; Tcl_CmdInfo cmdinfo; + GzipHeader *gzHeaderPtr = NULL; switch (mode) { case TCL_ZLIB_STREAM_DEFLATE: @@ -493,6 +669,15 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + if (dictObj) { + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + if (GenerateHeader(interp, dictObj, gzHeaderPtr, + NULL) != TCL_OK) { + ckfree(gzHeaderPtr); + return TCL_ERROR; + } + } break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -519,6 +704,14 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + gzHeaderPtr->header.name = (Bytef *) + gzHeaderPtr->nativeFilenameBuf; + gzHeaderPtr->header.name_max = MAXPATHLEN - 1; + gzHeaderPtr->header.comment = (Bytef *) + gzHeaderPtr->nativeCommentBuf; + gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1; break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -545,6 +738,9 @@ Tcl_ZlibStreamInit( zshPtr->wbits = wbits; zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; + zshPtr->compDictObj = NULL; + zshPtr->flags = 0; + zshPtr->gzHeaderPtr = gzHeaderPtr; memset(&zshPtr->stream, 0, sizeof(z_stream)); zshPtr->stream.adler = 1; @@ -555,12 +751,20 @@ Tcl_ZlibStreamInit( if (mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = deflateSetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } } else { e = inflateInit2(&zshPtr->stream, wbits); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = inflateGetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } } if (e != Z_OK) { - ConvertError(interp, e); + ConvertError(interp, e, zshPtr->stream.adler); goto error; } @@ -577,8 +781,8 @@ Tcl_ZlibStreamInit( TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname), &cmdinfo) == 1) { - Tcl_SetResult(interp, - "BUG: Stream command name already exists", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "BUG: Stream command name already exists", -1)); Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); Tcl_DStringFree(&cmdname); goto error; @@ -620,7 +824,14 @@ Tcl_ZlibStreamInit( } return TCL_OK; - error: + + error: + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } ckfree(zshPtr); return TCL_ERROR; } @@ -728,6 +939,12 @@ ZlibStreamCleanup( if (zshPtr->currentInput) { Tcl_DecrRefCount(zshPtr->currentInput); } + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } ckfree(zshPtr); } @@ -780,12 +997,24 @@ Tcl_ZlibStreamReset( if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && HaveDictToSet(zshPtr)) { + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } + } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr) && e == Z_OK) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } + } } if (e != Z_OK) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); /* TODO:cleanup */ return TCL_ERROR; } @@ -878,6 +1107,41 @@ Tcl_ZlibStreamChecksum( /* *---------------------------------------------------------------------- * + * Tcl_ZlibStreamSetCompressionDictionary -- + * + * Sets the compression dictionary for a stream. This will be used as + * appropriate for the next compression or decompression action performed + * on the stream. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zshandle, + Tcl_Obj *compressionDictionaryObj) +{ + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; + + if (compressionDictionaryObj != NULL) { + if (Tcl_IsShared(compressionDictionaryObj)) { + compressionDictionaryObj = + Tcl_DuplicateObj(compressionDictionaryObj); + } + Tcl_IncrRefCount(compressionDictionaryObj); + zshPtr->flags |= DICT_TO_SET; + } else { + zshPtr->flags &= ~DICT_TO_SET; + } + if (zshPtr->compDictObj != NULL) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + zshPtr->compDictObj = compressionDictionaryObj; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ZlibStreamPut -- * * Add data to the stream for compression or decompression from a @@ -900,8 +1164,8 @@ Tcl_ZlibStreamPut( if (zshPtr->streamEnd) { if (zshPtr->interp) { - Tcl_SetResult(zshPtr->interp, - "already past compressed stream end", TCL_STATIC); + Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( + "already past compressed stream end", -1)); Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL); } return TCL_ERROR; @@ -911,6 +1175,17 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; + if (HaveDictToSet(zshPtr)) { + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } + return TCL_ERROR; + } + DictWasSet(zshPtr); + } + /* * Deflatebound doesn't seem to take various header sizes into * account, so we add 100 extra bytes. @@ -948,6 +1223,12 @@ Tcl_ZlibStreamPut( e = deflate(&zshPtr->stream, flush); } + if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } + return TCL_ERROR; + } /* * And append the final data block. @@ -1025,7 +1306,7 @@ Tcl_ZlibStreamGet( * panic for out of memory if we just kept growing the buffer. */ - count = 65536; + count = MAX_BUFFER_SIZE; } /* @@ -1073,7 +1354,30 @@ Tcl_ZlibStreamGet( } } + /* + * When dealing with a raw stream, we set the dictionary here, once. + * (You can't do it in response to getting Z_NEED_DATA as raw streams + * don't ever issue that.) + */ + + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } + return TCL_ERROR; + } + DictWasSet(zshPtr); + } e = inflate(&zshPtr->stream, zshPtr->flush); + if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + e = inflate(&zshPtr->stream, zshPtr->flush); + } + }; Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) @@ -1085,9 +1389,9 @@ Tcl_ZlibStreamGet( if (zshPtr->stream.avail_in > 0) { if (zshPtr->interp) { - Tcl_SetResult(zshPtr->interp, - "Unexpected zlib internal state during decompression", - TCL_STATIC); + Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( + "unexpected zlib internal state during" + " decompression", -1)); Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE", NULL); } @@ -1127,7 +1431,14 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - e = inflate(&zshPtr->stream, zshPtr->flush); + do { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) { + break; + } + e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); + DictWasSet(zshPtr); + } while (e == Z_OK); } if (zshPtr->stream.avail_out > 0) { Tcl_SetByteArrayLength(data, @@ -1135,7 +1446,7 @@ Tcl_ZlibStreamGet( } if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) { Tcl_SetByteArrayLength(data, existing); - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } if (e == Z_STREAM_END) { @@ -1351,7 +1662,7 @@ Tcl_ZlibDeflate( return TCL_OK; error: - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); TclDecrRefCount(obj); return TCL_ERROR; } @@ -1530,7 +1841,7 @@ Tcl_ZlibInflate( error: TclDecrRefCount(obj); - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); if (nameBuf) { ckfree(nameBuf); } @@ -1586,11 +1897,10 @@ ZlibCmd( int objc, Tcl_Obj *const objv[]) { - int command, dlen, mode, format, i, option, level = -1; + int command, dlen, i, option, level = -1; unsigned start, buffersize = 0; - Tcl_ZlibStream zh; Byte *data; - Tcl_Obj *headerDictObj, *headerVarObj; + Tcl_Obj *headerDictObj; const char *extraInfoStr = NULL; static const char *const commands[] = { "adler32", "compress", "crc32", "decompress", "deflate", "gunzip", @@ -1601,14 +1911,6 @@ ZlibCmd( CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM }; - static const char *const stream_formats[] = { - "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", - NULL - }; - enum zlibFormats { - FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, - FMT_INFLATE - }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); @@ -1635,7 +1937,7 @@ ZlibCmd( } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibAdler32(start, data, dlen))); + (uLong) Tcl_ZlibAdler32(start, data, dlen))); return TCL_OK; case CMD_CRC: /* crc32 str ?startvalue? * -> checksum */ @@ -1652,7 +1954,7 @@ ZlibCmd( } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibCRC32(start, data, dlen))); + (uLong) Tcl_ZlibCRC32(start, data, dlen))); return TCL_OK; case CMD_DEFLATE: /* deflate data ?level? * -> rawCompressedData */ @@ -1688,12 +1990,27 @@ ZlibCmd( NULL); case CMD_GZIP: /* gzip data ?level? * -> gzippedCompressedData */ + headerDictObj = NULL; + + /* + * Legacy argument format support. + */ + + if (objc == 4 + && Tcl_GetIntFromObj(interp, objv[3], &level) == TCL_OK) { + if (level < 0 || level > 9) { + extraInfoStr = "\n (in -level option)"; + goto badLevel; + } + return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], + level, NULL); + } + if (objc < 3 || objc > 7 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-level level? ?-header header?"); return TCL_ERROR; } - headerDictObj = NULL; for (i=3 ; i<objc ; i+=2) { static const char *const gzipopts[] = { "-header", "-level", NULL @@ -1732,7 +2049,8 @@ ZlibCmd( (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (buffersize < 16 || buffersize > 65536) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } } @@ -1750,14 +2068,17 @@ ZlibCmd( (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (buffersize < 16 || buffersize > 65536) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], buffersize, NULL); - case CMD_GUNZIP: /* gunzip gzippeddata ?bufferSize? + case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize? * -> decompressedData */ + Tcl_Obj *headerVarObj; + if (objc < 3 || objc > 5 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?"); return TCL_ERROR; @@ -1778,7 +2099,8 @@ ZlibCmd( (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (buffersize < 16 || buffersize > 65536) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } break; @@ -1803,208 +2125,353 @@ ZlibCmd( return TCL_ERROR; } return TCL_OK; + } case CMD_STREAM: /* stream deflate/inflate/...gunzip \ - * ?level? + * ?options...? * -> handleCmd */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - mode = TCL_ZLIB_STREAM_INFLATE; - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_INFLATE: - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_DECOMPRESS: - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_GUNZIP: - format = TCL_ZLIB_FORMAT_GZIP; - break; - } - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], - (int *) &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } else { - level = Z_DEFAULT_COMPRESSION; - } - if (Tcl_ZlibStreamInit(interp, mode, format, level, NULL, - &zh) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); - return TCL_OK; - case CMD_PUSH: { /* push mode channel options... + return ZlibStreamSubcmd(interp, objc, objv); + case CMD_PUSH: /* push mode channel options... * -> channel */ - Tcl_Channel chan; - int chanMode; - static const char *const pushOptions[] = { - "-header", "-level", "-limit", - NULL - }; - enum pushOptions {poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL; - int limit = 1, dummy; + return ZlibPushSubcmd(interp, objc, objv); + }; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); - return TCL_ERROR; - } + return TCL_ERROR; - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - default: - Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); - return TCL_ERROR; - } + badLevel: + Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + if (extraInfoStr) { + Tcl_AddErrorInfo(interp, extraInfoStr); + } + return TCL_ERROR; + badBuffer: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "buffer size must be %d to %d", + MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ZlibStreamSubcmd -- + * + * Implementation of the [zlib stream] subcommand. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibStreamSubcmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const stream_formats[] = { + "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", + NULL + }; + enum zlibFormats { + FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, + FMT_INFLATE + }; + int i, format, mode = 0, option, level; + typedef struct { + const char *name; + Tcl_Obj **valueVar; + } OptDescriptor; + Tcl_Obj *compDictObj = NULL; + Tcl_Obj *gzipHeaderObj = NULL; + Tcl_Obj *levelObj = NULL; + const OptDescriptor compressionOpts[] = { + { "-dictionary", &compDictObj }, + { "-level", &levelObj }, + { NULL, NULL } + }; + const OptDescriptor gzipOpts[] = { + { "-header", &gzipHeaderObj }, + { "-level", &levelObj }, + { NULL, NULL } + }; + const OptDescriptor expansionOpts[] = { + { "-dictionary", &compDictObj }, + { NULL, NULL } + }; + const OptDescriptor gunzipOpts[] = { + { NULL, NULL } + }; + const OptDescriptor *desc = NULL; + Tcl_ZlibStream zh; + + if (objc < 3 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } + + /* + * The format determines the compression mode and the options that may be + * specified. + */ + + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_INFLATE: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_DECOMPRESS: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + desc = gzipOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + case FMT_GUNZIP: + desc = gunzipOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_Panic("should be unreachable"); + } - if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, - 0) != TCL_OK) { + /* + * Parse the options. + */ + + for (i=3 ; i<objc ; i+=2) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], desc, + sizeof(OptDescriptor), "option", 0, &option) != TCL_OK) { return TCL_ERROR; } + *desc[option].valueVar = objv[i+1]; /* - * Sanity checks. + * Drop the cache on the option name; table address not constant. */ - if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { - Tcl_AppendResult(interp, - "compression may only be applied to writable channels", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); + TclFreeIntRep(objv[i]); + } + + /* + * If a compression level was given, parse it (integral: 0..9). Otherwise + * use the default. + */ + + if (levelObj == NULL) { + level = Z_DEFAULT_COMPRESSION; + } else if (Tcl_GetIntFromObj(interp, levelObj, &level) != TCL_OK) { + return TCL_ERROR; + } else if (level < 0 || level > 9) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + + /* + * Construct the stream now we know its configuration. + */ + + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, + &zh) != TCL_OK) { + return TCL_ERROR; + } + if (compDictObj != NULL) { + Tcl_ZlibStreamSetCompressionDictionary(zh, compDictObj); + } + Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ZlibPushSubcmd -- + * + * Implementation of the [zlib push] subcommand. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibPushSubcmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const stream_formats[] = { + "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", + NULL + }; + enum zlibFormats { + FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, + FMT_INFLATE + }; + Tcl_Channel chan; + int chanMode, format, mode = 0, level, i, option; + static const char *const pushCompressOptions[] = { + "-dictionary", "-header", "-level", NULL + }; + static const char *const pushDecompressOptions[] = { + "-dictionary", "-header", "-level", "-limit", NULL + }; + const char *const *pushOptions = pushDecompressOptions; + enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; + Tcl_Obj *headerObj = NULL, *compDictObj = NULL; + int limit = 1, dummy; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + pushOptions = pushCompressOptions; + break; + case FMT_INFLATE: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + pushOptions = pushCompressOptions; + break; + case FMT_DECOMPRESS: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + pushOptions = pushCompressOptions; + break; + case FMT_GUNZIP: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_Panic("should be unreachable"); + } + + if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){ + return TCL_ERROR; + } + + /* + * Sanity checks. + */ + + if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "compression may only be applied to writable channels", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); + return TCL_ERROR; + } + if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "decompression may only be applied to readable channels",-1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); + return TCL_ERROR; + } + + /* + * Parse options. + */ + + level = Z_DEFAULT_COMPRESSION; + for (i=4 ; i<objc ; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0, + &option) != TCL_OK) { return TCL_ERROR; } - if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { - Tcl_AppendResult(interp, - "decompression may only be applied to readable channels", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); + if (++i > objc-1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "value missing for %s option", pushOptions[option])); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - - /* - * Parse options. - */ - - level = Z_DEFAULT_COMPRESSION; - for (i=4 ; i<objc ; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0, - &option) != TCL_OK) { - return TCL_ERROR; + switch ((enum pushOptions) option) { + case poHeader: + headerObj = objv[i]; + if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { + goto genericOptionError; } - switch ((enum pushOptions) option) { - case poHeader: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -header option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - headerObj = objv[i]; - if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -header option)"); - return TCL_ERROR; - } - break; - case poLevel: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -level option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &level) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -level option)"); - return TCL_ERROR; - } - if (level < 0 || level > 9) { - extraInfoStr = "\n (in -level option)"; - goto badLevel; - } - break; - case poLimit: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -limit option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &limit) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -limit option)"); - return TCL_ERROR; - } - if (limit < 1) { - limit = 1; - } - break; + break; + case poLevel: + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) { + goto genericOptionError; } + if (level < 0 || level > 9) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "level must be 0 to 9", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", + NULL); + goto genericOptionError; + } + break; + case poLimit: + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) { + goto genericOptionError; + } + if (limit < 1 || limit > MAX_BUFFER_SIZE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "read ahead limit must be 1 to %d", + MAX_BUFFER_SIZE)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + goto genericOptionError; + } + break; + case poDictionary: + if (format == TCL_ZLIB_FORMAT_GZIP) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "a compression dictionary may not be set in the " + "gzip format", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + goto genericOptionError; + } + compDictObj = objv[i]; + break; } - - if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[3]); - return TCL_OK; } - }; - - return TCL_ERROR; - badLevel: - Tcl_AppendResult(interp, "level must be 0 to 9", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); - if (extraInfoStr) { - Tcl_AddErrorInfo(interp, extraInfoStr); + if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan, + headerObj, compDictObj) == NULL) { + return TCL_ERROR; } - return TCL_ERROR; - badBuffer: - Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + Tcl_SetObjResult(interp, objv[3]); + return TCL_OK; + + genericOptionError: + Tcl_AddErrorInfo(interp, "\n (in "); + Tcl_AddErrorInfo(interp, pushOptions[option]); + Tcl_AddErrorInfo(interp, " option)"); return TCL_ERROR; } @@ -2026,22 +2493,16 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = cd; - int command, index, count, code, buffersize = -1, flush = -1, i; + int command, count, code; Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", - "fullflush", "get", "put", "reset", + "fullflush", "get", "header", "put", "reset", NULL }; enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, - zs_fullflush, zs_get, zs_put, zs_reset - }; - static const char *const add_options[] = { - "-buffer", "-finalize", "-flush", "-fullflush", NULL - }; - enum addOptions { - ao_buffer, ao_finalize, ao_flush, ao_fullflush + zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; if (objc < 2) { @@ -2056,123 +2517,11 @@ ZlibStreamCmd( switch ((enum zlibStreamCommands) command) { case zs_add: /* $strm add ?$flushopt? $data */ - for (i=2; i<objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum addOptions) index) { - case ao_flush: /* -flush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: /* -buffer */ - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-buffer\" option must be " - "followed by integer decompression buffersize", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i+1], - &buffersize) != TCL_OK) { - return TCL_ERROR; - } - if (buffersize < 1 || buffersize > 65536) { - Tcl_AppendResult(interp, - "buffer size must be 32 to 65536", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", - NULL); - return TCL_ERROR; - } - } - - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - - if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { - return TCL_ERROR; - } - TclNewObj(obj); - code = Tcl_ZlibStreamGet(zstream, obj, buffersize); - if (code == TCL_OK) { - Tcl_SetObjResult(interp, obj); - } else { - TclDecrRefCount(obj); - } - return code; - + return ZlibStreamAddCmd(zstream, interp, objc, objv); + case zs_header: /* $strm header */ + return ZlibStreamHeaderCmd(zstream, interp, objc, objv); case zs_put: /* $strm put ?$flushopt? $data */ - for (i=2; i<objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum addOptions) index) { - case ao_flush: /* -flush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: - Tcl_AppendResult(interp, - "\"-buffer\" option not supported here", NULL); - return TCL_ERROR; - } - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); + return ZlibStreamPutCmd(zstream, interp, objc, objv); case zs_get: /* $strm get ?count? */ if (objc > 3) { @@ -2249,7 +2598,7 @@ ZlibStreamCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibStreamChecksum(zstream))); + (uLong) Tcl_ZlibStreamChecksum(zstream))); return TCL_OK; case zs_reset: /* $strm reset */ if (objc != 2) { @@ -2261,6 +2610,246 @@ ZlibStreamCmd( return TCL_OK; } + +static int +ZlibStreamAddCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, code, buffersize = -1, flush = -1, i; + Tcl_Obj *obj, *compDictObj = NULL; + static const char *const add_options[] = { + "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum addOptions { + ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush + }; + + for (i=2; i<objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum addOptions) index) { + case ao_flush: /* -flush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case ao_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case ao_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case ao_buffer: /* -buffer */ + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-buffer\" option must be followed by integer " + "decompression buffersize", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { + return TCL_ERROR; + } + if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "buffer size must be 1 to %d", + MAX_BUFFER_SIZE)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + return TCL_ERROR; + } + break; + case ao_dictionary: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-dictionary\" option must be followed by" + " compression dictionary bytes", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + + if (flush == -2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-flush\", \"-fullflush\" and \"-finalize\" options" + " are mutually exclusive", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + return TCL_ERROR; + } + } + if (flush == -1) { + flush = 0; + } + + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get such data out as we can (up to the requested length). + */ + + TclNewObj(obj); + code = Tcl_ZlibStreamGet(zstream, obj, buffersize); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, obj); + } else { + TclDecrRefCount(obj); + } + return code; +} + +static int +ZlibStreamPutCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, flush = -1, i; + Tcl_Obj *compDictObj = NULL; + static const char *const put_options[] = { + "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum putOptions { + po_dictionary, po_finalize, po_flush, po_fullflush + }; + + for (i=2; i<objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum putOptions) index) { + case po_flush: /* -flush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case po_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case po_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case po_dictionary: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-dictionary\" option must be followed by" + " compression dictionary bytes", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + if (flush == -2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-flush\", \"-fullflush\" and \"-finalize\" options" + " are mutually exclusive", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + return TCL_ERROR; + } + } + if (flush == -1) { + flush = 0; + } + + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); +} + +static int +ZlibStreamHeaderCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + ZlibStreamHandle *zshPtr = cd; + Tcl_Obj *resultObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE + || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "only gunzip streams can produce header information", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + return TCL_ERROR; + } + + TclNewObj(resultObj); + ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -2301,7 +2890,7 @@ ZlibTransformClose( if (e != Z_OK && e != Z_STREAM_END) { /* TODO: is this the right way to do errors on close? */ if (!TclInThreadExit()) { - ConvertError(interp, e); + ConvertError(interp, e, cd->outStream.adler); } result = TCL_ERROR; break; @@ -2312,12 +2901,10 @@ ZlibTransformClose( /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem * then interp may be NULL */ - if (!TclInThreadExit()) { - if (interp) { - Tcl_AppendResult(interp, - "error while finalizing file: ", - Tcl_PosixError(interp), NULL); - } + if (!TclInThreadExit() && interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error while finalizing file: %s", + Tcl_PosixError(interp))); } result = TCL_ERROR; break; @@ -2403,7 +2990,7 @@ ZlibTransformInput( * reading over the border. */ - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); + readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* * Three cases here: @@ -2517,6 +3104,7 @@ ZlibTransformOutput( Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); int e, produced; + Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite, @@ -2540,14 +3128,19 @@ ZlibTransformOutput( } } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0); - if (e != Z_OK) { - Tcl_SetChannelError(cd->parent, - Tcl_NewStringObj(cd->outStream.msg, -1)); - *errorCodePtr = EINVAL; - return -1; + if (e == Z_OK) { + return toWrite - cd->outStream.avail_in; } - return toWrite - cd->outStream.avail_in; + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->outStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->outStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return -1; } /* @@ -2570,56 +3163,113 @@ ZlibTransformSetOption( /* not used */ ZlibChannelData *cd = instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "flush"; + static const char *compressChanOptions = "dictionary flush"; + static const char *gzipChanOptions = "flush"; + static const char *decompressChanOptions = "dictionary limit"; + static const char *gunzipChanOptions = "flush limit"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); - if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { - int flushType; + if (optionName && (strcmp(optionName, "-dictionary") == 0) + && (cd->format != TCL_ZLIB_FORMAT_GZIP)) { + Tcl_Obj *compDictObj; + int code; - if (value[0] == 'f' && strcmp(value, "full") == 0) { - flushType = Z_FULL_FLUSH; - } else if (value[0] == 's' && strcmp(value, "sync") == 0) { - flushType = Z_SYNC_FLUSH; - } else { - Tcl_AppendResult(interp, "unknown -flush type \"", value, - "\": must be full or sync", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); - return TCL_ERROR; + TclNewStringObj(compDictObj, value, strlen(value)); + Tcl_IncrRefCount(compDictObj); + (void) Tcl_GetByteArrayFromObj(compDictObj, NULL); + if (cd->compDictObj) { + TclDecrRefCount(cd->compDictObj); + } + cd->compDictObj = compDictObj; + code = Z_OK; + if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { + code = SetDeflateDictionary(&cd->outStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code, cd->outStream.adler); + return TCL_ERROR; + } + } else if (cd->format == TCL_ZLIB_FORMAT_RAW) { + code = SetInflateDictionary(&cd->inStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code, cd->inStream.adler); + return TCL_ERROR; + } } + return TCL_OK; + } - /* - * Try to actually do the flush now. - */ + if (haveFlushOpt) { + if (optionName && strcmp(optionName, "-flush") == 0) { + int flushType; - cd->outStream.avail_in = 0; - while (1) { - int e; + if (value[0] == 'f' && strcmp(value, "full") == 0) { + flushType = Z_FULL_FLUSH; + } else if (value[0] == 's' && strcmp(value, "sync") == 0) { + flushType = Z_SYNC_FLUSH; + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown -flush type \"%s\": must be full or sync", + value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); + return TCL_ERROR; + } - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; + /* + * Try to actually do the flush now. + */ - e = deflate(&cd->outStream, flushType); - if (e == Z_BUF_ERROR) { - break; - } else if (e != Z_OK) { - ConvertError(interp, e); - return TCL_ERROR; - } else if (cd->outStream.avail_out == 0) { - break; + cd->outStream.avail_in = 0; + while (1) { + int e; + + cd->outStream.next_out = (Bytef *) cd->outBuffer; + cd->outStream.avail_out = cd->outAllocated; + + e = deflate(&cd->outStream, flushType); + if (e == Z_BUF_ERROR) { + break; + } else if (e != Z_OK) { + ConvertError(interp, e, cd->outStream.adler); + return TCL_ERROR; + } else if (cd->outStream.avail_out == 0) { + break; + } + + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, + cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "problem flushing channel: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } } + return TCL_OK; + } + } else { + if (optionName && strcmp(optionName, "-limit") == 0) { + int newLimit; - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { - Tcl_AppendResult(interp, "problem flushing channel: ", - Tcl_PosixError(interp), NULL); + if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) { + return TCL_ERROR; + } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-limit must be between 1 and 65536", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); return TCL_ERROR; } } - return TCL_OK; } if (setOptionProc == NULL) { - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); + } } /* @@ -2651,7 +3301,10 @@ ZlibTransformGetOption( ZlibChannelData *cd = instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "checksum header"; + static const char *compressChanOptions = "checksum dictionary"; + static const char *gzipChanOptions = "checksum"; + static const char *decompressChanOptions = "checksum dictionary limit"; + static const char *gunzipChanOptions = "checksum header limit"; /* * The "crc" option reports the current CRC (calculated with the Adler32 @@ -2679,6 +3332,28 @@ ZlibTransformGetOption( } } + if ((cd->format != TCL_ZLIB_FORMAT_GZIP) && + (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) { + /* + * Embedded NUL bytes are ok; they'll be C080-encoded. + */ + + if (optionName == NULL) { + Tcl_DStringAppendElement(dsPtr, "-dictionary"); + if (cd->compDictObj) { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetString(cd->compDictObj)); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + } else { + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + + Tcl_DStringAppend(dsPtr, str, len); + } + } + /* * The "header" option, which is only valid on inflating gzip channels, * reports the header that has been read from the start of the stream. @@ -2711,7 +3386,15 @@ ZlibTransformGetOption( if (optionName == NULL) { return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); + } } /* @@ -2856,10 +3539,15 @@ ZlibStackChannelTransform( * decompressing transforms. */ int level, /* What compression level to use. Ignored for * decompressing transforms. */ + int limit, /* The limit on the number of bytes to read + * ahead; always at least 1. */ Tcl_Channel channel, /* The channel to attach to. */ - Tcl_Obj *gzipHeaderDictPtr) /* A description of header to use, or NULL to + Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to * use a default. Ignored if not compressing * to produce gzip-format data. */ + Tcl_Obj *compDictObj) /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ { ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; @@ -2872,15 +3560,15 @@ ZlibStackChannelTransform( memset(cd, 0, sizeof(ZlibChannelData)); cd->mode = mode; + cd->format = format; + cd->readAheadLimit = limit; if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { if (gzipHeaderDictPtr) { - int dummy = 0; - cd->flags |= OUT_HEADER; if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader, - &dummy) != TCL_OK) { + NULL) != TCL_OK) { goto error; } } @@ -2895,6 +3583,12 @@ ZlibStackChannelTransform( } } + if (compDictObj != NULL) { + cd->compDictObj = Tcl_DuplicateObj(compDictObj); + Tcl_IncrRefCount(cd->compDictObj); + Tcl_GetByteArrayFromObj(cd->compDictObj, NULL); + } + if (format == TCL_ZLIB_FORMAT_RAW) { wbits = WBITS_RAW; } else if (format == TCL_ZLIB_FORMAT_ZLIB) { @@ -2924,6 +3618,14 @@ ZlibStackChannelTransform( goto error; } } + if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + TclDecrRefCount(cd->compDictObj); + cd->compDictObj = NULL; + } } else { e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); @@ -2938,6 +3640,12 @@ ZlibStackChannelTransform( goto error; } } + if (cd->compDictObj) { + e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + } } Tcl_DStringInit(&cd->decompressed); @@ -2961,6 +3669,9 @@ ZlibStackChannelTransform( ckfree(cd->outBuffer); deflateEnd(&cd->outStream); } + if (cd->compDictObj) { + Tcl_DecrRefCount(cd->compDictObj); + } ckfree(cd); return NULL; } @@ -3050,6 +3761,7 @@ ResultGenerate( #define MAXBUF 1024 unsigned char buf[MAXBUF]; int e, written; + Tcl_Obj *errObj; cd->inStream.next_in = (Bytef *) cd->inBuffer; cd->inStream.avail_in = n; @@ -3059,6 +3771,18 @@ ResultGenerate( cd->inStream.avail_out = MAXBUF; e = inflate(&cd->inStream, flush); + if (e == Z_NEED_DICT && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e == Z_OK) { + /* + * A repetition of Z_NEED_DICT is just an error. + */ + + cd->inStream.next_out = (Bytef *) buf; + cd->inStream.avail_out = MAXBUF; + e = inflate(&cd->inStream, flush); + } + } /* * avail_out is now the left over space in the output. Therefore @@ -3090,13 +3814,7 @@ ResultGenerate( */ if ((e != Z_OK) && (e != Z_BUF_ERROR)) { - Tcl_Obj *errObj = Tcl_NewListObj(0, NULL); - - Tcl_ListObjAppendElement(NULL, errObj, - Tcl_NewStringObj(cd->inStream.msg, -1)); - Tcl_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return TCL_ERROR; + goto handleError; } /* @@ -3107,6 +3825,17 @@ ResultGenerate( return TCL_OK; } } + + handleError: + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->inStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->inStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return TCL_ERROR; } /* @@ -3119,6 +3848,8 @@ int TclZlibInit( Tcl_Interp *interp) { + Tcl_Config cfg[2]; + /* * This does two things. It creates a counter used in the creation of * stream commands, and it creates the namespace that will contain those @@ -3132,6 +3863,23 @@ TclZlibInit( */ Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); + + /* + * Store the underlying configuration information. + * + * TODO: Describe whether we're using the system version of the library or + * a compatibility version built into Tcl? + */ + + cfg[0].key = "zlibVersion"; + cfg[0].value = zlibVersion(); + cfg[1].key = NULL; + Tcl_RegisterConfig(interp, "zlib", cfg, "ascii"); + + /* + * Formally provide the package as a Tcl built-in. + */ + return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); } @@ -3152,7 +3900,7 @@ Tcl_ZlibStreamInit( Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -3218,7 +3966,7 @@ Tcl_ZlibDeflate( int level, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -3231,7 +3979,7 @@ Tcl_ZlibInflate( int bufferSize, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -3253,6 +4001,14 @@ Tcl_ZlibAdler32( { return 0; } + +void +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zshandle, + Tcl_Obj *compressionDictionaryObj) +{ + /* Do nothing. */ +} #endif /* HAVE_ZLIB */ /* |