From 592da3fcbdeed87601e0deb1a7bab5de79870efa Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 24 May 2024 19:36:08 +0000 Subject: Use TclDStringToObj a bit more --- generic/tclPkg.c | 6 +----- unix/tclUnixFCmd.c | 6 ++---- unix/tclUnixFile.c | 8 ++------ win/tclWinFCmd.c | 2 +- 4 files changed, 6 insertions(+), 16 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 5e7f614..7e8db0e 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -414,11 +414,7 @@ PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { AddRequirementsToDString(&command, reqc, reqv); Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL - ); - Tcl_DStringFree(&command); + Tcl_NREvalObj(interp, TclDStringToObj(&command), TCL_EVAL_GLOBAL); } return TCL_OK; } else { diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 26429df..3d44124 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -789,8 +789,7 @@ TclpObjCopyDirectory( Tcl_DStringFree(&dstString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); - Tcl_DStringFree(&ds); + *errorPtr = TclDStringToObj(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; @@ -843,8 +842,7 @@ TclpObjRemoveDirectory( Tcl_DStringFree(&pathString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); - Tcl_DStringFree(&ds); + *errorPtr = TclDStringToObj(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 5f9f9b3..c39e7b6 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -149,9 +149,7 @@ TclpFindExecutable( #endif { Tcl_ExternalToUtfDString(NULL, name, -1, &utfName); - TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), NULL); - Tcl_DStringFree(&utfName); + TclSetObjNameOfExecutable(TclDStringToObj(&utfName), NULL); goto done; } @@ -185,9 +183,7 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, &utfName); - TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), NULL); - Tcl_DStringFree(&utfName); + TclSetObjNameOfExecutable(TclDStringToObj(&utfName), NULL); done: Tcl_DStringFree(&buffer); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 65c6441..0bf21dd 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -925,7 +925,7 @@ TclpObjCopyDirectory( } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { *errorPtr = destPathPtr; } else { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = TclDStringToObj(&ds); } Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); -- cgit v0.12 From d074c70e9eb90a11545b4bf3bd4cb6d6bbc8acac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 May 2024 22:14:08 +0000 Subject: Remove TclSetProcessGlobalValue() "encoding" parameter: it should always be NULL --- generic/tclEncoding.c | 8 ++++---- generic/tclInt.h | 2 +- generic/tclUtil.c | 13 +++++++------ 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0844303..73b4f54 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -407,7 +407,7 @@ Tcl_SetEncodingSearchPath( if (TCL_ERROR == TclListObjLength(NULL, searchPath, &dummy)) { return TCL_ERROR; } - TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); + TclSetProcessGlobalValue(&encodingSearchPath, searchPath); return TCL_OK; } @@ -482,7 +482,7 @@ FillEncodingFileMap(void) Tcl_DecrRefCount(directory); } Tcl_DecrRefCount(searchPath); - TclSetProcessGlobalValue(&encodingFileMap, map, NULL); + TclSetProcessGlobalValue(&encodingFileMap, map); Tcl_DecrRefCount(map); } @@ -1778,7 +1778,7 @@ OpenEncodingFileChannel( map = Tcl_DuplicateObj(map); Tcl_DictObjRemove(NULL, map, nameObj); - TclSetProcessGlobalValue(&encodingFileMap, map, NULL); + TclSetProcessGlobalValue(&encodingFileMap, map); directory = NULL; } } @@ -1812,7 +1812,7 @@ OpenEncodingFileChannel( map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap)); Tcl_DictObjPut(NULL, map, nameObj, dir[i]); - TclSetProcessGlobalValue(&encodingFileMap, map, NULL); + TclSetProcessGlobalValue(&encodingFileMap, map); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index ed8336b..938090c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3576,7 +3576,7 @@ MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, - Tcl_Obj *newValue, Tcl_Encoding encoding); + Tcl_Obj *newValue); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0fcecbf..e2c96a9 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4121,8 +4121,7 @@ FreeProcessGlobalValue( void TclSetProcessGlobalValue( ProcessGlobalValue *pgvPtr, - Tcl_Obj *newValue, - Tcl_Encoding encoding) + Tcl_Obj *newValue) { const char *bytes; Tcl_HashTable *cacheMap; @@ -4144,7 +4143,7 @@ TclSetProcessGlobalValue( } bytes = TclGetString(newValue); pgvPtr->numBytes = newValue->length; - Tcl_UtfToExternalDStringEx(NULL, encoding, bytes, pgvPtr->numBytes, + Tcl_UtfToExternalDStringEx(NULL, NULL, bytes, pgvPtr->numBytes, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); pgvPtr->numBytes = Tcl_DStringLength(&ds); pgvPtr->value = (char *)Tcl_Alloc(pgvPtr->numBytes + 1); @@ -4153,7 +4152,7 @@ TclSetProcessGlobalValue( if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } - pgvPtr->encoding = encoding; + pgvPtr->encoding = NULL; /* * Fill the local thread copy directly with the Tcl_Obj value to avoid @@ -4277,6 +4276,8 @@ TclGetProcessGlobalValue( * This function stores the absolute pathname of the executable file * (normally as computed by TclpFindExecutable). * + * Starting with Tcl 9.0, encoding parameter is not used any more. + * * Results: * None. * @@ -4289,9 +4290,9 @@ TclGetProcessGlobalValue( void TclSetObjNameOfExecutable( Tcl_Obj *name, - Tcl_Encoding encoding) + TCL_UNUSED(Tcl_Encoding)) { - TclSetProcessGlobalValue(&executableName, name, encoding); + TclSetProcessGlobalValue(&executableName, name); } /* -- cgit v0.12 From db2ea548def3585a73e7b0c98582e68dab510a09 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 May 2024 09:09:52 +0000 Subject: Unneeded Tcl_DStringFree() (twice) --- generic/tclFileName.c | 1 - generic/tclPkg.c | 1 - 2 files changed, 2 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 5679a6c..54c583a 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1777,7 +1777,6 @@ TclGlob( if (c != '\0') { tail++; } - Tcl_DStringFree(&buffer); } else { tail = pattern; } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6a42a38..c82cd4d 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -538,7 +538,6 @@ PkgRequireCoreStep1( Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); Tcl_NREvalObj(interp, Tcl_DStringToObj(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); return TCL_OK; } -- cgit v0.12 From dfbb9a77ad9a9998eaed2cc0b70254f3ae7bfe65 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 09:13:47 +0000 Subject: Add some more C functions for working with dicts [656fe3c816] --- generic/tclDictObj.c | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 6 +++ 2 files changed, 120 insertions(+) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index de3547e..b44e437 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1440,6 +1440,120 @@ Tcl_DbNewDictObj( #endif } +/***** START OF FUNCTIONS ACTING AS HELPERS *****/ + +/* + *---------------------------------------------------------------------- + * + * TclDictGet -- + * + * Given a key, get its value from the dictionary (or NULL if key is not + * found in dictionary.) + * + * Results: + * A standard Tcl result. The variable pointed to by valuePtrPtr is + * updated with the value for the key. Note that it is not an error for + * the key to have no mapping in the dictionary. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one. + * + *---------------------------------------------------------------------- + */ +int +TclDictGet( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key, /* The key in a C string. */ + Tcl_Obj **valuePtrPtr) /* Where to write the value. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + code = Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr); + Tcl_DecrRefCount(keyPtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictPut -- + * + * Add a key,value pair to a dictionary, or update the value for a key if + * that key already has a mapping in the dictionary. + * + * If valuePtr is a zero-count object and is not written into the + * dictionary because of an error, it is freed by this routine. The caller + * does NOT need to do reference count management. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +TclDictPut( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key, /* The key in a C string. */ + Tcl_Obj *valuePtr) /* The value to write in. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + Tcl_IncrRefCount(valuePtr); + code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr); + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(valuePtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictPutString -- + * + * Add a key,value pair to a dictionary, or update the value for a key if + * that key already has a mapping in the dictionary. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +TclDictPutString( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key, /* The key in a C string. */ + const char *value) /* The value in a C string. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + Tcl_Obj *valuePtr = Tcl_NewStringObj(value, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + Tcl_IncrRefCount(valuePtr); + code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr); + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(valuePtr); + return code; +} + /***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/ /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 5890bcb..a3761e5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2918,6 +2918,12 @@ MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); +MODULE_SCOPE int TclDictGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key, Tcl_Obj **valuePtrPtr); +MODULE_SCOPE int TclDictPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key, Tcl_Obj *valuePtr); +MODULE_SCOPE int TclDictPutString(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key, const char *value); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, -- cgit v0.12 From 52e0863e247b040ad4634a2d76fb635864cc03f7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 11:31:34 +0000 Subject: Use the new operations --- generic/tclCmdMZ.c | 6 ++---- generic/tclCompCmds.c | 15 ++++++--------- generic/tclCompCmdsSZ.c | 5 ++--- generic/tclConfig.c | 2 +- generic/tclDictObj.c | 33 ++++++++++++++++++++++++++++++++ generic/tclDisassemble.c | 50 ++++++++++++++++++++---------------------------- generic/tclEncoding.c | 11 ++++------- generic/tclEnsemble.c | 5 ++--- generic/tclEvent.c | 30 +++++++---------------------- generic/tclIOCmd.c | 3 +-- generic/tclInt.h | 2 ++ generic/tclInterp.c | 41 ++++++++++++++++----------------------- generic/tclMain.c | 8 ++------ generic/tclOOInfo.c | 6 ++---- generic/tclZlib.c | 48 ++++++++++++++++------------------------------ 15 files changed, 117 insertions(+), 148 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 41782b0..a6e9ffd 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -5115,12 +5115,10 @@ TryPostBody( */ if (code == TCL_ERROR) { - Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2; + Tcl_Obj *errcode, **bits1, **bits2; int len1, len2, j; - TclNewLiteralStringObj(errorCodeName, "-errorcode"); - Tcl_DictObjGet(NULL, options, errorCodeName, &errcode); - Tcl_DecrRefCount(errorCodeName); + TclDictGet(NULL, options, "-errorcode", &errcode); TclListObjGetElements(NULL, info[2], &len1, &bits1); if (TclListObjGetElements(NULL, errcode, &len2, &bits2) != TCL_OK) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bafcb13..a422072 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2293,8 +2293,7 @@ DisassembleDictUpdateInfo( Tcl_ListObjAppendElement(NULL, variables, Tcl_NewIntObj(duiPtr->varIndices[i])); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), - variables); + TclDictPut(NULL, dictObj, "variables", variables); } /* @@ -3035,14 +3034,13 @@ DisassembleForeachInfo( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(infoPtr->firstValueTemp + i)); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); + TclDictPut(NULL, dictObj, "data", objPtr); /* * Loop counter. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + TclDictPut(NULL, dictObj, "loop", Tcl_NewIntObj(infoPtr->loopCtTemp)); /* * Assignment targets. @@ -3058,7 +3056,7 @@ DisassembleForeachInfo( } Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); + TclDictPut(NULL, dictObj, "assign", objPtr); } static void @@ -3077,8 +3075,7 @@ DisassembleNewForeachInfo( * Jump offset. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + TclDictPut(NULL, dictObj, "jumpOffset", Tcl_NewIntObj(infoPtr->loopCtTemp)); /* * Assignment targets. @@ -3094,7 +3091,7 @@ DisassembleNewForeachInfo( } Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); + TclDictPut(NULL, dictObj, "assign", objPtr); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index a7db705..4f2ee70 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2574,10 +2574,9 @@ DisassembleJumptableInfo( for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr); offset = PTR2INT(Tcl_GetHashValue(hPtr)); - Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), - Tcl_NewIntObj(offset)); + TclDictPut(NULL, mapping, keyPtr, Tcl_NewIntObj(offset)); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); + TclDictPut(NULL, dictObj, "mapping", mapping); } /* diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a1a53bc..8fe8fc9 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -128,7 +128,7 @@ Tcl_RegisterConfig( */ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { - Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), + TclDictPut(interp, pkgDict, cfg->key, Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value))); } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b44e437..3cd9f43 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1554,6 +1554,39 @@ TclDictPutString( return code; } +/* + *---------------------------------------------------------------------- + * + * TclDictRemove -- + * + * Remove the key,value pair with the given key from the dictionary; the + * key does not need to be present in the dictionary. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +TclDictRemove( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key) /* The key in a C string. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + code = Tcl_DictObjRemove(interp, dictPtr, keyPtr); + Tcl_DecrRefCount(keyPtr); + return code; +} + /***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/ /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 9597beb..a66b6a9 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1113,7 +1113,7 @@ DisassembleByteCodeAsDicts( Tcl_Obj *desc; TclNewObj(desc); - Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); + TclDictPut(NULL, desc, "name", auxDesc); auxDesc = desc; auxData->type->disassembleProc(auxData->clientData, auxDesc, codePtr, 0); @@ -1180,23 +1180,21 @@ DisassembleByteCodeAsDicts( sourceOffset += Decode(srcOffPtr); sourceLength = Decode(srcLenPtr); TclNewObj(cmd); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), - Tcl_NewIntObj(codeOffset)); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), - Tcl_NewIntObj(codeOffset + codeLength - 1)); + TclDictPut(NULL, cmd, "codefrom", Tcl_NewIntObj(codeOffset)); + TclDictPut(NULL, cmd, "codeto", Tcl_NewIntObj( + codeOffset + codeLength - 1)); /* * Convert byte offsets to character offsets; important if multibyte * characters are present in the source! */ - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), - Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, - sourceOffset))); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), - Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + TclDictPut(NULL, cmd, "scriptfrom", Tcl_NewIntObj( + Tcl_NumUtfChars(codePtr->source, sourceOffset))); + TclDictPut(NULL, cmd, "scriptto", Tcl_NewIntObj( + Tcl_NumUtfChars(codePtr->source, sourceOffset + sourceLength - 1))); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), + TclDictPut(NULL, cmd, "script", Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); Tcl_ListObjAppendElement(NULL, commands, cmd); } @@ -1215,32 +1213,26 @@ DisassembleByteCodeAsDicts( */ TclNewObj(description); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), - literals); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), - variables); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), - instructions); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), - commands); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), + TclDictPut(NULL, description, "literals", literals); + TclDictPut(NULL, description, "variables", variables); + TclDictPut(NULL, description, "exception", exn); + TclDictPut(NULL, description, "instructions", instructions); + TclDictPut(NULL, description, "auxiliary", aux); + TclDictPut(NULL, description, "commands", commands); + TclDictPut(NULL, description, "script", Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), + TclDictPut(NULL, description, "namespace", Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), + TclDictPut(NULL, description, "stackdepth", Tcl_NewIntObj(codePtr->maxStackDepth)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), + TclDictPut(NULL, description, "exceptdepth", Tcl_NewIntObj(codePtr->maxExceptDepth)); if (line > -1) { - Tcl_DictObjPut(NULL, description, - Tcl_NewStringObj("initiallinenumber", -1), + TclDictPut(NULL, description, "initiallinenumber", Tcl_NewIntObj(line)); } if (file) { - Tcl_DictObjPut(NULL, description, - Tcl_NewStringObj("sourcefile", -1), file); + TclDictPut(NULL, description, "sourcefile", file); } return description; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ba9f811..bbcaeb9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1494,8 +1494,7 @@ OpenEncodingFileChannel( const char *name) /* The name of the encoding file on disk and * also the name for new encoding. */ { - Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); - Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj); + Tcl_Obj *fileNameObj = Tcl_NewStringObj(name, -1); Tcl_Obj *searchPath = Tcl_DuplicateObj(Tcl_GetEncodingSearchPath()); Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap); Tcl_Obj **dir, *path, *directory = NULL; @@ -1503,10 +1502,9 @@ OpenEncodingFileChannel( int i, numDirs; TclListObjGetElements(NULL, searchPath, &numDirs, &dir); - Tcl_IncrRefCount(nameObj); Tcl_AppendToObj(fileNameObj, ".enc", -1); Tcl_IncrRefCount(fileNameObj); - Tcl_DictObjGet(NULL, map, nameObj, &directory); + TclDictGet(NULL, map, name, &directory); /* * Check that any cached directory is still on the encoding search path. @@ -1535,7 +1533,7 @@ OpenEncodingFileChannel( */ map = Tcl_DuplicateObj(map); - Tcl_DictObjRemove(NULL, map, nameObj); + TclDictRemove(NULL, map, name); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); directory = NULL; } @@ -1569,7 +1567,7 @@ OpenEncodingFileChannel( */ map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap)); - Tcl_DictObjPut(NULL, map, nameObj, dir[i]); + TclDictPut(NULL, map, name, dir[i]); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); } } @@ -1580,7 +1578,6 @@ OpenEncodingFileChannel( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_DecrRefCount(fileNameObj); - Tcl_DecrRefCount(nameObj); Tcl_DecrRefCount(searchPath); return chan; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f1d7134..dea3bed 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1586,17 +1586,16 @@ TclMakeEnsemble( */ if (ensemble != NULL) { - Tcl_Obj *mapDict, *fromObj, *toObj; + Tcl_Obj *mapDict, *toObj; Command *cmdPtr; TclDStringAppendLiteral(&buf, "::"); TclNewObj(mapDict); for (i=0 ; map[i].name != NULL ; i++) { - fromObj = Tcl_NewStringObj(map[i].name, -1); TclNewStringObj(toObj, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); Tcl_AppendToObj(toObj, map[i].name, -1); - Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + TclDictPut(NULL, mapDict, map[i].name, toObj); if (map[i].proc || map[i].nreProc) { /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index c2e71ec..49880b6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -263,13 +263,9 @@ HandleBgErrors( if (errChannel != NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); - Tcl_Obj *keyPtr, *valuePtr = NULL; - - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + Tcl_Obj *valuePtr = NULL; + TclDictGet(NULL, options, "-errorinfo", &valuePtr); Tcl_WriteChars(errChannel, "error in background error handler:\n", -1); if (valuePtr) { @@ -313,7 +309,7 @@ TclDefaultBgErrorHandlerObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *keyPtr, *valuePtr; + Tcl_Obj *valuePtr; Tcl_Obj *tempObjv[2]; int result, code, level; Tcl_InterpState saved; @@ -327,10 +323,7 @@ TclDefaultBgErrorHandlerObjCmd( * Check for a valid return options dictionary. */ - TclNewLiteralStringObj(keyPtr, "-level"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-level", &valuePtr); if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); @@ -340,10 +333,7 @@ TclDefaultBgErrorHandlerObjCmd( if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { return TCL_ERROR; } - TclNewLiteralStringObj(keyPtr, "-code"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-code", &valuePtr); if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); @@ -405,18 +395,12 @@ TclDefaultBgErrorHandlerObjCmd( Tcl_SetObjResult(interp, tempObjv[1]); } - TclNewLiteralStringObj(keyPtr, "-errorcode"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-errorcode", &valuePtr); if (result == TCL_OK && valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-errorinfo", &valuePtr); if (result == TCL_OK && valuePtr != NULL) { Tcl_AppendObjToErrorInfo(interp, valuePtr); } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 5127b99..cdcef10 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -2005,8 +2005,7 @@ TclInitChanCmd( * Can assume that reference counts are all incremented. */ - Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1), - Tcl_NewStringObj(extras[i+1], -1)); + TclDictPutString(NULL, mapObj, extras[i], extras[i + 1]); } Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj); return ensemble; diff --git a/generic/tclInt.h b/generic/tclInt.h index a3761e5..df3d7c8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2924,6 +2924,8 @@ MODULE_SCOPE int TclDictPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, Tcl_Obj *valuePtr); MODULE_SCOPE int TclDictPutString(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, const char *value); +MODULE_SCOPE int TclDictRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b0f6207..ad06293 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -4428,8 +4428,7 @@ ChildCommandLimitCmd( if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), - limitCBPtr->scriptObj); + TclDictPut(NULL, dictPtr, options[0], limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; } @@ -4438,22 +4437,19 @@ ChildCommandLimitCmd( putEmptyCommandInDict: TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[0], -1), empty); + TclDictPut(NULL, dictPtr, options[0], empty); } - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, - TCL_LIMIT_COMMANDS))); + TclDictPut(NULL, dictPtr, options[1], Tcl_NewIntObj( + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp))); + TclDictPut(NULL, dictPtr, options[2], Tcl_NewIntObj( + Tcl_LimitGetCommands(childInterp))); } else { Tcl_Obj *empty; TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[2], -1), empty); + TclDictPut(NULL, dictPtr, options[2], empty); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; @@ -4616,8 +4612,7 @@ ChildTimeLimitCmd( if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), - limitCBPtr->scriptObj); + TclDictPut(NULL, dictPtr, options[0], limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; } @@ -4625,29 +4620,25 @@ ChildTimeLimitCmd( Tcl_Obj *empty; putEmptyCommandInDict: TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[0], -1), empty); + TclDictPut(NULL, dictPtr, options[0], empty); } - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, - TCL_LIMIT_TIME))); + TclDictPut(NULL, dictPtr, options[1], Tcl_NewIntObj( + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; Tcl_LimitGetTime(childInterp, &limitMoment); - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewLongObj(limitMoment.usec/1000)); - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), + TclDictPut(NULL, dictPtr, options[2], + Tcl_NewLongObj(limitMoment.usec / 1000)); + TclDictPut(NULL, dictPtr, options[3], Tcl_NewLongObj(limitMoment.sec)); } else { Tcl_Obj *empty; TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[2], -1), empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[3], -1), empty); + TclDictPut(NULL, dictPtr, options[2], empty); + TclDictPut(NULL, dictPtr, options[3], empty); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; diff --git a/generic/tclMain.c b/generic/tclMain.c index 4f31924..d2ab04a 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -405,13 +405,9 @@ Tcl_MainEx( chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); - Tcl_Obj *keyPtr, *valuePtr; - - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + Tcl_Obj *valuePtr = NULL; + TclDictGet(NULL, options, "-errorinfo", &valuePtr); if (valuePtr) { Tcl_WriteObj(chan, valuePtr); } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 081dd5b..8f544e1 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -116,10 +116,8 @@ TclOOInitInfo( infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (infoCmd) { Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), - Tcl_NewStringObj("::oo::InfoClass", -1)); + TclDictPutString(NULL, mapDict, "object", "::oo::InfoObject"); + TclDictPutString(NULL, mapDict, "class", "::oo::InfoClass"); Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4b0332b..e043212 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -385,7 +385,7 @@ ConvertErrorToList( * GenerateHeader -- * * Function for creating a gzip header from the contents of a dictionary - * (as described in the documentation). GetValue is a helper function. + * (as described in the documentation). * * Results: * A Tcl result code. @@ -398,20 +398,6 @@ ConvertErrorToList( *---------------------------------------------------------------------- */ -static inline int -GetValue( - Tcl_Interp *interp, - Tcl_Obj *dictObj, - const char *nameStr, - Tcl_Obj **valuePtrPtr) -{ - Tcl_Obj *name = Tcl_NewStringObj(nameStr, -1); - int result = Tcl_DictObjGet(interp, dictObj, name, valuePtrPtr); - - TclDecrRefCount(name); - return result; -} - static int GenerateHeader( Tcl_Interp *interp, /* Where to put error messages. */ @@ -438,7 +424,7 @@ GenerateHeader( Tcl_Panic("no latin-1 encoding"); } - if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { Tcl_EncodingState state; @@ -465,14 +451,14 @@ GenerateHeader( } } - if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "crc", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetBooleanFromObj(interp, value, &headerPtr->header.hcrc)) { goto error; } - if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { Tcl_EncodingState state; @@ -499,7 +485,7 @@ GenerateHeader( } } - if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "os", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetIntFromObj(interp, value, &headerPtr->header.os) != TCL_OK) { @@ -511,14 +497,14 @@ GenerateHeader( * input data. */ - if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "time", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetLongFromObj(interp, value, (long *) &headerPtr->header.time) != TCL_OK) { goto error; } - if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "type", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types, "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { @@ -548,9 +534,6 @@ GenerateHeader( *---------------------------------------------------------------------- */ -#define SetValue(dictObj, key, value) \ - Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value)) - static void ExtractHeader( gz_header *headerPtr, /* The gzip header to extract from. */ @@ -573,9 +556,9 @@ ExtractHeader( Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1, &tmp); - SetValue(dictObj, "comment", TclDStringToObj(&tmp)); + TclDictPut(NULL, dictObj, "comment", TclDStringToObj(&tmp)); } - SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); + TclDictPut(NULL, dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); if (headerPtr->name != Z_NULL) { if (latin1enc == NULL) { /* @@ -590,17 +573,18 @@ ExtractHeader( Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, &tmp); - SetValue(dictObj, "filename", TclDStringToObj(&tmp)); + TclDictPut(NULL, dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { - SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os)); + TclDictPut(NULL, dictObj, "os", Tcl_NewIntObj(headerPtr->os)); } if (headerPtr->time != 0 /* magic - no time */) { - SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time)); + TclDictPut(NULL, dictObj, "time", + Tcl_NewLongObj((long) headerPtr->time)); } if (headerPtr->text != Z_UNKNOWN) { - SetValue(dictObj, "type", - Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1)); + TclDictPutString(NULL, dictObj, "type", + headerPtr->text ? "text" : "binary"); } if (latin1enc != NULL) { @@ -1889,7 +1873,7 @@ Tcl_ZlibInflate( Tcl_SetByteArrayLength(obj, stream.total_out); if (headerPtr != NULL) { ExtractHeader(&header, gzipHeaderDictObj); - SetValue(gzipHeaderDictObj, "size", + TclDictPut(NULL, gzipHeaderDictObj, "size", Tcl_NewLongObj(stream.total_out)); ckfree(nameBuf); ckfree(commentBuf); -- cgit v0.12 From 91c53be5fbab2ed2a60452e14a51159be9d9a208 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 13:53:52 +0000 Subject: Test to demonstrate [9ee9f4d7be]. Not fixed. --- tests/zlib.test | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index 5312d2b..61bddd9 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -1117,6 +1117,40 @@ if {$zlibbinf ne ""} { unset zlibbinf rename _zlibbinf {} +test zlib-14.1 {Bug 9ee9f4d7be: compression header added to source channel} -setup { + set data hello + set src [file tempfile] + puts -nonewline $src $data + flush $src + chan configure $src -translation binary + set dst [file tempfile] + chan configure $dst -translation binary + set result {} +} -constraints knownBug -body { + for {set i 0} {$i < 3} {incr i} { + # Determine size of src channel + seek $src 0 end + set size [chan tell $src] + seek $src 0 start + # Determine size of content in src channel + set data [read $src] + set size2 [string length $data] + seek $src 0 start + # Copy src over to dst, keep dst empty + zlib push deflate $src -level 6 + chan truncate $dst 0 + chan copy $src $dst + set size3 [chan tell $dst] + chan pop $src + # Show sizes + lappend result $size $size2 ->$size3 + } + return $result +} -cleanup { + chan close $src + chan close $dst +} -result {5 5 ->5 5 5 ->5 5 5 ->5} + ::tcltest::cleanupTests return -- cgit v0.12 From 3e56737166b9ae9be21274b4ff4c0318b19ff1a3 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 15:18:54 +0000 Subject: Check limits immediately when we do [interp eval]. [e3f4a8b78d] --- generic/tclInterp.c | 13 +++++++++++++ tests/interp.test | 18 ++++++++++++++++-- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b0f6207..ddca212 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2795,6 +2795,18 @@ ChildEval( Tcl_Preserve(childInterp); Tcl_AllowExceptions(childInterp); + /* + * If we're transferring to another interpreter, check it's limits first. + * It's much more reliable to do that now rather than waiting for the + * intermittent checks done during running; the slight performance hit for + * a cross-interp call is not a big problem. [Bug e3f4a8b78d] + */ + + if (interp != childInterp && Tcl_LimitCheck(childInterp) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (objc == 1) { /* * TIP #280: Make actual argument location available to eval'd script. @@ -2813,6 +2825,7 @@ ChildEval( result = Tcl_EvalObjEx(childInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } + done: Tcl_TransferResult(childInterp, result, interp); Tcl_Release(childInterp); diff --git a/tests/interp.test b/tests/interp.test index d742484..31c27ac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3326,13 +3326,13 @@ test interp-34.9 {time limits trigger in blocking after} { test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] # Assume someone hasn't set the clock to early 1970! - $i limit time -seconds 1 -granularity 4 + $i limit time -seconds [expr {[clock seconds] + 1}] -granularity 4 interp alias $i log {} lappend result set result {} catch { $i eval { log 1 - after 100 + after 1000 log 2 } } msg @@ -3409,6 +3409,20 @@ test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { } -cleanup { interp delete $i } -returnCodes error -result {limit exceeded} +test interp-34.14 {[Bug e3f4a8b78d]: interp limit and interp eval} -setup { + set i [interp create] + set result {} +} -body { + $i limit command -value [$i eval {info cmdcount}] + catch {$i eval [list expr 1+3]} msg + lappend result $msg + catch {$i eval [list expr 1+3]} msg + lappend result $msg + catch {interp eval $i [list expr 1+3]} msg + lappend result $msg +} -cleanup { + interp delete $i +} -result {{command count limit exceeded} {command count limit exceeded} {command count limit exceeded}} test interp-35.1 {interp limit syntax} -body { interp limit -- cgit v0.12