diff options
author | dgp <dgp@users.sourceforge.net> | 2016-07-09 15:47:28 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2016-07-09 15:47:28 (GMT) |
commit | da4f0a3cc9ce8134a629c12ce02572e0ee69bb3b (patch) | |
tree | 6ca06be4a2c871912e4d135a868e6ec1a96e9081 | |
parent | 7332635af1609ad38fa7021022dd79996b75144c (diff) | |
parent | 39488ce3ef11fcbac48bd3c7e35b3ba3fb80c2de (diff) | |
download | tcl-da4f0a3cc9ce8134a629c12ce02572e0ee69bb3b.zip tcl-da4f0a3cc9ce8134a629c12ce02572e0ee69bb3b.tar.gz tcl-da4f0a3cc9ce8134a629c12ce02572e0ee69bb3b.tar.bz2 |
merge 8.6
-rw-r--r-- | doc/exec.n | 5 | ||||
-rw-r--r-- | doc/file.n | 7 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 36 | ||||
-rw-r--r-- | generic/tclEnsemble.c | 10 | ||||
-rw-r--r-- | generic/tclExecute.c | 33 | ||||
-rw-r--r-- | generic/tclInt.h | 15 | ||||
-rw-r--r-- | generic/tclNamesp.c | 4 | ||||
-rw-r--r-- | generic/tclVar.c | 55 | ||||
-rw-r--r-- | tests/cmdAH.test | 62 | ||||
-rw-r--r-- | tests/exec.test | 16 | ||||
-rw-r--r-- | tests/oo.test | 32 | ||||
-rwxr-xr-x | win/tclWinFile.c | 110 | ||||
-rw-r--r-- | win/tclWinInt.h | 1 | ||||
-rw-r--r-- | win/tclWinPipe.c | 7 | ||||
-rw-r--r-- | win/tclWinPort.h | 14 |
15 files changed, 317 insertions, 90 deletions
@@ -271,8 +271,9 @@ limitation as \fBexec\fR wants to communicate over pipes. The Expect extension addresses this issue when communicating with a TUI application. .PP When attempting to execute an application, \fBexec\fR first searches for -the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and -\fB.bat\fR are appended to the end of the specified name and it searches +the name as it was specified. Then, in order, +\fB.com\fR, \fB.exe\fR, \fB.bat\fR and \fB.cmd\fR +are appended to the end of the specified name and it searches for the longer name. If a directory name was not specified as part of the application name, the following directories are automatically searched in order when attempting to locate the application: @@ -484,10 +484,9 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fBfile owned\fR subcommand currently always reports that the current user -is the owner of the file, without regard for what the operating system -believes to be true, making an ownership test useless. This issue (#3613671) -may be fixed in a future release of Tcl. +The \fBfile owned\fR subcommand uses the user identifier (SID) of +the process token, not the thread token which may be impersonating +some other user. .SH EXAMPLES .PP This procedure shows how to search for C files in a given directory diff --git a/generic/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/tclEnsemble.c b/generic/tclEnsemble.c index d5d896a..2766769 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -95,7 +95,7 @@ typedef struct { int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ - Tcl_Command token; /* Reference to the comamnd for which this + Command *token; /* Reference to the command for which this * structure is a cache of the resolution. */ Tcl_Obj *fix; /* Corrected spelling, if needed. */ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand @@ -1722,7 +1722,7 @@ NsEnsembleImplementationCmdNR( EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; if (ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == ensemblePtr->token) { + ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); if (ensembleCmd->fix) { @@ -2348,6 +2348,7 @@ MakeCachedEnsembleCommand( if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } @@ -2368,7 +2369,8 @@ MakeCachedEnsembleCommand( */ ensembleCmd->epoch = ensemblePtr->epoch; - ensembleCmd->token = ensemblePtr->token; + ensembleCmd->token = (Command *) ensemblePtr->token; + ensembleCmd->token->refCount++; if (fix) { Tcl_IncrRefCount(fix); } @@ -2754,6 +2756,7 @@ FreeEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } @@ -2791,6 +2794,7 @@ DupEnsembleCmdRep( copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; + ensembleCopy->token->refCount++; ensembleCopy->fix = ensembleCmd->fix; if (ensembleCopy->fix) { Tcl_IncrRefCount(ensembleCopy->fix); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a9c5de5..5c7505b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3153,20 +3153,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) { @@ -3174,13 +3161,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); /* * ----------------------------------------------------------------- @@ -4413,8 +4412,8 @@ TEBCresume( savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { TRACE_ERROR(interp); diff --git a/generic/tclInt.h b/generic/tclInt.h index 5ccd637..c01b0c1 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. *---------------------------------------------------------------- diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2c50a60..5930859 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4538,8 +4538,8 @@ NamespaceUpvarCmd( savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; if (otherPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclVar.c b/generic/tclVar.c index dc7fa20..a9bedd7 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -725,21 +725,6 @@ TclObjLookupVarEx( } /* - * This flag bit should not interfere with TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable - * lookup is performed for upvar (or similar) purposes, with slightly - * different rules: - * - Bug #696893 - variable is either proc-local or in the current - * namespace; never follow the second (global) resolution path - * - Bug #631741 - do not use special namespace or interp resolvers - * - * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag - * (Bug #835020) - */ - -#define AVOID_RESOLVERS 0x40000 - -/* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- @@ -788,8 +773,8 @@ TclLookupSimpleVar( Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG bits - * matter. */ + * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG + * bits matter. */ const int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ @@ -829,7 +814,7 @@ TclLookupSimpleVar( */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & AVOID_RESOLVERS)) { + && !(flags & TCL_AVOID_RESOLVERS)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = cxtNsPtr->varResProc(interp, varName, @@ -882,7 +867,7 @@ TclLookupSimpleVar( *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - if (flags & AVOID_RESOLVERS) { + if (flags & TCL_AVOID_RESOLVERS) { flags = (flags | TCL_NAMESPACE_ONLY); } if (flags & TCL_NAMESPACE_ONLY) { @@ -897,7 +882,7 @@ TclLookupSimpleVar( varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr, (Tcl_Namespace *) cxtNsPtr, - (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); + (flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { Tcl_Obj *tailPtr; @@ -4379,15 +4364,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", @@ -5615,11 +5600,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. */ @@ -5645,11 +5631,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. */ @@ -5679,7 +5666,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/tests/cmdAH.test b/tests/cmdAH.test index f2f7f8c..ef933cb 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1026,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 @@ -1257,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 { @@ -1276,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 { @@ -1306,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 @@ -1397,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 @@ -1437,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/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/oo.test b/tests/oo.test index 62f123c..ccb05c1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3424,6 +3424,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -cleanup { foo destroy } -result {v t} +test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { + oo::class create Super + oo::class create Master { + superclass Super + variable member1 member2 + constructor {} { + set member1 master1 + set member2 master2 + } + method getChild {} { + Child new [self] + } + } + oo::class create Child { + superclass Super + variable member1 result + constructor {m} { + set [namespace current]::member1 child1 + set ns [info object namespace $m] + namespace upvar $ns member1 l1 member2 l2 + upvar 1 member1 l3 member2 l4 + [format namespace] upvar $ns member1 l5 member2 l6 + [format upvar] 1 member1 l7 member2 l8 + set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] + } + method result {} {return $result} + } +} -body { + [[Master new] getChild] result +} -cleanup { + Super destroy +} -result {master1 master2 master1 master2 master1 master2 master1 master2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/win/tclWinFile.c b/win/tclWinFile.c index c840a46..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") @@ -1794,7 +1795,6 @@ NativeIsExec( if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) || (_tcsicmp(path+len-3, TEXT("com")) == 0) || (_tcsicmp(path+len-3, TEXT("cmd")) == 0) - || (_tcsicmp(path+len-3, TEXT("ps1")) == 0) || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { return 1; } @@ -1953,6 +1953,7 @@ NativeStat( unsigned short mode; unsigned int inode = 0; HANDLE fileHandle; + DWORD fileType = FILE_TYPE_UNKNOWN; /* * If we can use 'createFile' on this, then we can use the resulting @@ -1960,6 +1961,14 @@ NativeStat( * other attributes reading APIs. If not, then we try to fall back on the * 'getFileAttributesExProc', and if that isn't available, then on even * simpler routines. + * + * Special consideration must be given to Windows hardcoded names + * like CON, NULL, COM1, LPT1 etc. For these, we still need to + * do the CreateFile as some may not exist (e.g. there is no CON + * in wish by default). However the subsequent GetFileInformationByHandle + * will fail. We do a WinIsReserved to see if it is one of the special + * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION + * structure. */ fileHandle = CreateFile(nativePath, GENERIC_READ, @@ -1970,19 +1979,26 @@ NativeStat( BY_HANDLE_FILE_INFORMATION data; if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { - CloseHandle(fileHandle); - Tcl_SetErrno(ENOENT); - return -1; - } - CloseHandle(fileHandle); - + fileType = GetFileType(fileHandle); + CloseHandle(fileHandle); + if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) { + Tcl_SetErrno(ENOENT); + return -1; + } + /* Mock up the expected structure */ + memset(&data, 0, sizeof(data)); + statPtr->st_atime = 0; + statPtr->st_mtime = 0; + statPtr->st_ctime = 0; + } else { + CloseHandle(fileHandle); + statPtr->st_atime = ToCTime(data.ftLastAccessTime); + statPtr->st_mtime = ToCTime(data.ftLastWriteTime); + statPtr->st_ctime = ToCTime(data.ftCreationTime); + } attr = data.dwFileAttributes; - statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) | (((Tcl_WideInt) data.nFileSizeHigh) << 32); - statPtr->st_atime = ToCTime(data.ftLastAccessTime); - statPtr->st_mtime = ToCTime(data.ftLastWriteTime); - statPtr->st_ctime = ToCTime(data.ftCreationTime); /* * On Unix, for directories, nlink apparently depends on the number of @@ -2038,6 +2054,13 @@ NativeStat( dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); + if (fileType == FILE_TYPE_CHAR) { + mode &= ~S_IFMT; + mode |= S_IFCHR; + } else if (fileType == FILE_TYPE_DISK) { + mode &= ~S_IFMT; + mode |= S_IFBLK; + } statPtr->st_dev = (dev_t) dev; statPtr->st_ino = inode; @@ -3111,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/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) |