summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2016-07-09 15:47:28 (GMT)
committerdgp <dgp@users.sourceforge.net>2016-07-09 15:47:28 (GMT)
commit77e9a375ff3089711d1b2d25da3d190afc639e1e (patch)
tree6ca06be4a2c871912e4d135a868e6ec1a96e9081 /generic
parentd8785b835887dc0c3e6669537d6afbc4389b2153 (diff)
parent25f7d3b86e41d2ba566960340642bb816ecfd7e8 (diff)
downloadtcl-77e9a375ff3089711d1b2d25da3d190afc639e1e.zip
tcl-77e9a375ff3089711d1b2d25da3d190afc639e1e.tar.gz
tcl-77e9a375ff3089711d1b2d25da3d190afc639e1e.tar.bz2
merge 8.6
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCmdAH.c36
-rw-r--r--generic/tclEnsemble.c10
-rw-r--r--generic/tclExecute.c33
-rw-r--r--generic/tclInt.h15
-rw-r--r--generic/tclNamesp.c4
-rw-r--r--generic/tclVar.c55
6 files changed, 86 insertions, 67 deletions
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;