diff options
62 files changed, 828 insertions, 396 deletions
diff --git a/doc/SetResult.3 b/doc/SetResult.3 index dc8f487..e5b81d7 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -164,7 +164,7 @@ The source interpreter will have its result reset by this operation. .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP -Use of the following procedures (is deprecated +Use of the following procedures is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR that manipulate the result as a value @@ -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: @@ -162,7 +162,9 @@ returns \fB/home\fR (or something similar). \fBfile executable \fIname\fR . Returns \fB1\fR if file \fIname\fR is executable by the current user, -\fB0\fR otherwise. +\fB0\fR otherwise. On Windows, which does not have an executable attribute, +the command treats all directories and any files with extensions +\fBexe\fR, \fBcom\fR, \fBcmd\fR, \fBbat\fR or \fBps1\fR as executable. .TP \fBfile exists \fIname\fR . @@ -482,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/tclAssembly.c b/generic/tclAssembly.c index a0a6061..8540b59 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1300,7 +1300,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; @@ -1449,7 +1449,7 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); /* @@ -2289,7 +2289,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 d8f8188..9de8d1d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -128,7 +128,7 @@ static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; -static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +static Tcl_NRPostProc NRCommand; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); @@ -146,7 +146,6 @@ static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; @@ -3949,7 +3948,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -4048,7 +4047,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. */ @@ -4560,7 +4559,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); } @@ -4706,7 +4705,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. @@ -4758,7 +4757,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){ @@ -6123,7 +6122,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6154,7 +6153,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -8401,7 +8400,7 @@ TclNRTailcallEval( * a now-gone namespace: cleanup and return. */ - TailcallCleanup(data, interp, result); + Tcl_DecrRefCount(listPtr); return result; } @@ -8410,18 +8409,26 @@ TclNRTailcallEval( */ TclMarkTailcall(interp); - TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); } -static int -TailcallCleanup( +int +TclNRReleaseValues( ClientData data[], Tcl_Interp *interp, int result) { - Tcl_DecrRefCount((Tcl_Obj *) data[0]); + int i = 0; + while (i < 4) { + if (data[i]) { + Tcl_DecrRefCount((Tcl_Obj *) data[i]); + } else { + break; + } + i++; + } return result; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 337fd20..ea863cc 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2507,7 +2507,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/tclCmdAH.c b/generic/tclCmdAH.c index 54e0227..13d3df5 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -12,6 +12,9 @@ */ #include "tclInt.h" +#ifdef _WIN32 +# include "tclWinInt.h" +#endif #include <locale.h> /* @@ -1157,6 +1160,16 @@ FileAttrAccessTimeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } +#if defined(_WIN32) + /* We use a value of 0 to indicate the access time not available */ + if (buf.st_atime == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get access time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; + } +#endif + if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit @@ -1229,6 +1242,15 @@ FileAttrModifyTimeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } +#if defined(_WIN32) + /* We use a value of 0 to indicate the modification time not available */ + if (buf.st_mtime == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get modification time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; + } +#endif if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit @@ -1581,21 +1603,13 @@ FileAttrIsOwnedCmd( 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; + value = TclWinFileOwned(objv[1]); #else + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { value = (geteuid() == buf.st_uid); -#endif } +#endif Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8f50016..df1d33c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -105,8 +105,7 @@ typedef struct SortInfo { */ static int DictionaryCompare(const char *left, const char *right); -static int IfConditionCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc IfConditionCallback; static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 71e8555..df22261 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -22,14 +22,10 @@ static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static int SwitchPostProc(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostBody(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostFinal(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostHandler(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc SwitchPostProc; +static Tcl_NRPostProc TryPostBody; +static Tcl_NRPostProc TryPostFinal; +static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); diff --git a/generic/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/tclCompile.c b/generic/tclCompile.c index 5f8d9d2..cdd75d9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1320,7 +1320,7 @@ CompileSubstObj( if (codePtr == NULL) { 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); @@ -1800,7 +1800,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); @@ -2737,7 +2737,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); @@ -2974,7 +2974,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; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index da18a2b..e52edb5 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -71,18 +71,12 @@ static inline void DeleteChainTable(struct Dict *dict); static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, Tcl_Obj *keyPtr, int *newPtr); static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); -static int FinalizeDictUpdate(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeDictWith(ClientData data[], - Tcl_Interp *interp, int result); -static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictForLoopCallback(ClientData data[], - Tcl_Interp *interp, int result); -static int DictMapLoopCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeDictUpdate; +static Tcl_NRPostProc FinalizeDictWith; +static Tcl_ObjCmdProc DictForNRCmd; +static Tcl_ObjCmdProc DictMapNRCmd; +static Tcl_NRPostProc DictForLoopCallback; +static Tcl_NRPostProc DictMapLoopCallback; /* * Table of dict subcommand names and implementations. diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index ad4af5c..92e5c2e 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -6,7 +6,7 @@ * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2013 Donal K. Fellows. + * Copyright (c) 2013-2016 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -202,7 +202,7 @@ TclPrintObject( char *bytes; int length; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -663,7 +663,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); @@ -1297,9 +1297,11 @@ Tcl_DisassembleObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const types[] = { + "constructor", "destructor", "lambda", "method", "objmethod", "proc", "script", NULL }; enum Types { + DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, DISAS_SCRIPT }; @@ -1309,6 +1311,7 @@ Tcl_DisassembleObjCmd( Tcl_HashEntry *hPtr; Object *oPtr; ByteCode *codePtr; + Method *methodPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); @@ -1396,6 +1399,136 @@ Tcl_DisassembleObjCmd( codeObjPtr = objv[2]; break; + case DISAS_CLASS_CONSTRUCTOR: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "className"); + return TCL_ERROR; + } + + /* + * Look up the body of a constructor. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + methodPtr = oPtr->classPtr->constructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined constructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "CONSRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + /* + * Compile if necessary. + */ + + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of constructor", + TclGetString(objv[2])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + + case DISAS_CLASS_DESTRUCTOR: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "className"); + return TCL_ERROR; + } + + /* + * Look up the body of a destructor. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + methodPtr = oPtr->classPtr->destructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined destructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "DESRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of destructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + /* + * Compile if necessary. + */ + + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of destructor", + TclGetString(objv[2])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + case DISAS_CLASS_METHOD: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index b3ad1e4..5db6859 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -3649,7 +3649,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 a86b5c4..2766769 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -41,6 +41,8 @@ static int CompileBasicNArgCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr); +static Tcl_NRPostProc FreeER; + /* * The lists of subcommands and options for the [namespace ensemble] command. */ @@ -93,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 @@ -1720,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) { @@ -1769,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], @@ -1843,46 +1845,26 @@ NsEnsembleImplementationCmdNR( */ { - Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the - * target command prefix. */ Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. * Will be freed by the dispatch engine. */ - int prefixObjc, copyObjc; + Tcl_Obj **copyObjv; + int copyObjc, prefixObjc; - /* - * Get the prefix that we're rewriting to. To do this we need to - * ensure that the internal representation of the list does not change - * so that we can safely keep the internal representations of the - * elements in the list. - * - * TODO: Use conventional list operations to make this code sane! - */ + Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); - TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); - - copyObjc = objc - 2 + prefixObjc; - copyPtr = Tcl_NewListObj(copyObjc, NULL); - if (copyObjc > 0) { - register Tcl_Obj **copyObjv; - /* Space used to construct the list of - * arguments to pass to the command that - * implements the ensemble subcommand. */ - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - register int i; - - listRepPtr->elemCount = copyObjc; - copyObjv = &listRepPtr->elements; - memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(copyObjv+prefixObjc, objv+1, - sizeof(Tcl_Obj *) * ensemblePtr->numParameters); - memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters, - objv+ensemblePtr->numParameters+2, - sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2)); - - for (i=0; i < copyObjc; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - } + if (objc == 2) { + copyPtr = TclListObjCopy(NULL, prefixObj); + } else { + copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); + Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + ensemblePtr->numParameters, objv + 1); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + objc - 2 - ensemblePtr->numParameters, + objv + 2 + ensemblePtr->numParameters); + } + Tcl_IncrRefCount(copyPtr); + TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL); TclDecrRefCount(prefixObj); /* @@ -1902,7 +1884,8 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); + Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: @@ -2055,7 +2038,7 @@ TclResetRewriteEnsemble( * * TclSpellFix -- * - * Record a spelling correction that needs making in the + * Record a spelling correction that needs making in the * generation of the WrongNumArgs usage message. * * Results: @@ -2080,18 +2063,6 @@ FreeER( return result; } -static int -FreeObj( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *objPtr = (Tcl_Obj *)data[0]; - - Tcl_DecrRefCount(objPtr); - return result; -} - void TclSpellFix( Tcl_Interp *interp, @@ -2115,7 +2086,7 @@ TclSpellFix( /* Compute the valid length of the ensemble root */ - size = iPtr->ensembleRewrite.numRemovedObjs + objc + size = iPtr->ensembleRewrite.numRemovedObjs + objc - iPtr->ensembleRewrite.numInsertedObjs; search = iPtr->ensembleRewrite.sourceObjs; @@ -2167,7 +2138,7 @@ TclSpellFix( store[idx] = fix; Tcl_IncrRefCount(fix); - TclNRAddCallback(interp, FreeObj, fix, NULL, NULL, NULL); + TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } /* @@ -2377,7 +2348,8 @@ MakeCachedEnsembleCommand( if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - if (ensembleCmd->fix) { + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } } else { @@ -2397,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); } @@ -2783,6 +2756,7 @@ FreeEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } @@ -2820,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); @@ -2942,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! @@ -3344,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; } @@ -3373,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 b24e1ec..538e5b5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2082,8 +2082,6 @@ TclNRExecuteByteCode( * Push the callback for bytecode execution */ - TclResetRewriteEnsemble(interp, 1); - TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, /* cleanup */ INT2PTR(0), NULL); return TCL_OK; @@ -3163,20 +3161,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) { @@ -3184,13 +3169,25 @@ 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); + 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); /* * ----------------------------------------------------------------- @@ -4423,8 +4420,8 @@ TEBCresume( savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { TRACE_ERROR(interp); @@ -9845,7 +9842,7 @@ IllegalExprOperandType( if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -10474,7 +10471,7 @@ EvalStatsCmd( if (NULL != Tcl_FetchIntRep(entryPtr->objPtr, &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)); @@ -10696,7 +10693,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 2136883..150fb8c 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -387,7 +387,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] == '~') { /* @@ -578,7 +578,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; } @@ -597,7 +597,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; } @@ -857,7 +857,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 @@ -885,7 +885,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -921,7 +921,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -1003,7 +1003,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = Tcl_GetStringFromObj(resultObj, &len); + resultStr = TclGetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1249,7 +1249,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "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 @@ -1357,7 +1357,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 @@ -1460,7 +1460,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) { @@ -1992,7 +1992,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)) { /* @@ -2010,7 +2010,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) { @@ -2362,7 +2362,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); @@ -2400,7 +2400,7 @@ DoGlob( Tcl_DStringAppend(&append, pattern, p-pattern); if (pathPtr != NULL) { - (void) Tcl_GetStringFromObj(pathPtr, &length); + (void) TclGetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2446,7 +2446,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); @@ -2483,7 +2483,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/tclIORChan.c b/generic/tclIORChan.c index f476a1a..1089d2b 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 af86ba5..47e0bc8 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 1330c02..397c3b1 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -71,8 +71,7 @@ typedef struct ThreadSpecificData { * Prototypes for functions defined later in this file. */ -static int EvalFileCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc EvalFileCallback; static FilesystemRecord*FsGetFirstFilesystem(void); static void FsThrExitProc(ClientData cd); static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); @@ -545,8 +544,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 @@ -689,7 +688,7 @@ FsUpdateCwd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = Tcl_GetStringFromObj(cwdObj, &len); + str = TclGetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -1225,8 +1224,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. @@ -1817,7 +1816,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. @@ -1844,7 +1843,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); @@ -1995,7 +1994,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); @@ -2847,8 +2846,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 @@ -4116,7 +4115,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, @@ -4228,7 +4227,7 @@ TclFSNonnativePathType( numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = Tcl_GetStringFromObj(vol,&len); + strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4575,8 +4574,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 c2aa439..50265c7 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -713,10 +713,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. @@ -769,13 +769,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 @@ -1150,7 +1150,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.h b/generic/tclInt.h index 4d9bc3f..6b46866 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -183,6 +183,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. *---------------------------------------------------------------- @@ -2754,6 +2769,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; +MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); @@ -2864,8 +2880,7 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; -MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], - Tcl_Interp *interp, int result); +MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 7be0dac..b8b9977 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 27bd490..1992fb5 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -527,7 +527,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 03200ca..e0425cf 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -671,7 +671,7 @@ AddLocalLiteralEntry( } if (!found) { - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } @@ -1147,14 +1147,14 @@ 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); } 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); @@ -1205,7 +1205,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 28f8fd8..f89bd5e 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 679f60e..43f2c1a 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4558,8 +4558,8 @@ NamespaceUpvarCmd( savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; if (otherPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclOO.c b/generic/tclOO.c index 9dae778..ef0c987 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -68,12 +68,9 @@ static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, static void DeletedDefineNamespace(ClientData clientData); static void DeletedObjdefNamespace(ClientData clientData); static void DeletedHelpersNamespace(ClientData clientData); -static int FinalizeAlloc(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeNext(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeObjectCall(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeAlloc; +static Tcl_NRPostProc FinalizeNext; +static Tcl_NRPostProc FinalizeObjectCall; static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 68c4b8e..0a265e5 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -71,15 +71,12 @@ static void AddSimpleClassChainToCallContext(Class *classPtr, Class *const filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); -static int FinalizeMethodRefs(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); -static int ResetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); -static int SetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc ResetFilterFlags; +static Tcl_NRPostProc SetFilterFlags; static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 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 41f21aa..3d9fc35 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -70,10 +70,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp, - int result); -static int FinalizePMCall(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc FinalizeForwardCall; +static Tcl_NRPostProc FinalizePMCall; static int PushMethodCallFrame(Tcl_Interp *interp, CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, @@ -1168,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 e6d3d5b..8572575 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 */ /* @@ -2173,7 +2173,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 \""); 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 90a5ebe..ce371bd 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,11 +869,15 @@ 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 == &fsPathType) - && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) { + && !((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); @@ -881,7 +885,7 @@ TclJoinPath( 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 86777a8..244eb94 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -842,7 +842,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) { @@ -883,7 +883,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; } @@ -1034,7 +1034,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 { @@ -1682,7 +1682,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 286754e..a01a314 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -378,7 +378,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; } @@ -2127,7 +2127,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( @@ -2818,7 +2818,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/tclStringObj.c b/generic/tclStringObj.c index 5d38b28..551fd1f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2285,7 +2285,7 @@ Tcl_AppendFormatToObj( } } - Tcl_GetStringFromObj(segment, &segmentNumBytes); + TclGetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); diff --git a/generic/tclTest.c b/generic/tclTest.c index d4ca674..ec53d2f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -408,8 +408,7 @@ static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int NREUnwind_callback(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc NREUnwind_callback; static int TestNREUnwind(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index a9a6e04..edab8da 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -894,10 +894,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 33e62b2..0c73cba 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 9c86839..57604f8 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1967,7 +1967,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -2676,7 +2676,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *bytes = TclGetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -3912,7 +3912,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 003338c..d2fc668 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -721,21 +721,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 - * - * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag - * (Bug #835020) - */ - -#define AVOID_RESOLVERS 0x40000 - -/* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- @@ -784,8 +769,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. */ @@ -825,7 +810,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, @@ -878,7 +863,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) { @@ -893,7 +878,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; @@ -4375,15 +4360,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", @@ -5611,11 +5596,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. */ @@ -5641,11 +5627,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. */ @@ -5675,7 +5662,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 dac47cf..10fa4f7 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 9fd279f..6c2e3b7 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 64cfeba..ef933cb 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -879,19 +879,18 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { # On pc, must be a .exe, .com, etc. set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe $gorpexe] -} -cleanup { - removeFile $gorpexe -} -result {0 1} -test cmdAH-18.5.1 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe [string toupper $gorpexe]] + set gorpexes {} + foreach ext {exe com cmd bat ps1} { + set gorpexe [makeFile foo gorp.$ext] + lappend gorpexes $gorpexe + lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]] + } + set x } -cleanup { - removeFile $gorpexe -} -result {0 1} + foreach gorpexe $gorpexes { + removeFile $gorpexe + } +} -result {0 1 1 1 1 1 1 1 1 1 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { # Directories are always executable. file exe $dirfile @@ -1027,6 +1026,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 @@ -1258,6 +1267,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 { @@ -1277,6 +1296,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 { @@ -1307,6 +1332,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 @@ -1398,12 +1433,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 @@ -1438,6 +1485,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/compile.test b/tests/compile.test index 6aa7fd1..2fa4147 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -678,7 +678,7 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # change without warning. set disassemblables [linsert [join { - lambda method objmethod proc script + constructor destructor lambda method objmethod proc script } ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble @@ -872,6 +872,103 @@ test compile-18.39 {disassembler - basics} -setup { } -cleanup { foo destroy } -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.40 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.41 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.42 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble constructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.43 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.44 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble constructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.45 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.46 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.47 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.48 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode constructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" +# There is no compile-18.49 +test compile-18.50 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.51 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.52 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble destructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.53 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.54 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble destructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.55 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.56 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.57 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.58 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode destructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. 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/fileName.test b/tests/fileName.test index 51f00d1..a19bd1e 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1468,14 +1468,16 @@ if {[testConstraint testsetplatform]} { } test filename-17.2 {windows specific glob with executable} -body { makeDirectory execglob - makeFile contents execglob/abc.exe - makeFile contents execglob/abc.notexecutable - glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x * + foreach ext {exe com cmd bat ps1 notexecutable} { + makeFile contents execglob/abc.$ext + } + lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *] } -constraints {win} -cleanup { - removeFile execglob/abc.exe - removeFile execglob/abc.notexecutable + foreach ext {exe com cmd bat ps1 notexecutable} { + removeFile execglob/abc.$ext + } removeDirectory execglob -} -result {abc.exe} +} -result {abc.bat abc.cmd abc.com abc.exe abc.ps1} test filename-17.3 {Bug 2571597} win { set p /a file pathtype $p diff --git a/tests/oo.test b/tests/oo.test index 9491f78..ccb05c1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2017,6 +2017,12 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" +test oo-16.1.1 {OO: object introspection} -body { + catch {info object} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info object subcommand ?arg ...?\" + while executing +\"info object\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -2156,6 +2162,12 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" +test oo-17.1.1 {OO: class introspection} -body { + catch {info class} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info class subcommand ?arg ...?\" + while executing +\"info class\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -3412,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/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 6d95640..8634a5e 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -11,7 +11,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef STATIC_BUILD #include "tcl.h" /* @@ -70,7 +69,7 @@ PkguaInterpToTokens( int newEntry; Tcl_Command *cmdTokens; Tcl_HashEntry *entryPtr = - Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry); + Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry); if (newEntry) { cmdTokens = (Tcl_Command *) @@ -90,7 +89,7 @@ PkguaDeleteTokens( Tcl_Interp *interp) { Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&interpTokenMap, (char *) interp); + Tcl_FindHashEntry(&interpTokenMap, interp); if (entryPtr) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index a1a409e..4d38f8e 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1509,7 +1509,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. */ @@ -1576,7 +1576,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. */ @@ -1948,7 +1948,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 @@ -2184,7 +2184,7 @@ TclUnixOpenTemporaryFile( */ if (dirObj) { - string = Tcl_GetStringFromObj(dirObj, &len); + string = TclGetStringFromObj(dirObj, &len); Tcl_UtfToExternalDString(NULL, string, len, &template); } else { Tcl_DStringInit(&template); @@ -2194,7 +2194,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); @@ -2206,7 +2206,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 aaff9ec..57215f1 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 52ea8c6..8904a05 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 25c6ea4..63abad9 100755 --- 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]; @@ -1769,7 +1770,7 @@ NativeAccess( * NativeIsExec -- * * Determines if a path is executable. On windows this is simply defined - * by whether the path ends in any of ".exe", ".com", or ".bat" + * by whether the path ends in a standard executable extension. * * Results: * 1 = executable, 0 = not. @@ -1793,6 +1794,7 @@ 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("bat")) == 0)) { return 1; } @@ -1951,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 @@ -1958,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, @@ -1968,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 @@ -2036,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; @@ -2687,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 { @@ -2773,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') { @@ -3109,6 +3134,69 @@ 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(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); + } + +vamoose: + /* 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 9df424f..6b098f8 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -72,6 +72,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 ca6b2bf..b486466 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) |