diff options
65 files changed, 1068 insertions, 490 deletions
@@ -281,7 +281,7 @@ The \fIhashKeyProc\fR member contains the address of a function called to calculate a hash value for the key. .PP .CS -typedef size_t \fBTcl_HashKeyProc\fR( +typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR( Tcl_HashTable *\fItablePtr\fR, void *\fIkeyPtr\fR); .CE @@ -271,8 +271,9 @@ limitation as \fBexec\fR wants to communicate over pipes. The Expect extension addresses this issue when communicating with a TUI application. .PP When attempting to execute an application, \fBexec\fR first searches for -the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and -\fB.bat\fR are appended to the end of the specified name and it searches +the name as it was specified. Then, in order, +\fB.com\fR, \fB.exe\fR, \fB.bat\fR and \fB.cmd\fR +are appended to the end of the specified name and it searches for the longer name. If a directory name was not specified as part of the application name, the following directories are automatically searched in order when attempting to locate the application: @@ -484,10 +484,9 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fBfile owned\fR subcommand currently always reports that the current user -is the owner of the file, without regard for what the operating system -believes to be true, making an ownership test useless. This issue (#3613671) -may be fixed in a future release of Tcl. +The \fBfile owned\fR subcommand uses the user identifier (SID) of +the process token, not the thread token which may be impersonating +some other user. .SH EXAMPLES .PP This procedure shows how to search for C files in a given directory diff --git a/generic/tcl.h b/generic/tcl.h index dd2848a..5035365 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -937,7 +937,7 @@ typedef struct Tcl_DString { */ #ifndef TCL_HASH_TYPE -# define TCL_HASH_TYPE size_t +# define TCL_HASH_TYPE unsigned #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; @@ -1055,7 +1055,7 @@ struct Tcl_HashTable { * table. */ size_t rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - TCL_HASH_TYPE mask1; /* Mask value used in hashing function. */ + size_t mask; /* Mask value used in hashing function. */ int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 2116f2b..ab7dcce 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1299,7 +1299,7 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1448,7 +1448,7 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); /* @@ -2288,7 +2288,7 @@ FindLocalVar( if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { return -1; } - varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); + varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); return -1; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 456b6ad..57b0a6c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3534,7 +3534,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -3633,7 +3633,7 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ @@ -4130,7 +4130,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + cmdString = TclGetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -4276,7 +4276,7 @@ TEOV_RunEnterTraces( Command *cmdPtr = *cmdPtrPtr; int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -4328,7 +4328,7 @@ TEOV_RunLeaveTraces( Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ @@ -5570,7 +5570,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -5601,7 +5601,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 7398fc2..210d63e 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2500,7 +2500,7 @@ BinaryEncode64( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = TclGetStringFromObj(objv[i+1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } diff --git a/generic/tclClock.c b/generic/tclClock.c index fb97b9c..73f3416 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 b97b422..eebc63b 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> /* @@ -1021,6 +1024,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 @@ -1093,6 +1106,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 @@ -1438,28 +1460,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/tclCompCmds.c b/generic/tclCompCmds.c index 3ab03cc..bce17dc 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -801,7 +801,7 @@ TclCompileConcatCmd( Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = Tcl_GetStringFromObj(objPtr, &len); + bytes = TclGetStringFromObj(objPtr, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; @@ -1209,7 +1209,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = Tcl_GetStringFromObj(dictObj, &len); + bytes = TclGetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -2650,7 +2650,7 @@ CompileEachloopCmd( int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + bytes = TclGetStringFromObj(varNameObj, &numBytes); varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; @@ -3087,7 +3087,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3158,7 +3158,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = Tcl_GetStringFromObj(tmpObj, &len); + char *b = TclGetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3192,7 +3192,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ffe39ba..593a8af 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2451,7 +2451,7 @@ TclCompileRegsubCmd( * replacement "simple"? */ - bytes = Tcl_GetStringFromObj(patternObj, &len); + bytes = TclGetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; @@ -2499,7 +2499,7 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); + bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); TclEmitOpcode( INST_STR_MAP, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 101edbd..2503089 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -312,7 +312,7 @@ TclCompileStringCatCmd( Tcl_DecrRefCount(obj); if (folded) { int len; - const char *bytes = Tcl_GetStringFromObj(folded, &len); + const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -330,7 +330,7 @@ TclCompileStringCatCmd( } if (folded) { int len; - const char *bytes = Tcl_GetStringFromObj(folded, &len); + const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -948,12 +948,12 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = Tcl_GetStringFromObj(objv[0], &len); + bytes = TclGetStringFromObj(objv[0], &len); if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(objv[1], &len); + bytes = TclGetStringFromObj(objv[1], &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); @@ -2825,7 +2825,7 @@ TclCompileTryCmd( } if (objc > 0) { int len; - const char *varname = Tcl_GetStringFromObj(objv[0], &len); + const char *varname = TclGetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { @@ -2837,7 +2837,7 @@ TclCompileTryCmd( } if (objc == 2) { int len; - const char *varname = Tcl_GetStringFromObj(objv[1], &len); + const char *varname = TclGetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { @@ -3040,7 +3040,7 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3251,7 +3251,7 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3579,7 +3579,7 @@ TclCompileUnsetCmd( const char *bytes; int len; - bytes = Tcl_GetStringFromObj(leadingWord, &len); + bytes = TclGetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags++; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0f1a22a..8b07fd0 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -498,7 +498,7 @@ typedef struct JumpList { */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, - int index, Tcl_Obj *const **litObjvPtr, + unsigned int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); static void ConvertTreeToTokens(const char *start, int numBytes, @@ -2230,7 +2230,7 @@ static void CompileExprTree( Tcl_Interp *interp, OpNode *nodes, - int index, + unsigned int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bf27b93..c8c71ee 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1314,7 +1314,7 @@ CompileSubstObj( if (objPtr->typePtr != &substCodeType) { CompileEnv compEnv; int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); @@ -1630,7 +1630,7 @@ TclFreeCompileEnv( * have transferred to it. */ - int i; + size_t i; LiteralEntry *entryPtr = envPtr->literalArrayPtr; AuxData *auxDataPtr = envPtr->auxDataArrayPtr; @@ -1792,7 +1792,7 @@ CompileCmdLiteral( CompileEnv *envPtr) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + const char *bytes = TclGetStringFromObj(cmdObj, &numBytes); int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); @@ -2713,7 +2713,7 @@ PreventCycle( Tcl_Obj *objPtr, CompileEnv *envPtr) { - int i; + size_t i; for (i = 0; i < envPtr->literalArrayNext; i++) { if (objPtr == TclFetchLiteral(envPtr, i)) { @@ -2729,7 +2729,7 @@ PreventCycle( * the intrep. */ int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); Tcl_IncrRefCount(copyPtr); @@ -2968,7 +2968,7 @@ TclFindCompiledLocal( varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = Tcl_GetStringFromObj(*varNamePtr, &len); + localName = TclGetStringFromObj(*varNamePtr, &len); if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } @@ -3683,7 +3683,7 @@ TclCreateAuxData( register CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { - int index; /* Index for the new AuxData structure. */ + size_t index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; /* Points to the new AuxData structure */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ab8edf7..dddf0a6 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -318,8 +318,8 @@ typedef struct CompileEnv { * codeStart points into the heap.*/ LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ - int literalArrayNext; /* Index of next free object array entry. */ - int literalArrayEnd; /* Index just after last obj array entry. */ + size_t literalArrayNext; /* Index of next free object array entry. */ + size_t literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; @@ -346,11 +346,11 @@ typedef struct CompileEnv { int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ - int auxDataArrayNext; /* Next free compile aux data array index. + size_t auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ - int auxDataArrayEnd; /* Index after last aux data array entry. */ + size_t auxDataArrayEnd; /* Index after last aux data array entry. */ int mallocedAuxDataArray; /* 1 if aux data array was expanded and * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; @@ -1096,7 +1096,7 @@ MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, - size_t length, TCL_HASH_TYPE hash, int *newPtr, + size_t length, size_t hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1110,7 +1110,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, size_t index); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 1d616fb..0d6da8e 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -193,7 +193,7 @@ TclPrintObject( char *bytes; int length; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -650,7 +650,7 @@ FormatInstruction( int length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index a08f47d..f0e8539 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -3571,7 +3571,7 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); + bytes = TclGetStringFromObj(searchPathObj, &numBytes); *lengthPtr = numBytes; *valuePtr = ckalloc(numBytes + 1); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 8f31318..f7931ac 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -95,7 +95,7 @@ typedef struct { 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 + 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 @@ -1722,7 +1722,7 @@ NsEnsembleImplementationCmdNR( EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; if (ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == ensemblePtr->token) { + ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); if (ensembleCmd->fix) { @@ -1771,7 +1771,7 @@ NsEnsembleImplementationCmdNR( int tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); + subcmdName = TclGetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -2348,6 +2348,7 @@ MakeCachedEnsembleCommand( if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } @@ -2368,7 +2369,8 @@ MakeCachedEnsembleCommand( */ ensembleCmd->epoch = ensemblePtr->epoch; - ensembleCmd->token = ensemblePtr->token; + ensembleCmd->token = (Command *) ensemblePtr->token; + ensembleCmd->token->refCount++; if (fix) { Tcl_IncrRefCount(fix); } @@ -2754,6 +2756,7 @@ FreeEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } @@ -2791,6 +2794,7 @@ DupEnsembleCmdRep( copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; + ensembleCopy->token->refCount++; ensembleCopy->fix = ensembleCmd->fix; if (ensembleCopy->fix) { Tcl_IncrRefCount(ensembleCopy->fix); @@ -2913,7 +2917,7 @@ TclCompileEnsemble( goto failed; } for (i=0 ; i<len ; i++) { - str = Tcl_GetStringFromObj(elems[i], &sclen); + str = TclGetStringFromObj(elems[i], &sclen); if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! @@ -3170,7 +3174,7 @@ TclAttemptCompileProc( Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int savedAuxDataArrayNext = envPtr->auxDataArrayNext; + size_t savedAuxDataArrayNext = envPtr->auxDataArrayNext; int savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG int savedExceptDepth = envPtr->exceptDepth; @@ -3315,7 +3319,7 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { - bytes = Tcl_GetStringFromObj(words[i-1], &length); + bytes = TclGetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); continue; } @@ -3344,7 +3348,7 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b995cee..175e534 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2014,6 +2014,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 */ @@ -3021,20 +3028,7 @@ 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) { @@ -3042,13 +3036,26 @@ TEBCresume( } 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); /* * ----------------------------------------------------------------- @@ -4281,8 +4288,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); @@ -10305,7 +10312,7 @@ EvalStatsCmd( if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + (void) TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10527,7 +10534,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); + char *str = TclGetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 74f7b21..19b26d7 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -396,7 +396,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -587,7 +587,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - Tcl_GetStringFromObj(eltPtr, &len); + TclGetStringFromObj(eltPtr, &len); size += len + 1; } @@ -606,7 +606,7 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = Tcl_GetStringFromObj(eltPtr, &len); + str = TclGetStringFromObj(eltPtr, &len); memcpy(p, str, (size_t) len+1); p += len+1; } @@ -866,7 +866,7 @@ TclpNativeJoinPath( const char *p; const char *start; - start = Tcl_GetStringFromObj(prefix, &length); + start = TclGetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed @@ -894,7 +894,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -930,7 +930,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -1012,7 +1012,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = Tcl_GetStringFromObj(resultObj, &len); + resultStr = TclGetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1258,7 +1258,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, &index) != TCL_OK) { - string = Tcl_GetStringFromObj(objv[i], &length); + string = TclGetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1369,7 +1369,7 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; const char *last; - const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *first = TclGetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1472,7 +1472,7 @@ Tcl_GlobObjCmd( const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = Tcl_GetStringFromObj(look, &len); + str = TclGetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1969,7 +1969,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); + pre = TclGetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -1987,7 +1987,7 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { @@ -2339,7 +2339,7 @@ DoGlob( Tcl_Obj *fixme, *newObj; Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); - bytes = Tcl_GetStringFromObj(fixme, &numBytes); + bytes = TclGetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); Tcl_ListObjReplace(NULL, matchesObj, repair, 1, 1, &newObj); @@ -2377,7 +2377,7 @@ DoGlob( Tcl_DStringAppend(&append, pattern, p-pattern); if (pathPtr != NULL) { - (void) Tcl_GetStringFromObj(pathPtr, &length); + (void) TclGetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2423,7 +2423,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2460,7 +2460,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { diff --git a/generic/tclHash.c b/generic/tclHash.c index fbf5f10..52f35ce 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -28,7 +28,7 @@ */ #define RANDOM_INDEX(tablePtr, i) \ - ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask1) + ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. @@ -179,7 +179,7 @@ Tcl_InitCustomHashTable( tablePtr->numEntries = 0; tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; tablePtr->downShift = 28; - tablePtr->mask1 = 3; + tablePtr->mask = 3; tablePtr->keyType = keyType; tablePtr->findProc = FindHashEntry; tablePtr->createProc = CreateHashEntry; @@ -243,7 +243,7 @@ CreateHashEntry( { register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; - TCL_HASH_TYPE hash, index; + size_t hash, index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -261,7 +261,7 @@ CreateHashEntry( if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, hash); } else { - index = hash & tablePtr->mask1; + index = hash & tablePtr->mask; } } else { hash = (size_t)(key); @@ -381,7 +381,7 @@ Tcl_DeleteHashEntry( || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, entryPtr->hash); } else { - index = entryPtr->hash & tablePtr->mask1; + index = entryPtr->hash & tablePtr->mask; } bucketPtr = &tablePtr->buckets[index]; @@ -955,7 +955,7 @@ RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { size_t oldSize, count; - TCL_HASH_TYPE index; + size_t index; Tcl_HashEntry **oldBuckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; @@ -994,7 +994,7 @@ RebuildTable( } tablePtr->rebuildSize *= 4; tablePtr->downShift -= 2; - tablePtr->mask1 = (tablePtr->mask1 << 2) + 3; + tablePtr->mask = (tablePtr->mask << 2) + 3; /* * Rehash all of the existing entries into the new bucket array. @@ -1007,7 +1007,7 @@ RebuildTable( || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, hPtr->hash); } else { - index = hPtr->hash & tablePtr->mask1; + index = hPtr->hash & tablePtr->mask; } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 65b4952..1342abc 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1946,7 +1946,7 @@ ReflectGetOption( goto error; } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); @@ -2319,7 +2319,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); @@ -3174,7 +3174,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); @@ -3273,7 +3273,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index a15818b..9d36328 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -2043,7 +2043,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); @@ -2807,7 +2807,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index b52a0f2..0ad4d23 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -528,8 +528,8 @@ TclFSCwdPointerEquals( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be @@ -672,7 +672,7 @@ FsUpdateCwd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = Tcl_GetStringFromObj(cwdObj, &len); + str = TclGetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -1208,8 +1208,8 @@ FsAddMountsToGlobResult( if (norm != NULL) { const char *path, *mount; - mount = Tcl_GetStringFromObj(mElt, &mlen); - path = Tcl_GetStringFromObj(norm, &len); + mount = TclGetStringFromObj(mElt, &mlen); + path = TclGetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1800,7 +1800,7 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = Tcl_GetStringFromObj(objPtr, &length); + string = TclGetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. @@ -1827,7 +1827,7 @@ Tcl_FSEvalFileEx( * Record information telling where the error occurred. */ - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); @@ -1978,7 +1978,7 @@ EvalFileCallback( */ int length; - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); const int limit = 150; int overflow = (length > limit); @@ -2830,8 +2830,8 @@ Tcl_FSGetCwd( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(norm, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more efficient and @@ -4099,7 +4099,7 @@ TclGetPathType( * caller. */ { int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -4211,7 +4211,7 @@ TclFSNonnativePathType( numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = Tcl_GetStringFromObj(vol,&len); + strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4558,8 +4558,8 @@ Tcl_FSRemoveDirectory( Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = Tcl_GetStringFromObj(normPath, &normLen); - cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + normPathStr = TclGetStringFromObj(normPath, &normLen); + cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, (size_t) normLen) == 0)) { /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 288e38a..a0dd4f9 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -649,10 +649,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -705,13 +705,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -1057,7 +1057,7 @@ Tcl_ParseArgsObjv( curArg = objv[srcIndex]; srcIndex++; objc--; - str = Tcl_GetStringFromObj(curArg, &length); + str = TclGetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 5b69ed8..d308eec 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -584,8 +584,8 @@ declare 142 { CompileHookProc *hookProc, ClientData clientData) } declare 143 { - int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, - LiteralEntry **litPtrPtr) + unsigned int TclAddLiteralObj(struct CompileEnv *envPtr, + Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } declare 144 { void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, @@ -1023,8 +1023,8 @@ declare 250 { # Allow extensions for optimization declare 251 { - int TclRegisterLiteral(void *envPtr, - char *bytes, int length, int flags) + unsigned int TclRegisterLiteral(void *envPtr, + char *bytes, size_t length, int flags) } ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index 0947afa..ea5e124 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -170,6 +170,21 @@ typedef struct Tcl_ResolverInfo { } 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 + +/* *---------------------------------------------------------------- * Data structures related to namespaces. *---------------------------------------------------------------- @@ -1482,13 +1497,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - int numBuckets; /* Total number of buckets allocated at + size_t numBuckets; /* Total number of buckets allocated at * **buckets. */ - int numEntries; /* Total number of entries present in + size_t numEntries; /* Total number of entries present in * table. */ - int rebuildSize; /* Enlarge table when numEntries gets to be + size_t rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - int mask; /* Mask value used in hashing function. */ + size_t mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -3898,7 +3913,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 7b0a0e0..38b6520 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -310,7 +310,7 @@ TCLAPI int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 143 */ -TCLAPI int TclAddLiteralObj(struct CompileEnv *envPtr, +TCLAPI unsigned int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 144 */ TCLAPI void TclHideLiteral(Tcl_Interp *interp, @@ -547,8 +547,8 @@ TCLAPI char * TclDoubleDigits(double dv, int ndigits, int flags, TCLAPI void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -TCLAPI int TclRegisterLiteral(void *envPtr, char *bytes, - int length, int flags); +TCLAPI unsigned int TclRegisterLiteral(void *envPtr, char *bytes, + size_t length, int flags); typedef struct TclIntStubs { int magic; @@ -697,7 +697,7 @@ typedef struct TclIntStubs { void (*reserved140)(void); const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ - int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ + unsigned int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ @@ -805,7 +805,7 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ - int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ + unsigned int (*tclRegisterLiteral) (void *envPtr, char *bytes, size_t length, int flags); /* 251 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 229d584..7cb6756 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -4502,7 +4502,7 @@ SlaveCommandLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(scriptObj, &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4519,7 +4519,7 @@ SlaveCommandLimitCmd( break; case OPT_VAL: limitObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); + (void) TclGetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } @@ -4711,7 +4711,7 @@ SlaveTimeLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4728,7 +4728,7 @@ SlaveTimeLimitCmd( break; case OPT_MILLI: milliObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); + (void) TclGetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } @@ -4746,7 +4746,7 @@ SlaveTimeLimitCmd( break; case OPT_SEC: secObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &secLen); + (void) TclGetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 1d1ed21..35c7eee 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -526,7 +526,7 @@ LinkTraceProc( break; case TCL_LINK_STRING: - value = Tcl_GetStringFromObj(valueObj, &valueLength); + value = TclGetStringFromObj(valueObj, &valueLength); valueLength++; pp = (char **) linkPtr->addr; diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index e8059f4..7fd1e5a 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -28,10 +28,10 @@ * Function prototypes for static functions in this file: */ -static int AddLocalLiteralEntry(CompileEnv *envPtr, - Tcl_Obj *objPtr, int localHash); +static unsigned int AddLocalLiteralEntry(CompileEnv *envPtr, + Tcl_Obj *objPtr, size_t localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static TCL_HASH_TYPE HashString(const char *string, size_t length); +static size_t HashString(const char *string, size_t length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -104,7 +104,7 @@ TclDeleteLiteralTable( { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; - int i; + size_t i; /* * Release remaining literals in the table. Note that releasing a literal @@ -177,7 +177,7 @@ TclCreateLiteral( char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ size_t length, /* Number of bytes in the string. */ - TCL_HASH_TYPE hash, /* The string's hash. If -1, it will be + size_t hash, /* The string's hash. If -1, it will be * computed here. */ int *newPtr, Namespace *nsPtr, @@ -186,14 +186,14 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - int globalHash; + size_t globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ - if (hash == (TCL_HASH_TYPE) -1) { + if (hash == (size_t) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); @@ -245,7 +245,7 @@ TclCreateLiteral( #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", - "TclRegisterLiteral", (length>60? 60 : length), bytes); + "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); } #endif @@ -320,10 +320,10 @@ Tcl_Obj * TclFetchLiteral( CompileEnv *envPtr, /* Points to the CompileEnv from which to * fetch the registered literal value. */ - unsigned int index) /* Index of the desired literal, as returned + size_t index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= (unsigned int) envPtr->literalArrayNext) { + if (index >= envPtr->literalArrayNext) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; @@ -356,14 +356,14 @@ TclFetchLiteral( *---------------------------------------------------------------------- */ -int +unsigned int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - int length, /* Number of bytes in the string. If < 0, the + size_t length, /* Number of bytes in the string. If < 0, the * string consists of all bytes up to the * first null character. */ int flags) /* If LITERAL_ON_HEAP then the caller already @@ -377,12 +377,14 @@ TclRegisterLiteral( LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - unsigned hash; - int localHash, objIndex, new; + size_t hash; + size_t localHash; + unsigned int objIndex; + int new; Namespace *nsPtr; - if (length < 0) { - length = (bytes ? strlen(bytes) : 0); + if (length == (size_t)-1) { + length = bytes ? strlen(bytes) : 0; } hash = HashString(bytes, length); @@ -395,9 +397,9 @@ TclRegisterLiteral( for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL; localPtr = localPtr->nextPtr) { objPtr = localPtr->objPtr; - if ((objPtr->length == length) && ((length == 0) + if (((size_t)objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { + && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } @@ -476,9 +478,10 @@ LookupLiteralEntry( LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *entryPtr; const char *bytes; - int length, globalHash; + size_t length, globalHash; - bytes = TclGetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); + length = objPtr->length; globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; entryPtr=entryPtr->nextPtr) { @@ -539,8 +542,9 @@ TclHideLiteral( TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; - bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = (HashString(bytes, length) & localTablePtr->mask); + bytes = TclGetString(newObjPtr); + length = newObjPtr->length; + localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { @@ -575,7 +579,7 @@ TclHideLiteral( *---------------------------------------------------------------------- */ -int +unsigned int TclAddLiteralObj( register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ @@ -585,7 +589,7 @@ TclAddLiteralObj( * NULL. */ { register LiteralEntry *lPtr; - int objIndex; + unsigned int objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); @@ -624,16 +628,16 @@ TclAddLiteralObj( *---------------------------------------------------------------------- */ -static int +static unsigned int AddLocalLiteralEntry( register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ - int localHash) /* Hash value for the literal's string. */ + size_t localHash) /* Hash value for the literal's string. */ { register LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; - int objIndex; + unsigned int objIndex; objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); @@ -658,7 +662,8 @@ AddLocalLiteralEntry( TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int length, found, i; + size_t length, i; + int found; found = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { @@ -671,9 +676,10 @@ AddLocalLiteralEntry( } if (!found) { - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); + length = objPtr->length; Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : length), bytes); + "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -712,16 +718,15 @@ ExpandLocalLiteralArray( */ LiteralTable *localTablePtr = &envPtr->localLitTable; - int currElems = envPtr->literalArrayNext; + size_t currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; - int i; - unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; + size_t i; + size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; if (currBytes == newSize) { - Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", - currElems); + Tcl_Panic("max size of Tcl literal array exceeded"); } if (envPtr->mallocedLiteralArray) { @@ -793,15 +798,16 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length, index; + size_t length, index; if (iPtr == NULL) { goto done; } globalTablePtr = &iPtr->literalTable; - bytes = TclGetStringFromObj(objPtr, &length); - index = (HashString(bytes, length) & globalTablePtr->mask); + bytes = TclGetString(objPtr); + length = objPtr->length; + index = HashString(bytes, length) & globalTablePtr->mask; /* * Check to see if the object is in the global literal table and remove @@ -864,12 +870,12 @@ TclReleaseLiteral( *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static size_t HashString( register const char *string, /* String for which to compute hash value. */ size_t length) /* Number of bytes in the string. */ { - register TCL_HASH_TYPE result = 0; + register size_t result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -940,7 +946,7 @@ RebuildLiteralTable( const char *bytes; size_t oldSize; size_t count, length; - TCL_HASH_TYPE index; + size_t index; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -1064,7 +1070,7 @@ TclLiteralStats( LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - int count[NUM_COUNTERS], overflow, i, j; + size_t count[NUM_COUNTERS], overflow, i, j; double average, tmp; register LiteralEntry *entryPtr; char *result, *p; @@ -1140,8 +1146,8 @@ TclVerifyLocalLiteralTable( register LiteralTable *localTablePtr = &envPtr->localLitTable; register LiteralEntry *localPtr; char *bytes; - register int i; - int length, count; + register size_t i; + size_t length, count; count = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { @@ -1149,17 +1155,17 @@ TclVerifyLocalLiteralTable( localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + bytes = TclGetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes, localPtr->refCount); + (length>60? 60 : (int)length), bytes, localPtr->refCount); } if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + bytes = TclGetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" is not global", "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes); + (length>60? 60 : (int)length), bytes); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", @@ -1207,7 +1213,7 @@ TclVerifyGlobalLiteralTable( globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + bytes = TclGetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); diff --git a/generic/tclMain.c b/generic/tclMain.c index 3a09b0c..876bf61 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -536,7 +536,7 @@ Tcl_MainEx( * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(is.commandPtr, &length); + TclGetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); @@ -553,7 +553,7 @@ Tcl_MainEx( } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); @@ -797,7 +797,7 @@ StdinProc( goto prompt; } isPtr->prompt = PROMPT_START; - Tcl_GetStringFromObj(commandPtr, &length); + TclGetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* @@ -828,7 +828,7 @@ StdinProc( chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 982712f..2133ff9 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4538,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/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 8747ff5..8c3f28c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -525,7 +525,7 @@ TclOOUnknownDefinition( return TCL_ERROR; } - soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); + soughtStr = TclGetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } @@ -585,7 +585,7 @@ FindCommand( Tcl_Namespace *const namespacePtr) { int length; - const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); + const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); register Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; @@ -774,7 +774,7 @@ GenerateErrorInfo( int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + const char *objName = TclGetStringFromObj(realNameObj, &length); int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); @@ -1239,7 +1239,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[2], &bodyLength); + TclGetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1358,7 +1358,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[1], &bodyLength); + TclGetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 99a8bfc..9c49caa 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1166,7 +1166,7 @@ MethodErrorHandler( CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); + TclGetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { diff --git a/generic/tclObj.c b/generic/tclObj.c index 74f53cc..af1b4c9 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -663,7 +663,7 @@ TclContinuationsEnterDerived( * better way which doesn't shimmer?) */ - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* @@ -1989,7 +1989,7 @@ TclSetBooleanFromAny( badBoolean: if (interp != NULL) { int length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); + const char *str = TclGetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); @@ -4054,7 +4054,7 @@ TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr = keyPtr; const char *string = TclGetString(objPtr); size_t length = objPtr->length; TCL_HASH_TYPE result = 0; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 827d89d..8267a7d 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -233,7 +233,7 @@ ConvertZeroEffectToNOP( TclGetUInt1AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -248,7 +248,7 @@ ConvertZeroEffectToNOP( TclGetUInt4AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } diff --git a/generic/tclParse.c b/generic/tclParse.c index 5577e87..3a04df4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -2220,7 +2220,7 @@ TclSubstTokens( if (result == 0) { clPos = 0; } else { - Tcl_GetStringFromObj(result, &clPos); + TclGetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { @@ -2496,7 +2496,7 @@ TclObjCommandComplete( * check. */ { int length; - const char *script = Tcl_GetStringFromObj(objPtr, &length); + const char *script = TclGetStringFromObj(objPtr, &length); return CommandComplete(script, length); } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index bcc0a65..4f4db81 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -231,7 +231,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -257,7 +257,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -288,7 +288,7 @@ TclFSNormalizeAbsolutePath( */ const char *path = - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { @@ -303,7 +303,7 @@ TclFSNormalizeAbsolutePath( Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } else { /* * Absolute link. @@ -316,7 +316,7 @@ TclFSNormalizeAbsolutePath( } else { retVal = linkObj; } - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. @@ -333,7 +333,7 @@ TclFSNormalizeAbsolutePath( } } } else { - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } /* @@ -404,7 +404,7 @@ TclFSNormalizeAbsolutePath( if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; - const char *path = Tcl_GetStringFromObj(retVal, &len); + const char *path = TclGetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { @@ -579,7 +579,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -617,7 +617,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -646,7 +646,7 @@ TclPathPart( const char *fileName, *extension; int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { @@ -698,7 +698,7 @@ TclPathPart( int length; const char *fileName, *extension; - fileName = Tcl_GetStringFromObj(pathPtr, &length); + fileName = TclGetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); @@ -869,19 +869,23 @@ 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) { const char *str; int len; - str = Tcl_GetStringFromObj(tailObj, &len); + str = TclGetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. @@ -943,7 +947,7 @@ TclJoinPath( } } } - strElt = Tcl_GetStringFromObj(elt, &strEltLen); + strElt = TclGetStringFromObj(elt, &strEltLen); type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { /* @@ -1030,9 +1034,9 @@ TclJoinPath( noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); - ptr = Tcl_GetStringFromObj(res, &length); + ptr = TclGetStringFromObj(res, &length); } else { - ptr = Tcl_GetStringFromObj(res, &length); + ptr = TclGetStringFromObj(res, &length); } /* @@ -1077,7 +1081,7 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - Tcl_GetStringFromObj(res, &length); + TclGetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); @@ -1372,7 +1376,7 @@ AppendPath( * intrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = Tcl_GetStringFromObj(tail, &numBytes); + bytes = TclGetStringFromObj(tail, &numBytes); if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { @@ -1431,7 +1435,7 @@ TclFSMakePathRelative( * too little below, leading to wrong answers returned by glob. */ - tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the @@ -1451,7 +1455,7 @@ TclFSMakePathRelative( } break; } - tempStr = Tcl_GetStringFromObj(pathPtr, &len); + tempStr = TclGetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1715,7 +1719,7 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; - const char *orig = Tcl_GetStringFromObj(transPtr, &len); + const char *orig = TclGetStringFromObj(transPtr, &len); char *result = ckalloc(len+1); memcpy(result, orig, (size_t) len+1); @@ -1776,7 +1780,7 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1789,7 +1793,7 @@ Tcl_FSGetNormalizedPath( * We now own a reference on both 'dir' and 'copy' */ - (void) Tcl_GetStringFromObj(dir, &cwdLen); + (void) TclGetStringFromObj(dir, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* Normalize the combined string. */ @@ -1883,7 +1887,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* @@ -2333,7 +2337,7 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = Tcl_GetStringFromObj(pathPtr, &len); + name = TclGetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. @@ -2602,7 +2606,7 @@ UpdateStringOfFsPath( copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); - pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); + pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; copy->bytes = tclEmptyStringRep; copy->length = 0; @@ -2663,7 +2667,7 @@ TclNativePathInFilesystem( int len; - (void) Tcl_GetStringFromObj(pathPtr, &len); + (void) TclGetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 188794f..fdf9bba 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -801,7 +801,7 @@ Tcl_PackageObjCmd( } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = Tcl_GetStringFromObj(objv[3], &length); + argv3 = TclGetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { @@ -842,7 +842,7 @@ Tcl_PackageObjCmd( prevPtr->nextPtr = availPtr; } } - argv4 = Tcl_GetStringFromObj(objv[4], &length); + argv4 = TclGetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } @@ -993,7 +993,7 @@ Tcl_PackageObjCmd( if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } - argv2 = Tcl_GetStringFromObj(objv[2], &length); + argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { @@ -1641,7 +1641,7 @@ AddRequirementsToResult( int i, length; for (i = 0; i < reqc; i++) { - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + const char *v = TclGetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { diff --git a/generic/tclProc.c b/generic/tclProc.c index 9c4fd1d..677f877 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -343,7 +343,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + procBody = TclGetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -2079,7 +2079,7 @@ MakeProcError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2760,7 +2760,7 @@ MakeLambdaError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( diff --git a/generic/tclResult.c b/generic/tclResult.c index 456a164..478450b 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -447,7 +447,7 @@ Tcl_AppendElement( if (Tcl_IsShared(iPtr->objResultPtr)) { Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); } - bytes = Tcl_GetStringFromObj(iPtr->objResultPtr, &length); + bytes = TclGetStringFromObj(iPtr->objResultPtr, &length); if (TclNeedSpace(bytes, bytes+length)) { Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3c378ec..21a5756 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2286,7 +2286,7 @@ Tcl_AppendFormatToObj( } } - Tcl_GetStringFromObj(segment, &segmentNumBytes); + TclGetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 2d1cd33..a020773 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -900,10 +900,10 @@ Tcl_AfterObjCmd( } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } - command = Tcl_GetStringFromObj(commandPtr, &length); + command = TclGetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + tempCommand = TclGetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, (unsigned) length)) { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 34018bc..e6cd996 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -278,7 +278,7 @@ Tcl_TraceObjCmd( opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + flagOps = TclGetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; @@ -462,7 +462,7 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -701,7 +701,7 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -904,7 +904,7 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = ckalloc( diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0cceb34..c8bbd31 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1919,7 +1919,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -2628,7 +2628,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *bytes = TclGetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -3817,7 +3817,7 @@ TclSetProcessGlobalValue( } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + bytes = TclGetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { diff --git a/generic/tclVar.c b/generic/tclVar.c index 87771b2..5b6393a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -725,18 +725,6 @@ TclObjLookupVarEx( } /* - * 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 - */ - -#define AVOID_RESOLVERS 0x40000 - -/* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- @@ -785,8 +773,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. */ @@ -826,7 +814,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, @@ -879,7 +867,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) { @@ -894,7 +882,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; @@ -4235,15 +4223,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", @@ -5416,11 +5404,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. */ @@ -5446,11 +5435,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. */ @@ -5480,7 +5470,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 6d79f23..7e4bdd0 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -438,7 +438,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -459,7 +459,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; @@ -3346,7 +3346,7 @@ ZlibTransformGetOption( } else { if (cd->compDictObj) { int len; - const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + const char *str = TclGetStringFromObj(cd->compDictObj, &len); Tcl_DStringAppend(dsPtr, str, len); } diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 326d897..381ae08 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -640,7 +640,7 @@ SetOSTypeFromAny( Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); - string = Tcl_GetStringFromObj(objPtr, &length); + string = TclGetStringFromObj(objPtr, &length); Tcl_UtfToExternalDString(encoding, string, length, &ds); if (Tcl_DStringLength(&ds) > 4) { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 267fc66..a293b4e 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1024,6 +1024,16 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { set modatime [file atime $file $newatime] expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } -result 1 +test cmdAH-20.7 { + Tcl_FileObjCmd: atime (built-in Windows names) +} -constraints {win} -body { + file atime con +} -result "could not get access time for file \"con\"" -returnCodes error +test cmdAH-20.7.1 { + Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file atime [file join [temporaryDirectory] CON.txt] +} -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp @@ -1255,6 +1265,16 @@ test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup { } -cleanup { file delete -force $dirname } -result {0 1} +test cmdAH-24.14 { + Tcl_FileObjCmd: mtime (built-in Windows names) +} -constraints {win} -body { + file mtime con +} -result "could not get modification time for file \"con\"" -returnCodes error +test cmdAH-24.14.1 { + Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file mtime [file join [temporaryDirectory] CON.txt] +} -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { @@ -1274,6 +1294,12 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 +test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { + file owned $env(windir) +} -result 0 +test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body { + file owned nosuchfile +} -result 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body { @@ -1304,6 +1330,16 @@ test cmdAH-27.2 {Tcl_FileObjCmd: size} { test cmdAH-27.3 {Tcl_FileObjCmd: size} { list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-27.4 { + Tcl_FileObjCmd: size (built-in Windows names) +} -constraints {win} -body { + file size con +} -result 0 +test cmdAH-27.4.1 { + Tcl_FileObjCmd: size (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file size [file join [temporaryDirectory] con.txt] +} -result 0 catch {testsetplatform $platform} removeFile $gorpfile @@ -1395,12 +1431,24 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 +test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + file stat con stat + lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} +test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + file stat [file join [temporaryDirectory] CON.txt] stat + lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { - file size a b -} -result {wrong # args: should be "file size name"} + file type a b +} -result {wrong # args: should be "file type name"} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type $dirfile } directory @@ -1435,6 +1483,16 @@ test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { test cmdAH-29.5 {Tcl_FileObjCmd: type} { list [catch {file type _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-29.6 { + Tcl_FileObjCmd: type (built-in Windows names) +} -constraints {win} -body { + file type con +} -result "characterSpecial" +test cmdAH-29.6.1 { + Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension) +} -constraints {win} -body { + file type [file join [temporaryDirectory] CON.txt] +} -result "characterSpecial" # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { diff --git a/tests/exec.test b/tests/exec.test index 16a8320..38927d3 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -682,6 +682,22 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { } -cleanup { removeFile $tmpfile } -result 14 + +# Tests to ensure batch files and .CMD (Bug 9ece99d58b) +# can be executed on Windows +test exec-20.0 {exec .bat file} -constraints {win} -body { + set log [makeFile {} exec20.log] + exec [makeFile "echo %1> $log" exec20.bat] "Testing exec-20.0" + viewFile $log +} -result "\"Testing exec-20.0\"" +test exec-20.1 {exec .CMD file} -constraints {win} -body { + set log [makeFile {} exec201.log] + exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" + viewFile $log +} -result "\"Testing exec-20.1\"" + + + # ---------------------------------------------------------------------- # cleanup diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d8ba31..1d6a805 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -57,6 +57,12 @@ test namespace-old-1.9 {add elements to a namespace} { } } } {} +namespace eval test_ns_simple { + variable test_ns_x 0 + proc test {test_ns_x} { + return "test: $test_ns_x" + } +} test namespace-old-1.10 {commands in a namespace} { namespace eval test_ns_simple { info commands [namespace current]::*} } {::test_ns_simple::test} @@ -74,6 +80,12 @@ test namespace-old-1.13 {add to an existing namespace} { } } } "" +namespace eval test_ns_simple { + variable test_ns_y 123 + proc _backdoor {cmd} { + eval $cmd + } +} test namespace-old-1.14 {commands in a namespace} { lsort [namespace eval test_ns_simple {info commands [namespace current]::*}] } {::test_ns_simple::_backdoor ::test_ns_simple::test} @@ -128,6 +140,8 @@ test namespace-old-1.26 {namespace qualifiers are okay after $'s} { test namespace-old-1.27 {can create commands with null names} { proc test_ns_simple:: {args} {return $args} } {} +# Redeclare; later tests depend on it +proc test_ns_simple:: {args} {return $args} # ----------------------------------------------------------------------- # TEST: using "info" in namespace contexts @@ -212,6 +226,11 @@ test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { } list [catch $cmd msg] $msg } {1 {unknown namespace "ns*" in namespace delete command}} +namespace eval test_ns_delete { + namespace eval ns1 {} + namespace eval ns2 {} + namespace eval another {} +} test namespace-old-4.4 {command "namespace delete" handles multiple args} { set cmd { namespace eval test_ns_delete { @@ -256,6 +275,24 @@ test namespace-old-5.3 {namespace qualifiers work in namespace command} { [namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \ [namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}] } {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2} +set ::test_ns_var_global "var in ::" +proc test_ns_cmd_global {} {return "cmd in ::"} +namespace eval test_ns_hier1 { + variable test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + variable test_ns_level 1 + proc test_ns_show {} {return "[namespace current]: 1"} + namespace eval test_ns_hier2 { + variable test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + variable test_ns_level 2 + proc test_ns_show {} {return "[namespace current]: 2"} + namespace eval test_ns_hier3a {} + namespace eval test_ns_hier3b {} + } + namespace eval test_ns_hier2a {} + namespace eval test_ns_hier2b {} +} test namespace-old-5.4 {nested namespaces can access global namespace} { list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ @@ -331,16 +368,12 @@ test namespace-old-5.21 {querying namespace parent for explicit namespace} { # ----------------------------------------------------------------------- # TEST: name resolution and caching # ----------------------------------------------------------------------- +set trigger {namespace eval test_ns_cache2 {namespace current}} +set trigger2 {namespace eval test_ns_cache2::test_ns_cache3 {namespace current}} test namespace-old-6.1 {relative ns names only looked up in current ns} { namespace eval test_ns_cache1 {} namespace eval test_ns_cache2 {} namespace eval test_ns_cache2::test_ns_cache3 {} - set trigger { - namespace eval test_ns_cache2 {namespace current} - } - set trigger2 { - namespace eval test_ns_cache2::test_ns_cache3 {namespace current} - } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} @@ -354,20 +387,19 @@ test namespace-old-6.3 {relative ns names only looked up in current ns} { list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1::test_ns_cache2 {} test namespace-old-6.4 {relative ns names only looked up in current ns} { namespace delete test_ns_cache1::test_ns_cache2 list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1 { + proc trigger {} {test_ns_cache_cmd} +} test namespace-old-6.5 {define test commands} { proc test_ns_cache_cmd {} { return "global version" } - namespace eval test_ns_cache1 { - proc trigger {} { - test_ns_cache_cmd - } - } test_ns_cache1::trigger } {global version} test namespace-old-6.6 {one-level check for command shadowing} { @@ -376,24 +408,36 @@ test namespace-old-6.6 {one-level check for command shadowing} { } test_ns_cache1::trigger } {cache1 version} -test namespace-old-6.7 {renaming commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd test_ns_new +proc test_ns_cache_cmd {} { + return "global version" +} +test namespace-old-6.7 {renaming commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} -test namespace-old-6.8 {renaming back handles shadowing} { - namespace eval test_ns_cache1 { - rename test_ns_new test_ns_cache_cmd +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd test_ns_new}]\ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} +test namespace-old-6.8 {renaming back handles shadowing} -setup { + proc test_ns_cache1::test_ns_new {} { + return "cache1 version" } - test_ns_cache1::trigger -} {cache1 version} -test namespace-old-6.9 {deleting commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd "" +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_new test_ns_cache_cmd}]\ + [test_ns_cache1::trigger] +} -result {{global version} {} {cache1 version}} +test namespace-old-6.9 {deleting commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd ""}] \ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} test namespace-old-6.10 {define test namespaces} { namespace eval test_ns_cache2 { proc test_ns_cache_cmd {} { @@ -412,6 +456,12 @@ test namespace-old-6.10 {define test namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{global cache2 version} {global version}} +namespace eval test_ns_cache1 { + proc trigger {} { test_ns_cache2::test_ns_cache_cmd } + namespace eval test_ns_cache2 { + proc trigger {} { test_ns_cache_cmd } + } +} test namespace-old-6.11 {commands affect all parent namespaces} { proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { return "cache2 version" @@ -423,18 +473,22 @@ test namespace-old-6.12 {define test variables} { set trigger {set test_ns_cache_var} namespace eval test_ns_cache1 $trigger } {global version} + set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } namespace eval test_ns_cache1 $trigger } {cache1 version} +variable ::test_ns_cache_var "global version" test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { - unset test_ns_cache_var + variable test_ns_cache_var "cache1 version" } - namespace eval test_ns_cache1 $trigger -} {global version} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ + [namespace eval test_ns_cache1 $trigger] +} {{cache1 version} {} {global version}} test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" @@ -443,6 +497,7 @@ test namespace-old-6.15 {define test namespaces} { list [namespace eval test_ns_cache1 $trigger2] \ [namespace eval test_ns_cache1::test_ns_cache2 $trigger] } {{global cache2 version} {global version}} +set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" list [namespace eval test_ns_cache1 $trigger2] \ @@ -467,6 +522,7 @@ test namespace-old-6.19 {querying: namespace which -command} { test namespace-old-6.20 {command "namespace which" may not find commands} { namespace eval test_ns_cache1 {namespace which -command xyzzy} } {} +variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" test namespace-old-6.21 {querying: namespace which -variable} { namespace eval test_ns_cache1::test_ns_cache2 { namespace which -variable test_ns_cache_var @@ -493,6 +549,18 @@ test namespace-old-7.1 {define test namespace} { } } } {} +namespace eval test_ns_uplevel { + variable x 0 + variable y 1 + proc show_vars {num} { + return [uplevel $num {info vars}] + } + proc test_uplevel {num} { + set a 0 + set b 1 + namespace eval ::test_ns_uplevel " return \[show_vars $num\] " + } +} test namespace-old-7.2 {uplevel can access namespace call frame} { list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] @@ -526,6 +594,17 @@ test namespace-old-7.8 {namespaces are included in the call stack} { } } } {} +namespace eval test_ns_upvar { + variable scope "test_ns_upvar" + proc show_val {var num} { + upvar $num $var x + return $x + } + proc test_upvar {num} { + set scope "test_ns_upvar::test_upvar" + namespace eval ::test_ns_upvar " return \[show_val scope $num\] " + } +} test namespace-old-7.9 {upvar can access namespace call frame} { test_ns_upvar::test_upvar 1 } {test_ns_upvar} @@ -581,6 +660,15 @@ test namespace-old-9.3 {define test namespaces for import} { } lsort [info commands test_ns_export::*] } {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6} +namespace eval test_ns_export { + namespace export cmd1 cmd2 cmd3 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + proc cmd5 {args} {return "cmd5: $args"} + proc cmd6 {args} {return "cmd6: $args"} +} test namespace-old-9.4 {check export status} { set x "" namespace eval test_ns_import { @@ -592,6 +680,10 @@ test namespace-old-9.4 {check export status} { } set x } {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3} +namespace eval test_ns_import { + namespace export cmd1 cmd2 + namespace import ::test_ns_export::* +} test namespace-old-9.5 {empty import list in "namespace import" command} { namespace eval test_ns_import_empty { namespace import ::test_ns_export::* @@ -615,6 +707,7 @@ test namespace-old-9.8 {only exported commands are imported} { namespace import test_ns_import::cmd* set x [lsort [info commands cmd*]] } {cmd1 cmd2} +namespace import test_ns_import::cmd* test namespace-old-9.9 {imported commands work just the same as original} { list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6] } {{cmd1: test 1 2 3} {cmd1: test 4 5 6}} @@ -629,10 +722,19 @@ test namespace-old-9.10 {commands can be imported from many namespaces} { namespace import test_ns_import2::* lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd1 cmd2 ncmd ncmd1 ncmd2} +namespace eval test_ns_import2 { + namespace export ncmd ncmd1 ncmd2 + proc ncmd {args} {return "ncmd: $args"} + proc ncmd1 {args} {return "ncmd1: $args"} + proc ncmd2 {args} {return "ncmd2: $args"} + proc ncmd3 {args} {return "ncmd3: $args"} +} +namespace import test_ns_import2::* test namespace-old-9.11 {imported commands can be removed by deleting them} { rename cmd1 "" lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd2 ncmd ncmd1 ncmd2} +catch { rename cmd1 "" } test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} { list [catch {namespace forget xyzzy::*} msg] $msg } {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} @@ -653,6 +755,7 @@ test namespace-old-9.15 {existing commands can't be overwritten} { [cmd1 3 5] } {1 {can't import command "cmd1": already exists} 8} test namespace-old-9.16 {use "-force" option to override existing commands} { + proc cmd1 {x y} { return [expr $x+$y] } list [cmd1 3 5] \ [namespace import -force test_ns_import::cmd?] \ [cmd1 3 5] @@ -711,10 +814,18 @@ test namespace-old-10.6 {with many args, each "scope" adds new args} { set sval [namespace eval test_ns_inscope {namespace code {one two}}] namespace code "$sval three" } {::namespace inscope ::test_ns_inscope {one two} three} +namespace eval test_ns_inscope { + proc show {args} { + return "show: $args" + } +} test namespace-old-10.7 {scoped commands work with eval} { set cref [namespace eval test_ns_inscope {namespace code show}] list [eval $cref "a" "b c" "d e f"] } {{show: a b c d e f}} +namespace eval test_ns_inscope { + variable x "x-value" +} test namespace-old-10.8 {scoped commands execute in namespace context} { set cref [namespace eval test_ns_inscope { namespace code {set x "some new value"} diff --git a/tests/namespace.test b/tests/namespace.test index 2a5f308..0bbf2f7 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -82,12 +82,14 @@ test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} { test namespace-5.1 {Tcl_PopCallFrame, no vars} { namespace eval test_ns_1::blodge {} ;# pushes then pops frame } {} -test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { +test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} -setup { + namespace eval test_ns_1 {} +} -body { proc test_ns_1::r {} { set a 123 } test_ns_1::r ;# pushes then pop's r's frame -} {123} +} -result {123} test namespace-6.1 {Tcl_CreateNamespace} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -194,7 +196,6 @@ test namespace-7.7 {Bug 1655305} -setup { interp delete slave } -result {} - test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp @@ -303,15 +304,24 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, RFE 1230597} { +test namespace-9.5 {Tcl_Import, RFE 1230597} -setup { + namespace eval test_ns_import {} + namespace eval test_ns_export {} +} -body { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg -} {0 {}} -test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { +} -result {0 {}} +test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} -setup { + namespace eval test_ns_import {} + namespace eval ::test_ns_export { + proc cmd1 {args} {return "cmd1: $args"} + namespace export cmd1 + } +} -body { namespace eval test_ns_import { namespace import -force ::test_ns_export::* cmd1 555 } -} {cmd1: 555} +} -result {cmd1: 555} test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_export { @@ -329,7 +339,6 @@ test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { [test_ns_import::cmd1 g h i] \ [test_ns_export::cmd1 j k l] } {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}} - test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -354,7 +363,6 @@ test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { } -cleanup { namespace delete one two three } -match glob -result *::one::cmd - test namespace-9.9 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -388,7 +396,13 @@ test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { namespace forget ::test_ns_export::wombat } } {} -test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { +test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} -setup { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } +} -body { namespace eval test_ns_import { namespace import ::test_ns_export::* proc p {} {return [cmd1 123]} @@ -398,8 +412,7 @@ test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { lappend l [info commands ::test_ns_import::*] lappend l [catch {cmd1 777} msg] $msg } -} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] - +} -result [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -417,7 +430,6 @@ test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin unrelated my } - test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -433,7 +445,6 @@ test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my } -returnCodes error -match glob -result * - test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -450,7 +461,6 @@ test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my your } -returnCodes error -match glob -result * - test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -471,7 +481,6 @@ test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } -returnCodes error -match glob -result * - test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -492,7 +501,6 @@ test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } - test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -514,29 +522,47 @@ test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace delete origin link link2 my } -returnCodes error -match glob -result * -test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { +test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} } list [namespace origin set] [namespace origin test_ns_export::cmd1] -} {::set ::test_ns_export::cmd1} -test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} { +} -result {::set ::test_ns_export::cmd1} +test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } +} -body { namespace eval test_ns_import1 { namespace import ::test_ns_export::* namespace export * proc p {} {namespace origin cmd1} } list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1] -} {::test_ns_export::cmd1 ::test_ns_export::cmd1} -test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { +} -result {::test_ns_export::cmd1 ::test_ns_export::cmd1} +test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } + namespace eval test_ns_import1 { + namespace import ::test_ns_export::* + namespace export * + proc p {} {namespace origin cmd1} + } +} -body { namespace eval test_ns_import2 { namespace import ::test_ns_import1::* proc q {} {return [cmd1 123]} } list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1] -} {{cmd1: 123} ::test_ns_export::cmd1} +} -result {{cmd1: 123} ::test_ns_export::cmd1} test namespace-12.1 {InvokeImportedCmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -550,14 +576,23 @@ test namespace-12.1 {InvokeImportedCmd} { list [test_ns_import::cmd1] } {::test_ns_export} -test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { +test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {namespace current} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + } +} -body { namespace eval test_ns_import { set l {} lappend l [info commands ::test_ns_import::*] namespace forget ::test_ns_export::cmd1 lappend l [info commands ::test_ns_import::*] } -} {::test_ns_import::cmd1 {}} +} -result {::test_ns_import::cmd1 {}} test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { # Will panic if still buggy namespace eval src {namespace export foo; proc foo {} {}} @@ -568,7 +603,7 @@ test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { namespace delete src } {} -test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { +test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { @@ -577,22 +612,41 @@ test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { namespace eval test_ns_2 { variable v 30 } +} -body { namespace eval test_ns_1 { list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \ [lsort [namespace children :: test_ns_*]] } -} [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] -test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { +} -result [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] +test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } -} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} -test namespace-14.3 {TclGetNamespaceForQualName, relative names} { +} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} +test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list $v $test_ns_2::v } -} {10 20} +} -result {10 20} test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -619,57 +673,72 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl [catch {namespace children test_ns_1} msg] $msg } } {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} -test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { +test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children test_ns_1::: -} {::test_ns_1::test_ns_2} -test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} { +} -result {::test_ns_1::test_ns_2} +test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children :::test_ns_1:::::test_ns_2::: -} {::test_ns_1::test_ns_2::foo} +} -result {::test_ns_1::test_ns_2::foo} test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} { set l {} lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg namespace eval test_ns_1::test_ns_2 {variable {} 2525} lappend l [set test_ns_1::test_ns_2::] } {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} -test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {unset test_ns_1::test_ns_2::} +test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { + namespace eval test_ns_1::test_ns_2::foo {} + unset -nocomplain test_ns_1::test_ns_2:: set l {} +} -body { lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg set test_ns_1::test_ns_2:: 314159 lappend l [set test_ns_1::test_ns_2::] -} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} -test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} { +} -result {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} +test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} -setup { + namespace eval test_ns_1::test_ns_2::foo {} catch {rename test_ns_1::test_ns_2:: {}} set l {} +} -body { lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] -} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} -test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} { +} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} +test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { variable {} set test_ns_1::(x) y } set test_ns_1::(x) -} y -test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { +} -result y +test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg -} {1 {can't create namespace "": only global namespace can have empty name}} +} -returnCodes error -body { + namespace eval test_ns_1 { + proc {} {} {} + namespace eval {} {} + {} + } +} -result {can't create namespace "": only global namespace can have empty name} -test namespace-15.1 {Tcl_FindNamespace, absolute name found} { +test namespace-15.1 {Tcl_FindNamespace, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} proc cmd {args} {namespace current} } list [namespace delete ::test_ns_delete::test_ns_delete2] \ [namespace children ::test_ns_delete] -} {{} {}} -test namespace-15.2 {Tcl_FindNamespace, absolute name not found} { - list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg -} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}} +} -result {{} {}} +test namespace-15.2 {Tcl_FindNamespace, absolute name not found} -body { + namespace delete ::test_ns_delete::test_ns_delete2 +} -returnCodes error -result {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command} test namespace-15.3 {Tcl_FindNamespace, relative name found} { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} @@ -685,17 +754,24 @@ test namespace-15.4 {Tcl_FindNamespace, relative name not found} { } } {1 {unknown namespace "test_ns_delete2" in namespace delete command}} -test namespace-16.1 {Tcl_FindCommand, absolute name found} { +test namespace-16.1 {Tcl_FindCommand, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc cmd {args} {return "[namespace current]::cmd: $args"} variable v "::test_ns_1::cmd" eval $v one } -} {::test_ns_1::cmd: one} -test namespace-16.2 {Tcl_FindCommand, absolute name found} { +} -result {::test_ns_1::cmd: one} +test namespace-16.2 {Tcl_FindCommand, absolute name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + variable v "::test_ns_1::cmd" + } +} -body { eval $test_ns_1::v two -} {::test_ns_1::cmd: two} +} -result {::test_ns_1::cmd: two} test namespace-16.3 {Tcl_FindCommand, absolute name not found} { namespace eval test_ns_1 { variable v2 "::test_ns_1::ladidah" @@ -724,11 +800,16 @@ test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { catch {rename unknown {}} catch {rename unknown.old unknown} -test namespace-16.8 {Tcl_FindCommand, relative name found} { +test namespace-16.8 {Tcl_FindCommand, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + } +} -body { namespace eval test_ns_1 { cmd a b c } -} {::test_ns_1::cmd: a b c} +} -result {::test_ns_1::cmd: a b c} test namespace-16.9 {Tcl_FindCommand, relative name found} -body { proc cmd2 {args} {return "[namespace current]::cmd2: $args"} namespace eval test_ns_1 { @@ -750,20 +831,21 @@ test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current } -cleanup { catch {rename cmd2 {}} } -result {::::cmd2: a b c} -test namespace-16.11 {Tcl_FindCommand, relative name not found} { +test namespace-16.11 {Tcl_FindCommand, relative name not found} -body { namespace eval test_ns_1 { - list [catch {cmd3 a b c} msg] $msg + cmd3 a b c } -} {1 {invalid command name "cmd3"}} +} -returnCodes error -result {invalid command name "cmd3"} -catch {unset x} -test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { +unset -nocomplain x +test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { set x 314159 namespace eval test_ns_1 { set ::x } -} {314159} +} -result {314159} test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} { namespace eval test_ns_1 { variable x 777 @@ -778,27 +860,33 @@ test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} { set ::test_ns_1::test_ns_2::x } } {1111} -test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} { +test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} -body { namespace eval test_ns_1 { namespace eval test_ns_2 { variable x 1111 } - list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg + set ::test_ns_1::test_ns_2::y } -} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}} -test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} { +} -returnCodes error -result {can't read "::test_ns_1::test_ns_2::y": no such variable} +test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} -setup { + namespace eval ::test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace eval test_ns_3 { variable ::test_ns_1::test_ns_2::x 2222 } } set ::test_ns_1::test_ns_2::x -} {2222} -test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} { +} -result {2222} +test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { + namespace eval test_ns_1 { + variable x 777 + } +} -body { namespace eval test_ns_1 { set x } -} {777} +} -result {777} test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { unset x @@ -834,8 +922,9 @@ catch {unset x} catch {unset l} catch {rename foo {}} -test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { +test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc foo {} {return "global foo"} namespace eval test_ns_1 { proc trigger {} { @@ -849,7 +938,7 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] -} {{global foo} {foo in test_ns_1}} +} -result {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { proc foo {} {return "foo in ::test_ns_2"} @@ -873,22 +962,31 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado catch {unset l} catch {rename foo {}} -test namespace-19.1 {GetNamespaceFromObj, global name found} { +test namespace-19.1 {GetNamespaceFromObj, global name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::test_ns_2 {} namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-19.2 {GetNamespaceFromObj, relative name found} { +} -result {::test_ns_1::test_ns_2} +test namespace-19.2 {GetNamespaceFromObj, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} -test namespace-19.3 {GetNamespaceFromObj, name not found} -body { +} -result {} +test namespace-19.3 {GetNamespaceFromObj, name not found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace children test_ns_99 } } -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"} -test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { +test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { proc foo {} { return [namespace children test_ns_2] @@ -900,7 +998,7 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] -} {{} ::test_ns_1::test_ns_2::test_ns_3} +} -result {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -913,24 +1011,34 @@ test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} -test namespace-21.1 {NamespaceChildrenCmd, no args} { +test namespace-21.1 {NamespaceChildrenCmd, no args} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { + namespace eval test_ns_1::test_ns_2 {} + expr {"::test_ns_1" in [namespace children]} +} -result {1} +test namespace-21.2 {NamespaceChildrenCmd, no args} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2 {} - expr {[string first ::test_ns_1 [namespace children]] != -1} -} {1} -test namespace-21.2 {NamespaceChildrenCmd, no args} { +} -body { namespace eval test_ns_1 { namespace children } -} {::test_ns_1::test_ns_2} -test namespace-21.3 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.3 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-21.4 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.4 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} +} -result {} test namespace-21.5 {NamespaceChildrenCmd, too many args} { namespace eval test_ns_1 { list [catch {namespace children test_ns_2 xxx yyy} msg] $msg @@ -940,10 +1048,13 @@ test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} { namespace eval test_ns_1::test_ns_foo {} namespace children test_ns_1 *f* } {::test_ns_1::test_ns_foo} -test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { +test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1::test_ns_foo {} lsort [namespace children test_ns_1 test*] -} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}] +} -result {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo} test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} { namespace eval test_ns_1 {} namespace children [namespace current] [fq test_ns_1] @@ -1038,15 +1149,25 @@ test namespace-25.3 {NamespaceEvalCmd, new namespace} { } test_ns_1::p } {314159} -test namespace-25.4 {NamespaceEvalCmd, existing namespace} { +test namespace-25.4 {NamespaceEvalCmd, existing namespace} -setup { + namespace eval test_ns_1 { + variable v 314159 + proc p {} { + variable v + return $v + } + } +} -body { namespace eval test_ns_1 { proc q {} {return [expr {[p]+1}]} } test_ns_1::q -} {314160} -test namespace-25.5 {NamespaceEvalCmd, multiple args} { +} -result {314160} +test namespace-25.5 {NamespaceEvalCmd, multiple args} -setup { + namespace eval test_ns_1 {variable v 314159} +} -body { namespace eval test_ns_1 "set" "v" -} {314159} +} -result {314159} test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo } {1 {invalid command name "xxxx"} {invalid command name "xxxx" @@ -1097,21 +1218,50 @@ test namespace-26.4 {NamespaceExportCmd, one pattern} { } list [info commands test_ns_2::*] [test_ns_2::cmd1 hello] } {::test_ns_2::cmd1 {cmd1: hello}} -test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} { +test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} namespace export cmd1 cmd3 } +} -body { namespace eval test_ns_2 { namespace import -force ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello] -} [list [lsort {::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd3: hello}] -test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} { +} -result {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}} +test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + namespace export cmd1 cmd3 + } +} -body { namespace eval test_ns_1 { namespace export } -} {cmd1 cmd3} -test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { +} -result {cmd1 cmd3} +test namespace-26.7 {NamespaceExportCmd, -clear resets export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + } +} -body { + namespace eval test_ns_1 { + namespace export cmd1 cmd3 + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } namespace eval test_ns_1 { namespace export -clear cmd4 } @@ -1119,7 +1269,7 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { namespace import ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello] -} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] +} -result [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] test namespace-26.8 {NamespaceExportCmd, -clear resets export list} { catch {namespace delete foo} namespace eval foo { @@ -1202,14 +1352,23 @@ test namespace-29.4 {NamespaceInscopeCmd, simple case} { } namespace inscope test_ns_1 cmd } {::test_ns_1::cmd: v=747, args=} -test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { +test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} -setup { + namespace eval test_ns_1 { + variable v 747 + proc cmd {args} { + variable v + return "[namespace current]::cmd: v=$v, args=$args" + } + } +} -body { list [namespace inscope test_ns_1 cmd x y z] \ [namespace eval test_ns_1 [concat cmd [list x y z]]] -} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} -test namespace-29.6 {NamespaceInscopeCmd, 1400572} { +} -result {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} +test namespace-29.6 {NamespaceInscopeCmd, 1400572} -setup { + namespace eval test_ns_1 {} +} -body { namespace inscope test_ns_1 {info level 0} -} {namespace inscope test_ns_1 {info level 0}} - +} -result {namespace inscope test_ns_1 {info level 0}} test namespace-30.1 {NamespaceOriginCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1330,7 +1489,8 @@ test namespace-34.3 {NamespaceWhichCmd, single arg is always command name} { test namespace-34.4 {NamespaceWhichCmd, bad args} { list [catch {namespace which a b} msg] $msg } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} -test namespace-34.5 {NamespaceWhichCmd, command lookup} { +test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { namespace export cmd* variable v1 111 @@ -1343,6 +1503,7 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { variable v2 222 proc p {} {} } +} -body { namespace eval test_ns_3 { namespace import ::test_ns_2::* variable v3 333 @@ -1352,26 +1513,59 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { [namespace which -command ::test_ns_2::cmd2] \ [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} -test namespace-34.6 {NamespaceWhichCmd, -command is default} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} +test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which foreach] \ [namespace which p] \ [namespace which cmd1] \ [namespace which ::test_ns_2::cmd2] } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} -test namespace-34.7 {NamespaceWhichCmd, variable lookup} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} +test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + variable v2 222 + proc p {} {} + } + namespace eval test_ns_3 { + variable v3 333 + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which -variable env] \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} -test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { +test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc p {} { namespace delete [namespace current] @@ -1379,7 +1573,7 @@ test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { } } test_ns_1::p -} {::test_ns_1} +} -result {::test_ns_1} test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { namespace eval test_ns_1 { proc q {} { @@ -2162,6 +2356,13 @@ test namespace-50.8 {[f961d7d1dd]} -setup { rename e {} rename target {} } +test namespace-50.9 {[cea0344a51]} -body { + namespace eval foo { + namespace eval bar { + namespace delete foo + } + } +} -returnCodes error -result {unknown namespace "foo" in namespace delete command} test namespace-51.1 {name resolution path control} -body { namespace eval ::test_ns_1 { diff --git a/tests/oo.test b/tests/oo.test index 62f123c..ccb05c1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3424,6 +3424,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -cleanup { foo destroy } -result {v t} +test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { + oo::class create Super + oo::class create Master { + superclass Super + variable member1 member2 + constructor {} { + set member1 master1 + set member2 master2 + } + method getChild {} { + Child new [self] + } + } + oo::class create Child { + superclass Super + variable member1 result + constructor {m} { + set [namespace current]::member1 child1 + set ns [info object namespace $m] + namespace upvar $ns member1 l1 member2 l2 + upvar 1 member1 l3 member2 l4 + [format namespace] upvar $ns member1 l5 member2 l6 + [format upvar] 1 member1 l7 member2 l8 + set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] + } + method result {} {return $result} + } +} -body { + [[Master new] getChild] result +} -cleanup { + Super destroy +} -result {master1 master2 master1 master2 master1 master2 master1 master2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/tests/resolver.test b/tests/resolver.test index e73ea50..f3d22e5 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -135,6 +135,9 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s z } } + namespace eval :: { + variable r2 "" + } } -constraints testinterpresolver -body { set r0 [namespace eval ::ns2 {x}] set r1 [namespace eval ::ns2 {z}] diff --git a/tests/socket.test b/tests/socket.test index 8473602..d43c41c 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1782,7 +1782,6 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { set i 0 vwait x close $f - thread::wait }]] set port [thread::send $serverthread {set listen}] set s [socket $localhost $port] diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 84654fb..25a5901 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1507,7 +1507,7 @@ SetGroupAttribute( const char *string; int length; - string = Tcl_GetStringFromObj(attributePtr, &length); + string = TclGetStringFromObj(attributePtr, &length); native = Tcl_UtfToExternalDString(NULL, string, length, &ds); groupPtr = TclpGetGrNam(native); /* INTL: Native. */ @@ -1574,7 +1574,7 @@ SetOwnerAttribute( const char *string; int length; - string = Tcl_GetStringFromObj(attributePtr, &length); + string = TclGetStringFromObj(attributePtr, &length); native = Tcl_UtfToExternalDString(NULL, string, length, &ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ @@ -1946,7 +1946,7 @@ TclpObjNormalizePath( const char *currentPathEndPosition; int pathLen; char cur; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_DString ds; const char *nativePath; #ifndef NO_REALPATH @@ -2182,7 +2182,7 @@ TclUnixOpenTemporaryFile( */ if (dirObj) { - string = Tcl_GetStringFromObj(dirObj, &len); + string = TclGetStringFromObj(dirObj, &len); Tcl_UtfToExternalDString(NULL, string, len, &template); } else { Tcl_DStringInit(&template); @@ -2192,7 +2192,7 @@ TclUnixOpenTemporaryFile( TclDStringAppendLiteral(&template, "/"); if (basenameObj) { - string = Tcl_GetStringFromObj(basenameObj, &len); + string = TclGetStringFromObj(basenameObj, &len); Tcl_UtfToExternalDString(NULL, string, len, &tmp); TclDStringAppendDString(&template, &tmp); Tcl_DStringFree(&tmp); @@ -2204,7 +2204,7 @@ TclUnixOpenTemporaryFile( #ifdef HAVE_MKSTEMPS if (extensionObj) { - string = Tcl_GetStringFromObj(extensionObj, &len); + string = TclGetStringFromObj(extensionObj, &len); Tcl_UtfToExternalDString(NULL, string, len, &tmp); TclDStringAppendDString(&template, &tmp); fd = mkstemps(Tcl_DStringValue(&template), Tcl_DStringLength(&tmp)); diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 7ffbf8d..886b5ad 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -269,7 +269,7 @@ TclpMatchInDirectory( Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); - dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); + dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); /* @@ -951,7 +951,7 @@ TclpObjLink( if (transPtr == NULL) { return NULL; } - target = Tcl_GetStringFromObj(transPtr, &targetLen); + target = TclGetStringFromObj(transPtr, &targetLen); target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); Tcl_DecrRefCount(transPtr); @@ -1105,7 +1105,7 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetStringFromObj(validPathPtr, &len); + str = TclGetStringFromObj(validPathPtr, &len); Tcl_UtfToExternalDString(NULL, str, len, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index a9bbc8a..70b900c 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -550,7 +550,7 @@ TclpInitLibraryPath( Tcl_DStringFree(&buffer); *encodingPtr = Tcl_GetEncoding(NULL, NULL); - str = Tcl_GetStringFromObj(pathPtr, lengthPtr); + str = TclGetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((*lengthPtr) + 1); memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index e91f529..4e14e0f 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1526,7 +1526,7 @@ GetWinFileAttributes( */ int len; - const char *str = Tcl_GetStringFromObj(fileName,&len); + const char *str = TclGetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { @@ -1615,7 +1615,7 @@ ConvertFileNameFormat( Tcl_ListObjIndex(NULL, splitPath, i, &elt); - pathv = Tcl_GetStringFromObj(elt, &pathLen); + pathv = TclGetStringFromObj(elt, &pathLen); if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* @@ -1653,7 +1653,7 @@ ConvertFileNameFormat( */ Tcl_DStringInit(&ds); - tempString = Tcl_GetStringFromObj(tempPath,&tempLen); + tempString = TclGetStringFromObj(tempPath,&tempLen); nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); handle = FindFirstFile(nativeName, &data); diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 4b0b884..3a856a1 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -16,8 +16,9 @@ #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> -#include <lm.h> /* For TclpGetUserHome(). */ +#include <lm.h> /* For TclpGetUserHome(). */ #include <userenv.h> /* For TclpGetUserHome(). */ +#include <aclapi.h> /* For GetNamedSecurityInfo */ #ifdef _MSC_VER # pragma comment(lib, "userenv.lib") @@ -935,7 +936,7 @@ TclpMatchInDirectory( int len; DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; - const char *str = Tcl_GetStringFromObj(norm,&len); + const char *str = TclGetStringFromObj(norm,&len); native = Tcl_FSGetNativePath(pathPtr); @@ -995,7 +996,7 @@ TclpMatchInDirectory( */ Tcl_DStringInit(&dsOrig); - dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); + dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; @@ -1794,7 +1795,6 @@ NativeIsExec( if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) || (_tcsicmp(path+len-3, TEXT("com")) == 0) || (_tcsicmp(path+len-3, TEXT("cmd")) == 0) - || (_tcsicmp(path+len-3, TEXT("ps1")) == 0) || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { return 1; } @@ -1953,6 +1953,7 @@ NativeStat( unsigned short mode; unsigned int inode = 0; HANDLE fileHandle; + DWORD fileType = FILE_TYPE_UNKNOWN; /* * If we can use 'createFile' on this, then we can use the resulting @@ -1960,6 +1961,14 @@ NativeStat( * other attributes reading APIs. If not, then we try to fall back on the * 'getFileAttributesExProc', and if that isn't available, then on even * simpler routines. + * + * Special consideration must be given to Windows hardcoded names + * like CON, NULL, COM1, LPT1 etc. For these, we still need to + * do the CreateFile as some may not exist (e.g. there is no CON + * in wish by default). However the subsequent GetFileInformationByHandle + * will fail. We do a WinIsReserved to see if it is one of the special + * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION + * structure. */ fileHandle = CreateFile(nativePath, GENERIC_READ, @@ -1970,19 +1979,26 @@ NativeStat( BY_HANDLE_FILE_INFORMATION data; if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { - CloseHandle(fileHandle); - Tcl_SetErrno(ENOENT); - return -1; - } - CloseHandle(fileHandle); - + fileType = GetFileType(fileHandle); + CloseHandle(fileHandle); + if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) { + Tcl_SetErrno(ENOENT); + return -1; + } + /* Mock up the expected structure */ + memset(&data, 0, sizeof(data)); + statPtr->st_atime = 0; + statPtr->st_mtime = 0; + statPtr->st_ctime = 0; + } else { + CloseHandle(fileHandle); + statPtr->st_atime = ToCTime(data.ftLastAccessTime); + statPtr->st_mtime = ToCTime(data.ftLastWriteTime); + statPtr->st_ctime = ToCTime(data.ftCreationTime); + } attr = data.dwFileAttributes; - statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) | (((Tcl_WideInt) data.nFileSizeHigh) << 32); - statPtr->st_atime = ToCTime(data.ftLastAccessTime); - statPtr->st_mtime = ToCTime(data.ftLastWriteTime); - statPtr->st_ctime = ToCTime(data.ftCreationTime); /* * On Unix, for directories, nlink apparently depends on the number of @@ -2038,6 +2054,13 @@ NativeStat( dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); + if (fileType == FILE_TYPE_CHAR) { + mode &= ~S_IFMT; + mode |= S_IFCHR; + } else if (fileType == FILE_TYPE_DISK) { + mode &= ~S_IFMT; + mode |= S_IFBLK; + } statPtr->st_dev = (dev_t) dev; statPtr->st_ino = inode; @@ -2689,7 +2712,7 @@ TclpObjNormalizePath( tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); - path = Tcl_GetStringFromObj(tmpPathPtr, &len); + path = TclGetStringFromObj(tmpPathPtr, &len); Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); } else { @@ -2775,7 +2798,7 @@ TclWinVolumeRelativeNormalize( int cwdLen; const char *drive = - Tcl_GetStringFromObj(useThisCwd, &cwdLen); + TclGetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { @@ -3111,6 +3134,68 @@ TclpUtime( } /* + *--------------------------------------------------------------------------- + * + * TclWinFileOwned -- + * + * Returns 1 if the specified file exists and is owned by the current + * user and 0 otherwise. Like the Unix case, the check is made using + * the real process SID, not the effective (impersonation) one. + * + *--------------------------------------------------------------------------- + */ + +int +TclWinFileOwned( + Tcl_Obj *pathPtr) /* File whose ownership is to be checked */ +{ + const TCHAR *native; + PSID ownerSid = NULL; + PSECURITY_DESCRIPTOR secd = NULL; + HANDLE token; + LPBYTE buf = NULL; + DWORD bufsz; + int owned = 0; + + native = Tcl_FSGetNativePath(pathPtr); + + if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT, + OWNER_SECURITY_INFORMATION, &ownerSid, + NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { + /* Either not a file, or we do not have access to it in which + case we are in all likelihood not the owner */ + return 0; + } + + /* + * Getting the current process SID is a multi-step process. + * We make the assumption that if a call fails, this process is + * so underprivileged it could not possibly own anything. Normally + * a process can *always* look up its own token. + */ + if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { + /* Find out how big the buffer needs to be */ + bufsz = 0; + GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); + if (bufsz) { + buf = ckalloc(bufsz); + if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) { + owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid); + } + } + CloseHandle(token); + } + + /* Free allocations and be done */ + if (secd) + LocalFree(secd); /* Also frees ownerSid */ + if (buf) + ckfree(buf); + + return (owned != 0); /* Convert non-0 to 1 */ +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 8b600f6..b5a07aa 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -214,7 +214,7 @@ TclpInitLibraryPath( TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; - bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); + bytes = TclGetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((*lengthPtr) + 1); memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); diff --git a/win/tclWinInt.h b/win/tclWinInt.h index c7dbf39..b1c6d26 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -86,6 +86,7 @@ MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal, const TCHAR *LinkCopy); MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal, int linkOnly); +MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) MODULE_SCOPE void TclWinFreeAllocCache(void); MODULE_SCOPE void TclFreeAllocCache(void *); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index aff8836..382addd 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -897,7 +897,7 @@ TclpGetPid( * * The complete Windows search path is searched to find the specified * executable. If an executable by the given name is not found, - * automatically tries appending ".com", ".exe", and ".bat" to the + * automatically tries appending standard extensions to the * executable name. * * Results: @@ -1292,7 +1292,7 @@ ApplicationType( Tcl_DString nameBuf, ds; const TCHAR *nativeName; TCHAR nativeFullPath[MAX_PATH]; - static const char extensions[][5] = {"", ".com", ".exe", ".bat"}; + static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"}; /* * Look for the program as an external program. First try the name as it @@ -1337,7 +1337,8 @@ ApplicationType( Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); - if ((ext != NULL) && (strcasecmp(ext, ".bat") == 0)) { + if ((ext != NULL) && + (strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) { applType = APPL_DOS; break; } diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 45c996a..4ccf365 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -360,6 +360,20 @@ typedef DWORD_PTR * PDWORD_PTR; # define S_IFLNK 0120000 /* Symbolic Link */ #endif +/* + * Windows compilers do not define S_IFBLK. However, Tcl uses it in + * GetTypeFromMode to identify blockSpecial devices based on the + * value in the statsbuf st_mode field. We have no other way to pass this + * from NativeStat on Windows so are forced to define it here. + * The definition here is essentially what is seen on Linux and MingW. + * XXX - the root problem is Tcl using Unix definitions instead of + * abstracting the structure into a platform independent one. Sigh - perhaps + * Tcl 9 + */ +#ifndef S_IFBLK +# define S_IFBLK (S_IFDIR | S_IFCHR) +#endif + #ifndef S_ISREG # ifdef S_IFREG # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) |