diff options
Diffstat (limited to 'generic')
37 files changed, 1035 insertions, 735 deletions
diff --git a/generic/tcl.h b/generic/tcl.h index b6eb20e..48f8f8d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 5 +#define TCL_RELEASE_SERIAL 6 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.5" +#define TCL_PATCH_LEVEL "8.6.6" /* *---------------------------------------------------------------------------- @@ -1165,6 +1165,18 @@ typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); /* + * This flag controls whether the hash table stores the hash of a key, or + * recalculates it. There should be no reason for turning this flag off as it + * is completely binary and source compatible unless you directly access the + * bucketPtr member of the Tcl_HashTableEntry structure. This member has been + * removed and the space used to store the hash value. + */ + +#ifndef TCL_HASH_KEY_STORE_HASH +# define TCL_HASH_KEY_STORE_HASH 1 +#endif + +/* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ @@ -1173,9 +1185,15 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ +#if TCL_HASH_KEY_STORE_HASH void *hash; /* Hash value, stored as pointer to ensure * that the offsets of the fields in this * structure are not changed. */ +#else + Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first + * entry in this entry's chain: used for + * deleting the entry. */ +#endif ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e5d7406..d6a460d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -128,7 +128,7 @@ static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; -static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +static Tcl_NRPostProc NRCommand; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); @@ -146,7 +146,6 @@ static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; @@ -723,9 +722,7 @@ Tcl_CreateInterp(void) * Initialize the ensemble error message rewriting support. */ - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; + TclResetRewriteEnsemble(interp, 1); /* * TIP#143: Initialise the resource limit support. @@ -4220,7 +4217,7 @@ EvalObjvCore( * TCL_EVAL_INVOKE was not set: clear rewrite rules */ - iPtr->ensembleRewrite.sourceObjs = NULL; + TclResetRewriteEnsemble(interp, 1); if (flags & TCL_EVAL_GLOBAL) { TEOV_SwitchVarFrame(interp); @@ -8373,7 +8370,7 @@ TclNRTailcallEval( * a now-gone namespace: cleanup and return. */ - TailcallCleanup(data, interp, result); + Tcl_DecrRefCount(listPtr); return result; } @@ -8382,18 +8379,26 @@ TclNRTailcallEval( */ TclMarkTailcall(interp); - TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); } -static int -TailcallCleanup( +int +TclNRReleaseValues( ClientData data[], Tcl_Interp *interp, int result) { - Tcl_DecrRefCount((Tcl_Obj *) data[0]); + int i = 0; + while (i < 4) { + if (data[i]) { + Tcl_DecrRefCount((Tcl_Obj *) data[i]); + } else { + break; + } + i++; + } return result; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 949cb1c..c3b29e9 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1499,7 +1499,19 @@ GetJulianDayFromEraYearMonthDay( * Try an initial conversion in the Gregorian calendar. */ +#if 0 /* BUG http://core.tcl.tk/tcl/tktview?name=da340d4f32 */ ym1o4 = ym1 / 4; +#else + /* + * Have to make sure quotient is truncated towards 0 when negative. + * See above bug for details. The casts are necessary. + */ + if (ym1 >= 0) + ym1o4 = ym1 / 4; + else { + ym1o4 = - (int) (((unsigned int) -ym1) / 4); + } +#endif if (ym1 % 4 < 0) { ym1o4--; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 54e0227..88cc17d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -12,6 +12,9 @@ */ #include "tclInt.h" +#ifdef _WIN32 +# include "tclWinInt.h" +#endif #include <locale.h> /* @@ -1157,6 +1160,16 @@ FileAttrAccessTimeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } +#if defined(_WIN32) + /* We use a value of 0 to indicate the access time not available */ + if (buf.st_atime == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get access time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; + } +#endif + if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit @@ -1229,6 +1242,15 @@ FileAttrModifyTimeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } +#if defined(_WIN32) + /* We use a value of 0 to indicate the modification time not available */ + if (buf.st_mtime == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get modification time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; + } +#endif if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit @@ -1574,28 +1596,25 @@ FileAttrIsOwnedCmd( int objc, Tcl_Obj *const objv[]) { +#ifdef __CYGWIN__ +#define geteuid() (short)(geteuid)() +#endif +#if !defined(_WIN32) Tcl_StatBuf buf; +#endif int value = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids associated with a file, so we - * always return 1. - * - * TODO: use GetSecurityInfo to get the real owner of the file and - * test for equivalence to the current user. - */ - -#if defined(_WIN32) || defined(__CYGWIN__) - value = 1; +#if defined(_WIN32) + value = TclWinFileOwned(objv[1]); #else + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { value = (geteuid() == buf.st_uid); -#endif } +#endif Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c93e593..0a1b4fe 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -105,8 +105,7 @@ typedef struct SortInfo { */ static int DictionaryCompare(const char *left, const char *right); -static int IfConditionCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc IfConditionCallback; static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 13f9e7d..885a0bc 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -22,14 +22,10 @@ static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static int SwitchPostProc(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostBody(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostFinal(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostHandler(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc SwitchPostProc; +static Tcl_NRPostProc TryPostBody; +static Tcl_NRPostProc TryPostFinal; +static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index c8474e6..428173d 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -70,18 +70,12 @@ static inline void DeleteChainTable(struct Dict *dict); static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, Tcl_Obj *keyPtr, int *newPtr); static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); -static int FinalizeDictUpdate(ClientData data[], - Tcl_Interp *interp, int result); -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); +static Tcl_NRPostProc FinalizeDictUpdate; +static Tcl_NRPostProc FinalizeDictWith; +static Tcl_ObjCmdProc DictForNRCmd; +static Tcl_ObjCmdProc DictMapNRCmd; +static Tcl_NRPostProc DictForLoopCallback; +static Tcl_NRPostProc DictMapLoopCallback; /* * Table of dict subcommand names and implementations. diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index c85fe13..1d616fb 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -6,7 +6,7 @@ * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2013 Donal K. Fellows. + * Copyright (c) 2013-2016 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1279,9 +1279,11 @@ Tcl_DisassembleObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const types[] = { + "constructor", "destructor", "lambda", "method", "objmethod", "proc", "script", NULL }; enum Types { + DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, DISAS_SCRIPT }; @@ -1290,6 +1292,7 @@ Tcl_DisassembleObjCmd( Proc *procPtr = NULL; Tcl_HashEntry *hPtr; Object *oPtr; + Method *methodPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); @@ -1384,6 +1387,136 @@ Tcl_DisassembleObjCmd( codeObjPtr = objv[2]; break; + case DISAS_CLASS_CONSTRUCTOR: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "className"); + return TCL_ERROR; + } + + /* + * Look up the body of a constructor. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == 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; + } + + methodPtr = oPtr->classPtr->constructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined constructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "CONSRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + /* + * Compile if necessary. + */ + + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of constructor", + TclGetString(objv[2])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + + case DISAS_CLASS_DESTRUCTOR: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "className"); + return TCL_ERROR; + } + + /* + * Look up the body of a destructor. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == 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; + } + + methodPtr = oPtr->classPtr->destructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined destructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "DESRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of destructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + /* + * Compile if necessary. + */ + + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of destructor", + TclGetString(objv[2])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + case DISAS_CLASS_METHOD: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5b96730..5c65a3c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -367,7 +367,6 @@ DupEncodingIntRep( Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); - dupPtr->typePtr = &encodingType; } /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 986a553..8e5e410 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -30,11 +30,10 @@ static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); static void DeleteEnsembleConfig(ClientData clientData); static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - const char *subcmdName, Tcl_Obj *prefixObjPtr); + EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, + Tcl_Obj *fix); static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); @@ -42,6 +41,8 @@ static int CompileBasicNArgCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr); +static Tcl_NRPostProc FreeER; + /* * The lists of subcommands and options for the [namespace ensemble] command. */ @@ -77,14 +78,30 @@ enum EnsConfigOpts { * that implements it. */ -const Tcl_ObjType tclEnsembleCmdType = { +static const Tcl_ObjType ensembleCmdType = { "ensembleCommand", /* the type's name */ FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ - StringOfEnsembleCmdRep, /* updateStringProc */ + NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; +/* + * The internal rep for caching ensemble subcommand lookups and + * spell corrections. + */ + +typedef struct { + int epoch; /* Used to confirm when the data in this + * really structure matches up with the + * ensemble. */ + Command *token; /* Reference to the command for which this + * structure is a cache of the resolution. */ + Tcl_Obj *fix; /* Corrected spelling, if needed. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand + * hash table. */ +} EnsembleCmdRep; + static inline Tcl_Obj * NewNsObj( @@ -1643,6 +1660,8 @@ NsEnsembleImplementationCmdNR( * names. */ int reparseCount = 0; /* Number of reparses. */ Tcl_Obj *errorObj; /* Used for building error messages. */ + Tcl_Obj *subObj; + int subIdx; /* * Must recheck objc, since numParameters might have changed. Cf. test @@ -1650,24 +1669,18 @@ NsEnsembleImplementationCmdNR( */ restartEnsembleParse: - if (objc < 2 + ensemblePtr->numParameters) { + subIdx = 1 + ensemblePtr->numParameters; + if (objc < subIdx + 1) { /* * We don't have a subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ - Tcl_Obj **elemPtrs; /* Parameter names */ - int len; /* Number of parameters to append */ Tcl_DStringInit(&buf); - if (ensemblePtr->parameterList == NULL) { - len = 0; - } else if (TclListObjGetElements(NULL, ensemblePtr->parameterList, - &len, &elemPtrs) != TCL_OK) { - Tcl_Panic("List of ensemble parameters is not a list"); - } - for (; len>0; len--,elemPtrs++) { - TclDStringAppendObj(&buf, *elemPtrs); + if (ensemblePtr->parameterList) { + Tcl_DStringAppend(&buf, + TclGetString(ensemblePtr->parameterList), -1); TclDStringAppendLiteral(&buf, " "); } TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); @@ -1695,6 +1708,8 @@ NsEnsembleImplementationCmdNR( * up in there and go straight to dispatch. */ + subObj = objv[subIdx]; + if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* * Table of subcommands is still valid; therefore there might be a @@ -1703,15 +1718,16 @@ NsEnsembleImplementationCmdNR( * part where we do the invocation of the subcommand. */ - if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ - EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] - ->internalRep.twoPtrValue.ptr1; + if (subObj->typePtr==&ensembleCmdType){ + EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; - if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && - ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == ensemblePtr->token) { - prefixObj = ensembleCmd->realPrefixObj; + if (ensembleCmd->epoch == ensemblePtr->epoch && + ensembleCmd->token == (Command *)ensemblePtr->token) { + prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); + if (ensembleCmd->fix) { + TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix); + } goto runResultingSubcommand; } } @@ -1726,18 +1742,14 @@ NsEnsembleImplementationCmdNR( */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, - TclGetString(objv[1 + ensemblePtr->numParameters])); + TclGetString(subObj)); if (hPtr != NULL) { - char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); - - prefixObj = Tcl_GetHashValue(hPtr); /* * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], - ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Could not map, no prefixing, go to unknown/error handling. @@ -1757,9 +1769,9 @@ NsEnsembleImplementationCmdNR( char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; + Tcl_Obj *fix; - subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]); - stringLength = objv[1 + ensemblePtr->numParameters]->length; + subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -1799,16 +1811,22 @@ NsEnsembleImplementationCmdNR( Tcl_Panic("full name %s not found in supposedly synchronized hash", fullName); } - prefixObj = Tcl_GetHashValue(hPtr); + + /* + * Record the spelling correction for usage message. + */ + + fix = Tcl_NewStringObj(fullName, -1); /* * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], - ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix); + TclSpellFix(interp, objv, objc, subIdx, subObj, fix); } + prefixObj = Tcl_GetHashValue(hPtr); Tcl_IncrRefCount(prefixObj); runResultingSubcommand: @@ -1827,47 +1845,26 @@ NsEnsembleImplementationCmdNR( */ { - Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the - * target command prefix. */ Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. * Will be freed by the dispatch engine. */ - int prefixObjc, copyObjc; - Interp *iPtr = (Interp *) interp; + Tcl_Obj **copyObjv; + int copyObjc, prefixObjc; - /* - * Get the prefix that we're rewriting to. To do this we need to - * ensure that the internal representation of the list does not change - * so that we can safely keep the internal representations of the - * elements in the list. - * - * TODO: Use conventional list operations to make this code sane! - */ + Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); - TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); - - copyObjc = objc - 2 + prefixObjc; - copyPtr = Tcl_NewListObj(copyObjc, NULL); - if (copyObjc > 0) { - register Tcl_Obj **copyObjv; - /* Space used to construct the list of - * arguments to pass to the command that - * implements the ensemble subcommand. */ - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - register int i; - - listRepPtr->elemCount = copyObjc; - copyObjv = &listRepPtr->elements; - memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(copyObjv+prefixObjc, objv+1, - sizeof(Tcl_Obj *) * ensemblePtr->numParameters); - memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters, - objv+ensemblePtr->numParameters+2, - sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2)); - - for (i=0; i < copyObjc; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - } + if (objc == 2) { + copyPtr = TclListObjCopy(NULL, prefixObj); + } else { + copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); + Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + ensemblePtr->numParameters, objv + 1); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + objc - 2 - ensemblePtr->numParameters, + objv + 2 + ensemblePtr->numParameters); + } + Tcl_IncrRefCount(copyPtr); + TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL); TclDecrRefCount(prefixObj); /* @@ -1876,25 +1873,10 @@ NsEnsembleImplementationCmdNR( * count both as inserted and removed arguments. */ - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = - 2 + ensemblePtr->numParameters; - iPtr->ensembleRewrite.numInsertedObjs = - prefixObjc + ensemblePtr->numParameters; + if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, + prefixObjc + ensemblePtr->numParameters, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } else { - register int ni = 2 + ensemblePtr->numParameters - - iPtr->ensembleRewrite.numInsertedObjs; - /* Position in objv of new front of insertion - * relative to old one. */ - if (ni > 0) { - iPtr->ensembleRewrite.numRemovedObjs += ni; - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; - } else { - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; - } } /* @@ -1902,7 +1884,8 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); + Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: @@ -1934,20 +1917,17 @@ NsEnsembleImplementationCmdNR( Tcl_ResetResult(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); + TclGetString(subObj), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown subcommand \"%s\": namespace %s does not" - " export any commands", - TclGetString(objv[1+ensemblePtr->numParameters]), + " export any commands", TclGetString(subObj), ensemblePtr->nsPtr->fullName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), - TclGetString(objv[1+ensemblePtr->numParameters])); + TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); } else { @@ -2013,7 +1993,7 @@ TclInitRewriteEnsemble( if (numIns < numRemoved) { iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns; - iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1; + iPtr->ensembleRewrite.numInsertedObjs = numInserted; } else { iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved; } @@ -2054,6 +2034,149 @@ TclResetRewriteEnsemble( } /* + *---------------------------------------------------------------------- + * + * TclSpellFix -- + * + * Record a spelling correction that needs making in the + * generation of the WrongNumArgs usage message. + * + * Results: + * None. + * + * Side effects: + * Can create an alternative ensemble rewrite structure. + * + *---------------------------------------------------------------------- + */ + +static int +FreeER( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj **tmp = (Tcl_Obj **)data[0]; + + ckfree(tmp[2]); + ckfree(tmp); + return result; +} + +void +TclSpellFix( + Tcl_Interp *interp, + Tcl_Obj *const *objv, + int objc, + int badIdx, + Tcl_Obj *bad, + Tcl_Obj *fix) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *const *search; + Tcl_Obj **store; + int idx; + int size; + + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + + /* Compute the valid length of the ensemble root */ + + size = iPtr->ensembleRewrite.numRemovedObjs + objc + - iPtr->ensembleRewrite.numInsertedObjs; + + search = iPtr->ensembleRewrite.sourceObjs; + if (search[0] == NULL) { + /* Awful casting abuse here */ + search = (Tcl_Obj *const *) search[1]; + } + + if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { + /* + * Misspelled value was inserted. We cannot directly jump + * to the bad value, but have to search. + */ + idx = 1; + while (idx < size) { + if (search[idx] == bad) { + break; + } + idx++; + } + if (idx == size) { + return; + } + } else { + /* Jump to the misspelled value. */ + idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx + - iPtr->ensembleRewrite.numInsertedObjs; + + /* Verify */ + if (search[idx] != bad) { + Tcl_Panic("SpellFix: programming error"); + } + } + + search = iPtr->ensembleRewrite.sourceObjs; + if (search[0] == NULL) { + store = (Tcl_Obj **)search[2]; + } else { + Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *)); + tmp[0] = NULL; + tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs; + tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *)); + memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *)); + + iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp; + TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL); + store = (Tcl_Obj **)tmp[2]; + } + + store[idx] = fix; + Tcl_IncrRefCount(fix); + TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclFetchEnsembleRoot -- + * + * Returns the root of ensemble rewriting, if any. + * If no root exists, returns objv instead. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj *const * +TclFetchEnsembleRoot( + Tcl_Interp *interp, + Tcl_Obj *const *objv, + int objc, + int *objcPtr) +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->ensembleRewrite.sourceObjs) { + *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + return iPtr->ensembleRewrite.sourceObjs; + } + *objcPtr = objc; + return objv; +} + +/* * ---------------------------------------------------------------------- * * EnsmebleUnknownCallback -- @@ -2218,17 +2341,17 @@ static void MakeCachedEnsembleCommand( Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, - const char *subcommandName, - Tcl_Obj *prefixObjPtr) + Tcl_HashEntry *hPtr, + Tcl_Obj *fix) { register EnsembleCmdRep *ensembleCmd; - int length; - if (objPtr->typePtr == &tclEnsembleCmdType) { + if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DecrRefCount(ensembleCmd->realPrefixObj); - TclNsDecrRefCount(ensembleCmd->nsPtr); - ckfree(ensembleCmd->fullSubcmdName); + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { + Tcl_DecrRefCount(ensembleCmd->fix); + } } else { /* * Kill the old internal rep, and replace it with a brand new one of @@ -2238,22 +2361,21 @@ MakeCachedEnsembleCommand( TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; - objPtr->typePtr = &tclEnsembleCmdType; + objPtr->typePtr = &ensembleCmdType; } /* * Populate the internal rep. */ - ensembleCmd->nsPtr = ensemblePtr->nsPtr; ensembleCmd->epoch = ensemblePtr->epoch; - ensembleCmd->token = ensemblePtr->token; - ensemblePtr->nsPtr->refCount++; - ensembleCmd->realPrefixObj = prefixObjPtr; - length = strlen(subcommandName)+1; - ensembleCmd->fullSubcmdName = ckalloc(length); - memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); - Tcl_IncrRefCount(ensembleCmd->realPrefixObj); + ensembleCmd->token = (Command *) ensemblePtr->token; + ensembleCmd->token->refCount++; + if (fix) { + Tcl_IncrRefCount(fix); + } + ensembleCmd->fix = fix; + ensembleCmd->hPtr = hPtr; } /* @@ -2634,9 +2756,10 @@ FreeEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DecrRefCount(ensembleCmd->realPrefixObj); - ckfree(ensembleCmd->fullSubcmdName); - TclNsDecrRefCount(ensembleCmd->nsPtr); + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { + Tcl_DecrRefCount(ensembleCmd->fix); + } ckfree(ensembleCmd); objPtr->typePtr = NULL; } @@ -2666,48 +2789,17 @@ DupEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - int length = strlen(ensembleCmd->fullSubcmdName); - copyPtr->typePtr = &tclEnsembleCmdType; + copyPtr->typePtr = &ensembleCmdType; copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; - ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; - ensembleCopy->nsPtr->refCount++; - ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; - Tcl_IncrRefCount(ensembleCopy->realPrefixObj); - ensembleCopy->fullSubcmdName = ckalloc(length + 1); - memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, - (unsigned) length+1); -} - -/* - *---------------------------------------------------------------------- - * - * StringOfEnsembleCmdRep -- - * - * Creates a string representation of a Tcl_Obj that holds a subcommand - * of an ensemble. - * - * Results: - * None. - * - * Side effects: - * The object gains a string (UTF-8) representation. - * - *---------------------------------------------------------------------- - */ - -static void -StringOfEnsembleCmdRep( - Tcl_Obj *objPtr) -{ - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - int length = strlen(ensembleCmd->fullSubcmdName); - - objPtr->length = length; - objPtr->bytes = ckalloc(length + 1); - memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); + ensembleCopy->token->refCount++; + ensembleCopy->fix = ensembleCmd->fix; + if (ensembleCopy->fix) { + Tcl_IncrRefCount(ensembleCopy->fix); + } + ensembleCopy->hPtr = ensembleCmd->hPtr; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 70ccc05..e539161 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -35,14 +35,14 @@ #endif /* - * A counter that is used to work out when the bytecode engine should call - * Tcl_AsyncReady() to see whether there is a signal that needs handling, and - * other expensive periodic operations. + * A mask (should be 2**n-1) that is used to work out when the bytecode engine + * should call Tcl_AsyncReady() to see whether there is a signal that needs + * handling. */ -#ifndef ASYNC_CHECK_COUNT -# define ASYNC_CHECK_COUNT 64 -#endif /* !ASYNC_CHECK_COUNT */ +#ifndef ASYNC_CHECK_COUNT_MASK +# define ASYNC_CHECK_COUNT_MASK 63 +#endif /* !ASYNC_CHECK_COUNT_MASK */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -2078,6 +2078,13 @@ TclNRExecuteByteCode( #endif /* + * Test namespace-50.9 demonstrates the need for this call. + * Use a --enable-symbols=mem bug to see. + */ + + TclResetRewriteEnsemble(interp, 1); + + /* * Push the callback for bytecode execution */ @@ -2115,14 +2122,8 @@ TEBCresume( * sporadically: no special need for speed. */ - unsigned interruptCounter = 1; - /* Counter that is used to work out when to - * call Tcl_AsyncReady(). This must be 1 - * initially so that we call the async-check - * stanza early, otherwise there are command - * sequences that can make the interpreter - * busy-loop without an opportunity to - * recognise an interrupt. */ + int instructionCount = 0; /* Counter that is used to work out when to + * call Tcl_AsyncReady() */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level @@ -2320,11 +2321,10 @@ TEBCresume( /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT instructions. + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ - if ((--interruptCounter) == 0) { - interruptCounter = ASYNC_CHECK_COUNT; + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); @@ -3160,35 +3160,34 @@ TEBCresume( fflush(stdout); } #endif /*TCL_COMPILE_DEBUG*/ - { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj **copyObjv = &listRepPtr->elements; - int i; - listRepPtr->elemCount = objc - opnd + 1; - copyObjv[0] = objPtr; - memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd)); - for (i=1 ; i<objc-opnd+1 ; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - objPtr = copyPtr; - } bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = opnd; - iPtr->ensembleRewrite.numInsertedObjs = 1; + + TclInitRewriteEnsemble(interp, opnd, 1, objv); + + { + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); + + Tcl_ListObjAppendElement(NULL, copyPtr, objPtr); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + objc - opnd, objv + opnd); + Tcl_DecrRefCount(objPtr); + objPtr = copyPtr; + } + DECACHE_STACK_INFO(); pc += 6; TEBC_YIELD(); TclMarkTailcall(interp); - TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); /* * ----------------------------------------------------------------- @@ -4421,8 +4420,8 @@ TEBCresume( savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { TRACE_ERROR(interp); diff --git a/generic/tclHash.c b/generic/tclHash.c index 3ea9dd9..1991aea 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -321,9 +321,11 @@ CreateHashEntry( for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) { if (newPtr) { *newPtr = 0; @@ -334,9 +336,11 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif if (key == hPtr->key.oneWordValue) { if (newPtr) { *newPtr = 0; @@ -364,9 +368,15 @@ CreateHashEntry( } hPtr->tablePtr = tablePtr; +#if TCL_HASH_KEY_STORE_HASH hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + hPtr->bucketPtr = &tablePtr->buckets[index]; + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif tablePtr->numEntries++; /* @@ -406,7 +416,9 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; +#if TCL_HASH_KEY_STORE_HASH int index; +#endif tablePtr = entryPtr->tablePtr; @@ -421,6 +433,7 @@ Tcl_DeleteHashEntry( typePtr = &tclArrayHashKeyType; } +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); @@ -429,6 +442,9 @@ Tcl_DeleteHashEntry( } bucketPtr = &tablePtr->buckets[index]; +#else + bucketPtr = entryPtr->bucketPtr; +#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; @@ -1046,6 +1062,7 @@ RebuildTable( for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); @@ -1054,6 +1071,26 @@ RebuildTable( } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + void *key = Tcl_GetHashKey(tablePtr, hPtr); + + if (typePtr->hashKeyProc) { + unsigned int hash; + + hash = typePtr->hashKeyProc(tablePtr, key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX(tablePtr, hash); + } else { + index = hash & tablePtr->mask; + } + } else { + index = RANDOM_INDEX(tablePtr, key); + } + + hPtr->bucketPtr = &tablePtr->buckets[index]; + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif } } diff --git a/generic/tclIO.c b/generic/tclIO.c index f93d00d..80f6fa4 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -313,15 +313,20 @@ static int WillRead(Channel *chanPtr); && (strncmp(optionName, (nameString), len) == 0)) /* - * The ChannelObjType type. We actually store the ChannelState structure - * as that lives longest and we want to return the bottomChanPtr when - * requested (consistent with Tcl_GetChannel). The setFromAny and - * updateString can be NULL as they should not be called. + * The ChannelObjType type. Used to store the result of looking up + * a channel name in the context of an interp. Saves the lookup + * result and values needed to check its continued validity. */ +typedef struct ResolvedChanName { + ChannelState *statePtr; /* The saved lookup result */ + Tcl_Interp *interp; /* The interp in which the lookup was done. */ + int epoch; /* The epoch of the channel when the lookup + * was done. Use to verify validity. */ + int refCount; /* Share this struct among many Tcl_Obj. */ +} ResolvedChanName; + static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static int SetChannelFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); static const Tcl_ObjType chanObjType = { @@ -329,18 +334,9 @@ static const Tcl_ObjType chanObjType = { FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc SetChannelFromAny */ + NULL /* setFromAnyProc */ }; -#define GET_CHANNELSTATE(objPtr) \ - ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_CHANNELSTATE(objPtr, storePtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) -#define GET_CHANNELINTERP(objPtr) \ - ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) -#define SET_CHANNELINTERP(objPtr, storePtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) - #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -1021,7 +1017,7 @@ DeleteChannelTable( */ Tcl_DeleteHashEntry(hPtr); - SetFlag(statePtr, CHANNEL_TAINTED); + statePtr->epoch++; if (statePtr->refCount-- <= 1) { if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); @@ -1365,7 +1361,7 @@ DetachChannel( return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); - SetFlag(statePtr, CHANNEL_TAINTED); + statePtr->epoch++; /* * Remove channel handlers that refer to this interpreter, so that @@ -1498,12 +1494,57 @@ TclGetChannelFromObj( int flags) { ChannelState *statePtr; + ResolvedChanName *resPtr = NULL; + Tcl_Channel chan; + + if (interp == NULL) { + return TCL_ERROR; + } + + if (objPtr->typePtr == &chanObjType) { + /* + * Confirm validity of saved lookup results. + */ + + resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; + statePtr = resPtr->statePtr; + if ((resPtr->interp == interp) /* Same interp context */ + /* No epoch change in channel since lookup */ + && (resPtr->epoch == statePtr->epoch)) { + + /* Have a valid saved lookup. Jump to end to return it. */ + goto valid; + } + } + + chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - if (SetChannelFromAny(interp, objPtr) != TCL_OK) { + if (chan == NULL) { + if (resPtr) { + FreeChannelIntRep(objPtr); + } return TCL_ERROR; } - statePtr = GET_CHANNELSTATE(objPtr); + if (resPtr && resPtr->refCount == 1) { + /* Re-use the ResolvedCmdName struct */ + Tcl_Release((ClientData) resPtr->statePtr); + + } else { + TclFreeIntRep(objPtr); + + resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; + objPtr->typePtr = &chanObjType; + } + statePtr = ((Channel *)chan)->state; + resPtr->statePtr = statePtr; + Tcl_Preserve((ClientData) statePtr); + resPtr->interp = interp; + resPtr->epoch = statePtr->epoch; + + valid: *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; if (modePtr != NULL) { @@ -1676,6 +1717,8 @@ Tcl_CreateChannel( statePtr->chanMsg = NULL; statePtr->unreportedMsg = NULL; + statePtr->epoch = 0; + /* * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels in @@ -11121,78 +11164,16 @@ DupChannelIntRep( register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); + ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; - SET_CHANNELSTATE(copyPtr, statePtr); - SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr)); - Tcl_Preserve(statePtr); + resPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->typePtr = srcPtr->typePtr; } /* *---------------------------------------------------------------------- * - * SetChannelFromAny -- - * - * Create an internal representation of type "Channel" for an object. - * - * Results: - * This operation always succeeds and returns TCL_OK. - * - * Side effects: - * Any old internal reputation for objPtr is freed and the internal - * representation is set to "Channel". - * - *---------------------------------------------------------------------- - */ - -static int -SetChannelFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - ChannelState *statePtr; - - if (interp == NULL) { - return TCL_ERROR; - } - if (objPtr->typePtr == &chanObjType) { - /* - * TODO: TAINT Flag and dup'd channel values? - * The channel is valid until any call to DetachChannel occurs. - * Ensure consistency checks are done. - */ - - statePtr = GET_CHANNELSTATE(objPtr); - if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) { - ResetFlag(statePtr, CHANNEL_TAINTED); - Tcl_Release(statePtr); - objPtr->typePtr = NULL; - } else if (interp != GET_CHANNELINTERP(objPtr)) { - Tcl_Release(statePtr); - objPtr->typePtr = NULL; - } - } - if (objPtr->typePtr != &chanObjType) { - Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - - if (chan == NULL) { - return TCL_ERROR; - } - - TclFreeIntRep(objPtr); - statePtr = ((Channel *) chan)->state; - Tcl_Preserve(statePtr); - SET_CHANNELSTATE(objPtr, statePtr); - SET_CHANNELINTERP(objPtr, interp); - objPtr->typePtr = &chanObjType; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * FreeChannelIntRep -- * * Release statePtr storage. @@ -11210,8 +11191,14 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Release(GET_CHANNELSTATE(objPtr)); + ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + objPtr->typePtr = NULL; + if (--resPtr->refCount) { + return; + } + Tcl_Release(resPtr->statePtr); + ckfree(resPtr); } #if 0 diff --git a/generic/tclIO.h b/generic/tclIO.h index b799375..ffbfa31 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -214,6 +214,8 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ + int epoch; /* Used to test validity of stored channelname + * lookup results. */ } ChannelState; /* @@ -275,10 +277,6 @@ typedef struct ChannelState { * usable, but it may not be closed * again from within the close * handler. */ -#define CHANNEL_TAINTED (1<<20) /* Channel stack structure has changed. - * Used by Channel Tcl_Obj type to - * determine if we have to revalidate - * the channel. */ #define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed. * No further Tcl-level write IO on * the channel is allowed. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index de65da5..834f225 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -16,7 +16,7 @@ */ typedef struct AcceptCallback { - Tcl_Obj *script; /* Script to invoke. */ + char *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -37,7 +37,8 @@ static Tcl_ThreadDataKey dataKey; */ static void FinalizeIOCmdTSD(ClientData clientData); -static Tcl_TcpAcceptProc AcceptCallbackProc; +static void AcceptCallbackProc(ClientData callbackData, + Tcl_Channel chan, char *address, int port); static int ChanPendingObjCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -1372,22 +1373,15 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { + char portBuf[TCL_INTEGER_SPACE]; + char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - Tcl_Obj *script, *objv[2]; - int result = TCL_OK; - - objv[0] = acceptCallbackPtr->script; - objv[1] = Tcl_NewListObj(3, NULL); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( - Tcl_GetChannelName(chan), -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); - - script = Tcl_ConcatObj(2, objv); - Tcl_IncrRefCount(script); - Tcl_DecrRefCount(objv[1]); + int result; + Tcl_Preserve(script); Tcl_Preserve(interp); + + TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* @@ -1397,9 +1391,8 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(script); - + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, NULL); if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); @@ -1413,6 +1406,7 @@ AcceptCallbackProc( Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); + Tcl_Release(script); } else { /* * The interpreter has been deleted, so there is no useful way to use @@ -1456,7 +1450,7 @@ TcpServerCloseProc( UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_DecrRefCount(acceptCallbackPtr->script); + Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); ckfree(acceptCallbackPtr); } @@ -1491,8 +1485,7 @@ Tcl_SocketObjCmd( SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; int optionIndex, a, server = 0, port, myport = 0, async = 0; - const char *host, *myaddr = NULL; - Tcl_Obj *script = NULL; + const char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { @@ -1555,7 +1548,7 @@ Tcl_SocketObjCmd( "no argument given for -server option", -1)); return TCL_ERROR; } - script = objv[a]; + script = TclGetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1596,14 +1589,16 @@ Tcl_SocketObjCmd( if (server) { AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); + unsigned len = strlen(script) + 1; + char *copyScript = ckalloc(len); - Tcl_IncrRefCount(script); - acceptCallbackPtr->script = script; + memcpy(copyScript, script, len); + acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { - Tcl_DecrRefCount(script); + ckfree(copyScript); ckfree(acceptCallbackPtr); return TCL_ERROR; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 0ef6d3b..142693e 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -71,8 +71,7 @@ typedef struct ThreadSpecificData { * Prototypes for functions defined later in this file. */ -static int EvalFileCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc EvalFileCallback; static FilesystemRecord*FsGetFirstFilesystem(void); static void FsThrExitProc(ClientData cd); static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index ce8b9fb..0e0ddc9 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -925,6 +925,14 @@ Tcl_WrongNumArgs( Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; /* + * Check for spelling fixes, and substitute the fixed values. + */ + + if (origObjv[0] == NULL) { + origObjv = (Tcl_Obj *const *)origObjv[2]; + } + + /* * We only know how to do rewriting if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just * gets too complicated and we'd be better off just giving a slightly @@ -957,12 +965,6 @@ Tcl_WrongNumArgs( elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); - } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { - register EnsembleCmdRep *ecrPtr = - origObjv[i]->internalRep.twoPtrValue.ptr1; - - elementStr = ecrPtr->fullSubcmdName; - elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } @@ -1011,11 +1013,6 @@ Tcl_WrongNumArgs( register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); - } else if (objv[i]->typePtr == &tclEnsembleCmdType) { - register EnsembleCmdRep *ecrPtr = - objv[i]->internalRep.twoPtrValue.ptr1; - - Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). diff --git a/generic/tclInt.h b/generic/tclInt.h index cd49c85..8445931 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -168,6 +168,35 @@ typedef struct Tcl_ResolverInfo { /* Procedure handling variable name resolution * at compile time. */ } Tcl_ResolverInfo; +/* + * This flag bit should not interfere with TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable + * lookup is performed for upvar (or similar) purposes, with slightly + * different rules: + * - Bug #696893 - variable is either proc-local or in the current + * namespace; never follow the second (global) resolution path + * - Bug #631741 - do not use special namespace or interp resolvers + * + * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag + * (Bug #835020) + */ + +#define TCL_AVOID_RESOLVERS 0x40000 + +/* + * This flag bit should not interfere with TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable + * lookup is performed for upvar (or similar) purposes, with slightly + * different rules: + * - Bug #696893 - variable is either proc-local or in the current + * namespace; never follow the second (global) resolution path + * - Bug #631741 - do not use special namespace or interp resolvers + * + * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag + * (Bug #835020) + */ + +#define TCL_AVOID_RESOLVERS 0x40000 /* *---------------------------------------------------------------- @@ -390,27 +419,6 @@ struct NamespacePathEntry { #define TCL_FIND_ONLY_NS 0x1000 /* - * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in - * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs - * referring to the same subcommand, even where one is a duplicate of another. - */ - -typedef struct { - Namespace *nsPtr; /* The namespace backing the ensemble which - * this is a subcommand of. */ - int epoch; /* Used to confirm when the data in this - * really structure matches up with the - * ensemble. */ - Tcl_Command token; /* Reference to the comamnd for which this - * structure is a cache of the resolution. */ - char *fullSubcmdName; /* The full (local) name of the subcommand, - * allocated with ckalloc(). */ - Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the - * command that implements this ensemble - * subcommand. */ -} EnsembleCmdRep; - -/* * The client data for an ensemble command. This consists of the table of * commands that are actually exported by the namespace, and an epoch counter * that, combined with the exportLookupEpoch field of the namespace structure, @@ -2762,6 +2770,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; +MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); @@ -2872,8 +2881,7 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; -MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], - Tcl_Interp *interp, int result); +MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, @@ -2909,6 +2917,8 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); +MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, + Tcl_Obj *const *objv, int objc, int *objcPtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); @@ -3112,6 +3122,9 @@ MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); +MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, + Tcl_Obj *const *objv, int objc, int subIdx, + Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, @@ -3135,7 +3148,6 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE int TclUtfCount(int ch); 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, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index cd0dc18..66ce1e0 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1795,11 +1795,9 @@ AliasNRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Interp *iPtr = (Interp *) interp; Alias *aliasPtr = clientData; int prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; - int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); Tcl_Obj *listPtr; List *listRep; int flags = TCL_EVAL_INVOKE; @@ -1831,21 +1829,7 @@ AliasNRCmd( * only the source command should show, not the full target prefix. */ - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 1; - iPtr->ensembleRewrite.numInsertedObjs = prefc; - } else { - iPtr->ensembleRewrite.numInsertedObjs += prefc - 1; - } - - /* - * We are sending a 0-refCount obj, do not need a callback: it will be - * cleaned up automatically. But we may need to clear the rootEnsemble - * stuff ... - */ - - if (isRootEnsemble) { + if (TclInitRewriteEnsemble(interp, 1, prefc, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } TclSkipTailcall(interp); @@ -1866,7 +1850,7 @@ AliasObjCmd( Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; Interp *tPtr = (Interp *) targetInterp; - int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); + int isRootEnsemble; /* * Append the arguments to the command prefix and invoke the command in @@ -1896,13 +1880,7 @@ AliasObjCmd( * only the source command should show, not the full target prefix. */ - if (isRootEnsemble) { - tPtr->ensembleRewrite.sourceObjs = objv; - tPtr->ensembleRewrite.numRemovedObjs = 1; - tPtr->ensembleRewrite.numInsertedObjs = prefc; - } else { - tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; - } + isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)tPtr, 1, prefc, objv); /* * Protect the target interpreter if it isn't the same as the source @@ -1925,9 +1903,7 @@ AliasObjCmd( */ if (isRootEnsemble) { - tPtr->ensembleRewrite.sourceObjs = NULL; - tPtr->ensembleRewrite.numRemovedObjs = 0; - tPtr->ensembleRewrite.numInsertedObjs = 0; + TclResetRewriteEnsemble((Tcl_Interp *)tPtr, 1); } /* diff --git a/generic/tclMain.c b/generic/tclMain.c index 6946375..1a390b9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -335,6 +335,7 @@ Tcl_MainEx( #ifdef ZIPFS_IN_TCL const char *zipFile = NULL; Tcl_Obj *zipval = NULL; + Tcl_Obj *checkAppName = NULL; int autoRun = 1; int zipOk = TCL_ERROR; #ifndef ANDROID @@ -410,6 +411,9 @@ Tcl_MainEx( if (path == NULL) { appName = NewNativeObj(argv[0], -1); } else { +#ifdef ZIPFS_IN_TCL + checkAppName = path; +#endif appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); @@ -496,7 +500,7 @@ Tcl_MainEx( zipval = NULL; } #endif - + /* * Invoke application-specific initialization. */ @@ -565,18 +569,41 @@ Tcl_MainEx( */ if ((zipOk == TCL_OK) && autoRun) { - char *filename; + int pushBack = 1; + char *filename = NULL; Tcl_Channel chan; -#ifdef ZIPFS_BOOTDIR - filename = ZIPFS_BOOTDIR "/app/main.tcl"; -#else Tcl_DString dsFile; Tcl_DStringInit(&dsFile); +#ifdef ZIPFS_BOOTDIR + Tcl_DStringAppend(&dsFile, ZIPFS_BOOTDIR, -1); +#else Tcl_DStringAppend(&dsFile, Tcl_GetString(mntpt), -1); - Tcl_DStringAppend(&dsFile, "/app/main.tcl", -1); - filename = Tcl_DStringValue(&dsFile); #endif + if (checkAppName != NULL) { + filename = Tcl_GetString(checkAppName); + if ((strlen(filename) > 8) && + (strncasecmp(filename, "builtin:", 8) == 0)) { + filename += 8; + while (filename[0] == '/') { + ++filename; + } + if (filename[0] != '\0') { + pushBack = 0; + } else { + filename = NULL; + } + } else { + filename = NULL; + } + } + if (filename != NULL) { + Tcl_DStringAppend(&dsFile, "/", 1); + Tcl_DStringAppend(&dsFile, filename, -1); + } else { + Tcl_DStringAppend(&dsFile, "/app/main.tcl", -1); + } + filename = Tcl_DStringValue(&dsFile); chan = Tcl_OpenFileChannel(NULL, filename, "r", 0); if (chan != (Tcl_Channel) NULL) { Tcl_Obj *arg; @@ -586,7 +613,7 @@ Tcl_MainEx( /* * Push back script file to argv, if any. */ - if ((arg = Tcl_GetStartupScript(NULL)) != NULL) { + if (pushBack && (arg = Tcl_GetStartupScript(NULL)) != NULL) { Tcl_Obj *v, *no; no = Tcl_NewStringObj("argv", 4); @@ -605,18 +632,18 @@ Tcl_MainEx( if (Tcl_ObjSetVar2(interp, no, NULL, nv, TCL_GLOBAL_ONLY) != NULL) { Tcl_GlobalEval(interp, "incr argc"); - } + } Tcl_DecrRefCount(nv); } Tcl_DecrRefCount(no); } Tcl_SetStartupScript(Tcl_NewStringObj(filename, -1), NULL); - Tcl_SetVar(interp, "argv0", filename, TCL_GLOBAL_ONLY); + if (pushBack) { + Tcl_SetVar(interp, "argv0", filename, TCL_GLOBAL_ONLY); + } Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); } -#ifndef ANDROID Tcl_DStringFree(&dsFile); -#endif } #endif diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 58a86d9..5930859 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -3354,14 +3354,7 @@ NRNamespaceEvalCmd( (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; - } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; - } + framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); if (objc == 3) { /* @@ -3768,7 +3761,6 @@ NRNamespaceInscopeCmd( { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; - register Interp *iPtr = (Interp *) interp; int i; Tcl_Obj *cmdObjPtr; @@ -3794,14 +3786,7 @@ NRNamespaceInscopeCmd( (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; - } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; - } + framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); /* * Execute the command. If there is just one argument, just treat it as a @@ -4553,8 +4538,8 @@ NamespaceUpvarCmd( savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; if (otherPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclOO.c b/generic/tclOO.c index 9df5029..ec666ee 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -68,12 +68,9 @@ static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, static void DeletedDefineNamespace(ClientData clientData); static void DeletedObjdefNamespace(ClientData clientData); static void DeletedHelpersNamespace(ClientData clientData); -static int FinalizeAlloc(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeNext(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeObjectCall(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeAlloc; +static Tcl_NRPostProc FinalizeNext; +static Tcl_NRPostProc FinalizeObjectCall; static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -1687,7 +1684,7 @@ Tcl_NewObjectInstance( TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr != NULL) { - int result; + int isRoot, result; Tcl_InterpState state; state = Tcl_SaveInterpState(interp, TCL_OK); @@ -1698,13 +1695,14 @@ Tcl_NewObjectInstance( * Adjust the ensmble tracking record if necessary. [Bug 3514761] */ - if (((Interp*) interp)->ensembleRewrite.sourceObjs) { - ((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1; - ((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1; - } + isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); + } + /* * It's an error if the object was whacked in the constructor. * Force this if it isn't already an error (don't want to lose @@ -1827,9 +1825,8 @@ TclNRNewObjectInstance( * Adjust the ensmble tracking record if necessary. [Bug 3514761] */ - if (((Interp *) interp)->ensembleRewrite.sourceObjs) { - ((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1; - ((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1; + if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } /* diff --git a/generic/tclOO.h b/generic/tclOO.h index 696908a..46f01fb 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0.4" +#define TCLOO_VERSION "1.0.5" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index facf90d..1797760 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -70,15 +70,12 @@ static void AddSimpleClassChainToCallContext(Class *classPtr, Class *const filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); -static int FinalizeMethodRefs(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); -static int ResetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); -static int SetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc ResetFilterFlags; +static Tcl_NRPostProc SetFilterFlags; static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index c880754..8747ff5 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -847,9 +847,8 @@ TclOODefineObjCmd( TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; Tcl_Command cmd; - int dummy; + int isRoot, dummy; /* * More than one argument: fire them through the ensemble processing @@ -861,18 +860,7 @@ TclOODefineObjCmd( * the moment. Ugly! */ - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 3; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 3) { - iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 2; - } - } + isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv); /* * Build the list of arguments using a Tcl_Obj as a workspace. See @@ -894,6 +882,9 @@ TclOODefineObjCmd( Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); + } Tcl_DecrRefCount(objPtr); } DelRef(oPtr); @@ -927,7 +918,7 @@ TclOOObjDefObjCmd( Tcl_Obj *const *objv) { Foundation *fPtr = TclOOGetFoundation(interp); - int result; + int isRoot, result; Object *oPtr; if (objc < 3) { @@ -962,7 +953,6 @@ TclOOObjDefObjCmd( TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; Tcl_Command cmd; int dummy; @@ -976,18 +966,7 @@ TclOOObjDefObjCmd( * the moment. Ugly! */ - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 3; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 3) { - iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 2; - } - } + isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv); /* * Build the list of arguments using a Tcl_Obj as a workspace. See @@ -1009,6 +988,10 @@ TclOOObjDefObjCmd( Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); + + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); + } Tcl_DecrRefCount(objPtr); } DelRef(oPtr); @@ -1077,9 +1060,8 @@ TclOODefineSelfObjCmd( TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; Tcl_Command cmd; - int dummy; + int isRoot, dummy; /* * More than one argument: fire them through the ensemble processing @@ -1091,18 +1073,7 @@ TclOODefineSelfObjCmd( * the moment. Ugly! */ - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 2) { - iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 1; - } - } + isRoot = TclInitRewriteEnsemble(interp, 2, 1, objv); /* * Build the list of arguments using a Tcl_Obj as a workspace. See @@ -1124,6 +1095,9 @@ TclOODefineSelfObjCmd( Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE); + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); + } Tcl_DecrRefCount(objPtr); } DelRef(oPtr); diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 34fa108..99a8bfc 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -70,10 +70,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp, - int result); -static int FinalizePMCall(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc FinalizeForwardCall; +static Tcl_NRPostProc FinalizePMCall; static int PushMethodCallFrame(Tcl_Interp *interp, CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, @@ -1458,6 +1456,11 @@ InvokeForwardMethod( argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); + /* + * NOTE: The combination of direct set of iPtr->lookupNsPtr and the use + * of the TCL_EVAL_NOERR flag results in an evaluation configuration + * very much like TCL_EVAL_INVOKE. + */ ((Interp *)interp)->lookupNsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); @@ -1594,12 +1597,9 @@ InitEnsembleRewrite( int *lengthPtr) /* Where to write the resulting length of the * array of rewritten arguments. */ { - Interp *iPtr = (Interp *) interp; - int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); - Tcl_Obj **argObjs; unsigned len = rewriteLength + objc - toRewrite; + Tcl_Obj **argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); - argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, sizeof(Tcl_Obj *) * (objc - toRewrite)); @@ -1613,22 +1613,9 @@ InitEnsembleRewrite( * (and unavoidably). */ - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = toRewrite; - iPtr->ensembleRewrite.numInsertedObjs = rewriteLength; - } else { - int numIns = iPtr->ensembleRewrite.numInsertedObjs; - - if (numIns < toRewrite) { - iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns; - iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1; - } else { - iPtr->ensembleRewrite.numInsertedObjs += - rewriteLength - toRewrite; - } + if (TclInitRewriteEnsemble(interp, toRewrite, rewriteLength, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } - *lengthPtr = len; return argObjs; } diff --git a/generic/tclObj.c b/generic/tclObj.c index a45a392..628c3a7 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4176,7 +4176,7 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 99d576d..c2643bf 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -869,12 +869,16 @@ TclJoinPath( * object which can be normalized more efficiently. Currently we only * use the special case when we have exactly two elements, but we * could expand that in the future. + * + * Bugfix [a47641a0]. TclNewFSPathObj requires first argument + * to be an absolute path. Added a check for that elt is absolute. */ if ((i == (elements-2)) && (i == 0) - && (elt->typePtr == &tclFsPathType) - && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) { - Tcl_Obj *tailObj = objv[i+1]; + && (elt->typePtr == &tclFsPathType) + && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) + && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { + Tcl_Obj *tailObj = objv[i+1]; type = TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { diff --git a/generic/tclProc.c b/generic/tclProc.c index e8c5955..ae9e7cd 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -22,7 +22,6 @@ */ typedef struct { - int isRootEnsemble; Command cmd; ExtraFrameInfo efi; } ApplyExtraData; @@ -1088,12 +1087,10 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { - ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; - #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; #else - desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); + desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); #endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); @@ -1528,6 +1525,10 @@ InitArgsAndLocals( */ incorrectArgs: + if ((skip != 1) && + TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + } memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); return ProcWrongNumArgs(interp, skip); @@ -2634,7 +2635,7 @@ TclNRApplyObjCmd( Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; - int result, isRootEnsemble; + int result; Tcl_Namespace *nsPtr; ApplyExtraData *extraPtr; @@ -2717,16 +2718,6 @@ TclNRApplyObjCmd( extraPtr->efi.fields[0].clientData = lambdaPtr; extraPtr->cmd.clientData = &extraPtr->efi; - isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 1; - iPtr->ensembleRewrite.numInsertedObjs = 0; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 1; - } - extraPtr->isRootEnsemble = isRootEnsemble; - result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); @@ -2743,10 +2734,6 @@ ApplyNR2( { ApplyExtraData *extraPtr = data[0]; - if (extraPtr->isRootEnsemble) { - ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; - } - TclStackFree(interp, extraPtr); return result; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b480735..11a57e9 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -39,6 +39,15 @@ #include "tclStringRep.h" /* + * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. + * This is an escape hatch in case the changes have some unexpected unwelcome + * impact on performance. If things go well, this mechanism can go away when + * post-8.6 development begins. + */ + +#define COMPAT 0 + +/* * Prototypes for functions defined later in this file: */ @@ -436,6 +445,18 @@ Tcl_GetCharLength( if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; + +#if COMPAT + if (numChars < objPtr->length) { + /* + * Since we've just computed the number of chars, and not all UTF + * chars are 1-byte long, go ahead and populate the unicode + * string. + */ + + FillUnicodeRep(objPtr); + } +#endif } return numChars; } @@ -1152,7 +1173,11 @@ Tcl_AppendUnicodeToObj( * objPtr's string rep. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode +#if COMPAT + && stringPtr->numChars > 0 +#endif + ) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); @@ -1256,7 +1281,11 @@ Tcl_AppendObjToObj( * appendObjPtr and append it. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode +#if COMPAT + && stringPtr->numChars > 0 +#endif + ) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ @@ -1289,7 +1318,11 @@ Tcl_AppendObjToObj( AppendUtfToUtfRep(objPtr, bytes, length); - if (numChars >= 0 && appendNumChars >= 0) { + if (numChars >= 0 && appendNumChars >= 0 +#if COMPAT + && appendNumChars == length +#endif + ) { stringPtr->numChars = numChars + appendNumChars; } } @@ -1413,6 +1446,14 @@ AppendUnicodeToUtfRep( if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } + +#if COMPAT + /* + * Invalidate the unicode rep. + */ + + stringPtr->hasUnicode = 0; +#endif } /* @@ -2830,6 +2871,7 @@ DupStringInternalRep( String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; +#if COMPAT==0 if (srcStringPtr->numChars == -1) { /* * The String struct in the source value holds zero useful data. Don't @@ -2872,6 +2914,41 @@ DupStringInternalRep( */ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; +#else /* COMPAT!=0 */ + /* + * If the src obj is a string of 1-byte Utf chars, then copy the string + * rep of the source object and create an "empty" Unicode internal rep for + * the new object. Otherwise, copy Unicode internal rep, and invalidate + * the string rep of the new object. + */ + + if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { + /* + * Copy the full allocation for the Unicode buffer. + */ + + copyStringPtr = stringAlloc(srcStringPtr->maxChars); + copyStringPtr->maxChars = srcStringPtr->maxChars; + memcpy(copyStringPtr->unicode, srcStringPtr->unicode, + srcStringPtr->numChars * sizeof(Tcl_UniChar)); + copyStringPtr->unicode[srcStringPtr->numChars] = 0; + copyStringPtr->allocated = 0; + } else { + copyStringPtr = stringAlloc(0); + copyStringPtr->unicode[0] = 0; + copyStringPtr->maxChars = 0; + + /* + * Tricky point: the string value was copied by generic object + * management code, so it doesn't contain any extra bytes that might + * exist in the source object. + */ + + copyStringPtr->allocated = copyPtr->length; + } + copyStringPtr->numChars = srcStringPtr->numChars; + copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; +#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; @@ -2967,7 +3044,7 @@ ExtendStringRepWithUnicode( */ int i, origLength, size = 0; - char *dst; + char *dst, buf[TCL_UTF_MAX]; String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -2993,7 +3070,7 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { - size += TclUtfCount(unicode[i]); + size += Tcl_UniCharToUtf((int) unicode[i], buf); } if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); diff --git a/generic/tclTest.c b/generic/tclTest.c index 7c30d36..e33d263 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -323,9 +323,6 @@ static int TestparsevarObjCmd(ClientData dummy, static int TestparsevarnameObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestpreferstableObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); static int TestregexpObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -416,8 +413,7 @@ static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int NREUnwind_callback(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc NREUnwind_callback; static int TestNREUnwind(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -656,8 +652,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, - NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, @@ -3799,36 +3793,6 @@ TestparsevarnameObjCmd( /* *---------------------------------------------------------------------- * - * TestpreferstableObjCmd -- - * - * This procedure implements the "testpreferstable" command. It is - * used for being able to test the "package" command even when the - * environment variable TCL_PKG_PREFER_LATEST is set in your environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpreferstableObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - iPtr->packagePrefer = PKG_PREFER_STABLE; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f36b07f..a637498 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -19,6 +19,7 @@ #endif #include "tclInt.h" #include "tommath.h" +#include "tclStringRep.h" /* @@ -46,13 +47,6 @@ static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -typedef struct TestString { - int numChars; - int allocated; - int maxChars; - Tcl_UniChar unicode[2]; -} TestString; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 @@ -1141,7 +1135,7 @@ TeststringobjCmd( int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; - TestString *strPtr; + String *strPtr; Tcl_Obj **varPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index dd9edaf..bb074ba 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -87,7 +87,7 @@ extern "C" { # define DIGIT_BIT 60 #else /* this is the default case, 28-bit digits */ - + /* this is to make porting into LibTomCrypt easier :-) */ #ifndef CRYPT # if defined(_MSC_VER) || defined(__BORLANDC__) @@ -105,14 +105,14 @@ extern "C" { #endif typedef ulong64 mp_word; -#ifdef MP_31BIT +#ifdef MP_31BIT /* this is an extension that uses 31-bit digits */ # define DIGIT_BIT 31 #else /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ # define DIGIT_BIT 28 # define MP_28BIT -#endif +#endif #endif /* define heap macros */ @@ -646,7 +646,7 @@ int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); */ /* This gives [for a given bit size] the number of trials required - * such that Miller-Rabin gives a prob of failure lower than 2^-96 + * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ /* int mp_prime_rabin_miller_trials(int size); @@ -673,7 +673,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); */ /* makes a truly random prime of a given size (bytes), - * call with bbs = 1 if you want it to be congruent to 3 mod 4 + * call with bbs = 1 if you want it to be congruent to 3 mod 4 * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself @@ -686,7 +686,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); /* makes a truly random prime of a given size (bits), * * Flags are as follows: - * + * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6c4cb7f..b878149 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -84,11 +84,17 @@ static const unsigned char totalBytes[256] = { 1,1,1,1 #endif }; + +/* + * Functions used only in this module. + */ + +static int UtfCount(int ch); /* *--------------------------------------------------------------------------- * - * TclUtfCount -- + * UtfCount -- * * Find the number of bytes in the Utf character "ch". * @@ -101,8 +107,8 @@ static const unsigned char totalBytes[256] = { *--------------------------------------------------------------------------- */ -int -TclUtfCount( +INLINE static int +UtfCount( int ch) /* The Tcl_UniChar whose size is returned. */ { if ((ch > 0) && (ch < UNICODE_SELF)) { @@ -137,7 +143,7 @@ TclUtfCount( *--------------------------------------------------------------------------- */ -int +INLINE int Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. */ @@ -823,7 +829,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(upChar)) { + if (bytes < UtfCount(upChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -876,7 +882,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(lowChar)) { + if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -926,7 +932,7 @@ Tcl_UtfToTitle( bytes = TclUtfToUniChar(src, &ch); titleChar = Tcl_UniCharToTitle(ch); - if (bytes < TclUtfCount(titleChar)) { + if (bytes < UtfCount(titleChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -938,7 +944,7 @@ Tcl_UtfToTitle( bytes = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); - if (bytes < TclUtfCount(lowChar)) { + if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { diff --git a/generic/tclVar.c b/generic/tclVar.c index ad1368f..2adffbc 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -206,6 +206,7 @@ static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; +static Tcl_UpdateStringProc UpdateParsedVarName; static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_SetFromAnyProc PanicOnSetVarName; @@ -218,10 +219,6 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; * or NULL if it is this same obj * twoPtrValue.ptr2: index into locals table * - * nsVarName - INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to the namespace containing the reference - * twoPtrValue.ptr2: pointer to the corresponding Var - * * parsedVarName - INTERNALREP DEFINITION: * twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a * scalar variable @@ -236,7 +233,7 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, PanicOnUpdateVarName, PanicOnSetVarName + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName }; /* @@ -535,6 +532,7 @@ TclObjLookupVarEx( const char *errMsg = NULL; CallFrame *varFramePtr = iPtr->varFramePtr; const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; + char *newPart2 = NULL; *arrayPtrPtr = NULL; if (typePtr == &localVarNameType) { @@ -581,7 +579,9 @@ TclObjLookupVarEx( } return NULL; } - if ((part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2)) { + part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; + if (newPart2) { + part2Ptr = Tcl_NewStringObj(newPart2, -1); if (createPart2) { Tcl_IncrRefCount(part2Ptr); } @@ -625,7 +625,11 @@ TclObjLookupVarEx( len2 = len1 - i - 2; len1 = i; - part2Ptr = Tcl_NewStringObj(part2, len2); + newPart2 = ckalloc(len2 + 1); + memcpy(newPart2, part2, (unsigned) len2); + *(newPart2+len2) = '\0'; + part2 = newPart2; + part2Ptr = Tcl_NewStringObj(newPart2, -1); if (createPart2) { Tcl_IncrRefCount(part2Ptr); } @@ -650,8 +654,7 @@ TclObjLookupVarEx( Tcl_IncrRefCount(part1Ptr); objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; - Tcl_IncrRefCount(part2Ptr); - objPtr->internalRep.twoPtrValue.ptr2 = part2Ptr; + objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; typePtr = part1Ptr->typePtr; part1 = TclGetString(part1Ptr); @@ -676,6 +679,9 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } return NULL; } @@ -724,26 +730,14 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } } return varPtr; } /* - * This flag bit should not interfere with TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable - * lookup is performed for upvar (or similar) purposes, with slightly - * different rules: - * - Bug #696893 - variable is either proc-local or in the current - * namespace; never follow the second (global) resolution path - * - Bug #631741 - do not use special namespace or interp resolvers - * - * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag - * (Bug #835020) - */ - -#define AVOID_RESOLVERS 0x40000 - -/* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- @@ -792,8 +786,8 @@ TclLookupSimpleVar( Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG bits - * matter. */ + * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG + * bits matter. */ const int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ @@ -833,7 +827,7 @@ TclLookupSimpleVar( */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & AVOID_RESOLVERS)) { + && !(flags & TCL_AVOID_RESOLVERS)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = cxtNsPtr->varResProc(interp, varName, @@ -886,7 +880,7 @@ TclLookupSimpleVar( *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - if (flags & AVOID_RESOLVERS) { + if (flags & TCL_AVOID_RESOLVERS) { flags = (flags | TCL_NAMESPACE_ONLY); } if (flags & TCL_NAMESPACE_ONLY) { @@ -901,7 +895,7 @@ TclLookupSimpleVar( varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr, (Tcl_Namespace *) cxtNsPtr, - (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); + (flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { Tcl_Obj *tailPtr; @@ -4383,15 +4377,15 @@ TclPtrObjMakeUpvar( /* * Lookup and eventually create the new variable. Set the flag bit - * AVOID_RESOLVERS to indicate the special resolution rules for upvar - * purposes: + * TCL_AVOID_RESOLVERS to indicate the special resolution rules for + * upvar purposes: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path. * - Bug #631741 - do not use special namespace or interp resolvers. */ varPtr = TclLookupSimpleVar(interp, myNamePtr, - myFlags|AVOID_RESOLVERS, /* create */ 1, &errMsg, &index); + myFlags|TCL_AVOID_RESOLVERS, /* create */ 1, &errMsg, &index); if (varPtr == NULL) { TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", @@ -5580,11 +5574,11 @@ FreeParsedVarName( Tcl_Obj *objPtr) { register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; + register char *elem = objPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - TclDecrRefCount(elem); + ckfree(elem); } objPtr->typePtr = NULL; } @@ -5595,17 +5589,58 @@ DupParsedVarName( Tcl_Obj *dupPtr) { register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; + register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; + char *elemCopy; + unsigned elemLen; if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); - Tcl_IncrRefCount(elem); + elemLen = strlen(elem); + elemCopy = ckalloc(elemLen + 1); + memcpy(elemCopy, elem, elemLen); + *(elemCopy + elemLen) = '\0'; + elem = elemCopy; } dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; dupPtr->internalRep.twoPtrValue.ptr2 = elem; dupPtr->typePtr = &tclParsedVarNameType; } + +static void +UpdateParsedVarName( + Tcl_Obj *objPtr) +{ + Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + char *part2 = objPtr->internalRep.twoPtrValue.ptr2; + const char *part1; + char *p; + int len1, len2, totalLen; + + if (arrayPtr == NULL) { + /* + * This is a parsed scalar name: what is it doing here? + */ + + Tcl_Panic("scalar parsedVarName without a string rep"); + } + + part1 = TclGetStringFromObj(arrayPtr, &len1); + len2 = strlen(part2); + + totalLen = len1 + len2 + 2; + p = ckalloc(totalLen + 1); + objPtr->bytes = p; + objPtr->length = totalLen; + + memcpy(p, part1, (unsigned) len1); + p += len1; + *p++ = '('; + memcpy(p, part2, (unsigned) len2); + p += len2; + *p++ = ')'; + *p = '\0'; +} /* *---------------------------------------------------------------------- @@ -5641,11 +5676,12 @@ Tcl_FindNamespaceVar( * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of: AVOID_RESOLVERS, - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY (look - * up only in contextNsPtr, or the current - * namespace if contextNsPtr is NULL), and + int flags) /* An OR'd combination of: + * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look + * up name only in global namespace), + * TCL_NAMESPACE_ONLY (look up only in + * contextNsPtr, or the current namespace if + * contextNsPtr is NULL), and * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ @@ -5671,11 +5707,12 @@ ObjFindNamespaceVar( * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of: AVOID_RESOLVERS, - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY (look - * up only in contextNsPtr, or the current - * namespace if contextNsPtr is NULL), and + int flags) /* An OR'd combination of: + * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look + * up name only in global namespace), + * TCL_NAMESPACE_ONLY (look up only in + * contextNsPtr, or the current namespace if + * contextNsPtr is NULL), and * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ @@ -5705,7 +5742,7 @@ ObjFindNamespaceVar( cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - if (!(flags & AVOID_RESOLVERS) && + if (!(flags & TCL_AVOID_RESOLVERS) && (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)) { resPtr = iPtr->resolverPtr; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8f70c30..dac47cf 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1189,40 +1189,33 @@ Tcl_ZlibStreamPut( */ outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100; - if (outSize < 4096) { - outSize = 4096; - } zshPtr->stream.avail_out = outSize; dataTmp = ckalloc(zshPtr->stream.avail_out); zshPtr->stream.next_out = (Bytef *) dataTmp; e = deflate(&zshPtr->stream, flush); - if ((e==Z_OK || e==Z_BUF_ERROR) && (zshPtr->stream.avail_out == 0)) { - if (outSize - zshPtr->stream.avail_out > 0) { - /* - * Output buffer too small. - */ - - obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, - outSize - zshPtr->stream.avail_out); + while (e == Z_BUF_ERROR || (flush == Z_FINISH && e == Z_OK)) { + /* + * Output buffer too small to hold the data being generated or we + * are doing the end-of-stream flush (which can spit out masses of + * data). This means we need to put a new buffer into place after + * saving the old generated data to the outData list. + */ - /* - * Now append the compressed data to the outData list. - */ + obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, outSize); + Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj); - Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj); - } if (outSize < 0xFFFF) { outSize = 0xFFFF; /* There may be *lots* of data left to * output... */ - ckfree(dataTmp); - dataTmp = ckalloc(outSize); + dataTmp = ckrealloc(dataTmp, outSize); } zshPtr->stream.avail_out = outSize; zshPtr->stream.next_out = (Bytef *) dataTmp; 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); @@ -2913,9 +2906,9 @@ ZlibTransformClose( } } } while (e != Z_STREAM_END); - e = deflateEnd(&cd->outStream); + (void) deflateEnd(&cd->outStream); } else { - e = inflateEnd(&cd->inStream); + (void) inflateEnd(&cd->inStream); } /* @@ -3351,10 +3344,13 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, ""); } } else { - int len; - const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + if (cd->compDictObj) { + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); - Tcl_DStringAppend(dsPtr, str, len); + Tcl_DStringAppend(dsPtr, str, len); + } + return TCL_OK; } } @@ -3556,7 +3552,6 @@ ZlibStackChannelTransform( ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; - int e; if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) { Tcl_Panic("unknown mode: %d", mode); @@ -3610,43 +3605,35 @@ ZlibStackChannelTransform( */ if (mode == TCL_ZLIB_STREAM_INFLATE) { - e = inflateInit2(&cd->inStream, wbits); - if (e != Z_OK) { + if (inflateInit2(&cd->inStream, wbits) != Z_OK) { goto error; } cd->inAllocated = DEFAULT_BUFFER_SIZE; cd->inBuffer = ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { - e = inflateGetHeader(&cd->inStream, &cd->inHeader.header); - if (e != Z_OK) { + if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; } } if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { - e = SetInflateDictionary(&cd->inStream, cd->compDictObj); - if (e != Z_OK) { + if (SetInflateDictionary(&cd->inStream, cd->compDictObj) != 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); - if (e != Z_OK) { + if (deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, + MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) { goto error; } cd->outAllocated = DEFAULT_BUFFER_SIZE; cd->outBuffer = ckalloc(cd->outAllocated); if (cd->flags & OUT_HEADER) { - e = deflateSetHeader(&cd->outStream, &cd->outHeader.header); - if (e != Z_OK) { + if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { goto error; } } if (cd->compDictObj) { - e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); - if (e != Z_OK) { + if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) { goto error; } } diff --git a/generic/zipfs.c b/generic/zipfs.c index 84a4276..ad4447d 100644 --- a/generic/zipfs.c +++ b/generic/zipfs.c @@ -575,7 +575,7 @@ CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr) path[j++] = c; } if (j == 0) { - path[j++] = '/'; + path[j++] = '/'; } path[j] = 0; Tcl_DStringSetLength(dsPtr, j); @@ -4075,35 +4075,45 @@ Zipfs_doInit(Tcl_Interp *interp, int safe) Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); ZipFS.initialized = ZipFS.idCount = 1; #if defined(ZIPFS_IN_TCL) || defined(ZIPFS_IN_TK) - Tcl_StaticPackage(interp, "zipfs", Zipfs_Init, Zipfs_SafeInit); + if (interp != NULL) { + Tcl_StaticPackage(interp, "zipfs", Zipfs_Init, Zipfs_SafeInit); + } #endif } Unlock(); - if (!safe) { - Tcl_CreateObjCommand(interp, "::zipfs::mount", ZipFSMountObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::unmount", - ZipFSUnmountObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::mkkey", ZipFSMkKeyObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::mkimg", ZipFSMkImgObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::mkzip", ZipFSMkZipObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::lmkimg", - ZipFSLMkImgObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::lmkzip", - ZipFSLMkZipObjCmd, 0, 0); - Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - } - Tcl_CreateObjCommand(interp, "::zipfs::exists", ZipFSExistsObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::info", ZipFSInfoObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::zipfs::list", ZipFSListObjCmd, 0, 0); - if (!safe) { - Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); - } - - TclMakeEnsemble(interp, "zipfs", safe ? initSafeMap : initMap); - - Tcl_PkgProvide(interp, "zipfs", "1.0"); + if (interp != NULL) { + if (!safe) { + Tcl_CreateObjCommand(interp, "::zipfs::mount", + ZipFSMountObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::unmount", + ZipFSUnmountObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::mkkey", + ZipFSMkKeyObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::mkimg", + ZipFSMkImgObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::mkzip", + ZipFSMkZipObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::lmkimg", + ZipFSLMkImgObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::lmkzip", + ZipFSLMkZipObjCmd, 0, 0); + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); + } + Tcl_CreateObjCommand(interp, "::zipfs::exists", + ZipFSExistsObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::info", + ZipFSInfoObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::zipfs::list", + ZipFSListObjCmd, 0, 0); + if (!safe) { + Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + } + + TclMakeEnsemble(interp, "zipfs", safe ? initSafeMap : initMap); + Tcl_PkgProvide(interp, "zipfs", "1.0"); + } return TCL_OK; #else if (interp != NULL) { |