summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2019-05-03 20:06:09 (GMT)
committerdgp <dgp@users.sourceforge.net>2019-05-03 20:06:09 (GMT)
commita35dd1803660e9f68391c597e20b3c0f72e320ad (patch)
tree5f6c5fe71c2e8c8aa511b015f78e19234d06d408
parent79ac1a3b1956162a598c734c948ed6c9a75bd305 (diff)
parent48891ff56a16c20d88b9643b9949a9915208188f (diff)
downloadtcl-a35dd1803660e9f68391c597e20b3c0f72e320ad.zip
tcl-a35dd1803660e9f68391c597e20b3c0f72e320ad.tar.gz
tcl-a35dd1803660e9f68391c597e20b3c0f72e320ad.tar.bz2
merge 8.6
-rw-r--r--generic/tclBasic.c187
-rw-r--r--generic/tclBinary.c5
-rw-r--r--generic/tclOO.c89
-rw-r--r--generic/tclOOCall.c17
-rw-r--r--generic/tclOODefineCmds.c76
-rw-r--r--generic/tclTest.c6
-rw-r--r--generic/tclTimer.c26
-rw-r--r--tests/coroutine.test75
-rw-r--r--tests/link.test10
-rwxr-xr-x[-rw-r--r--]win/tclWinFile.c309
-rw-r--r--win/tclWinPipe.c459
11 files changed, 851 insertions, 408 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 84c87d0..87533ac 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -173,6 +173,7 @@ static Tcl_NRPostProc Dispatch;
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
+static Tcl_ObjCmdProc CoroTypeObjCmd;
MODULE_SCOPE const TclStubs tclStubs;
@@ -973,8 +974,11 @@ Tcl_CreateInterp(void)
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
+ /* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
+ CoroTypeObjCmd, NULL, NULL);
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
@@ -2377,14 +2381,16 @@ Tcl_CreateCommand(
break;
}
- /* An existing command conflicts. Try to delete it.. */
+ /*
+ * An existing command conflicts. Try to delete it...
+ */
+
cmdPtr = Tcl_GetHashValue(hPtr);
/*
- * Be careful to preserve
- * any existing import links so we can restore them down below. That
- * way, you can redefine a command and its import status will remain
- * intact.
+ * Be careful to preserve any existing import links so we can restore
+ * them down below. That way, you can redefine a command and its
+ * import status will remain intact.
*/
cmdPtr->refCount++;
@@ -2404,16 +2410,15 @@ Tcl_CreateCommand(
if (!isNew) {
/*
- * If the deletion callback recreated the command, just throw away
- * the new command (if we try to delete it again, we could get
- * stuck in an infinite loop).
+ * If the deletion callback recreated the command, just throw away the
+ * new command (if we try to delete it again, we could get stuck in an
+ * infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
}
if (!deleted) {
-
/*
* Command resolvers (per-interp, per-namespace) might have resolved
* to a command for the given namespace scope with this command not
@@ -2596,17 +2601,17 @@ TclCreateObjCommandInNs(
}
/*
- * An existing command conflicts. Try to delete it.
+ * An existing command conflicts. Try to delete it...
*/
cmdPtr = Tcl_GetHashValue(hPtr);
/*
- * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy
- * behavior is kept under particular circumstances to accommodate
- * deployed binaries of the "tclcompiler" program
- * http://sourceforge.net/projects/tclpro/
- * that crash if the bug is fixed.
+ * [***] This is wrong. See Tcl Bug a16752c252.
+ * However, this buggy behavior is kept under particular circumstances
+ * to accommodate deployed binaries of the "tclcompiler" program
+ * <http://sourceforge.net/projects/tclpro/> that crash if the bug is
+ * fixed.
*/
if (cmdPtr->objProc == TclInvokeStringCommand
@@ -4606,15 +4611,22 @@ EvalObjvCore(
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
- /* Caller gave it to us */
+ /*
+ * Caller gave it to us.
+ */
+
if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
- /* So long as it exists, use it. */
+ /*
+ * So long as it exists, use it.
+ */
+
cmdPtr = preCmdPtr;
} else if (flags & TCL_EVAL_NORESOLVE) {
/*
- * When it's been deleted, and we're told not to attempt
- * resolving it ourselves, all we can do is raise an error.
+ * When it's been deleted, and we're told not to attempt resolving
+ * it ourselves, all we can do is raise an error.
*/
+
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to invoke a deleted command"));
Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
@@ -4630,14 +4642,12 @@ EvalObjvCore(
if (enterTracesDone || iPtr->tracePtr
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
-
Tcl_Obj *commandPtr = TclGetSourceFromFrame(
flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
objc, objv);
- Tcl_IncrRefCount(commandPtr);
+ Tcl_IncrRefCount(commandPtr);
if (!enterTracesDone) {
-
int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
objc, objv);
@@ -4645,10 +4655,10 @@ EvalObjvCore(
* Send any exception from enter traces back as an exception
* raised by the traced command.
* TODO: Is this a bug? Letting an execution trace BREAK or
- * CONTINUE or RETURN in the place of the traced command?
- * Would either converting all exceptions to TCL_ERROR, or
- * just swallowing them be better? (Swallowing them has the
- * problem of permanently hiding program errors.)
+ * CONTINUE or RETURN in the place of the traced command? Would
+ * either converting all exceptions to TCL_ERROR, or just
+ * swallowing them be better? (Swallowing them has the problem of
+ * permanently hiding program errors.)
*/
if (code != TCL_OK) {
@@ -4657,9 +4667,8 @@ EvalObjvCore(
}
/*
- * If the enter traces made the resolved cmdPtr unusable, go
- * back and resolve again, but next time don't run enter
- * traces again.
+ * If the enter traces made the resolved cmdPtr unusable, go back
+ * and resolve again, but next time don't run enter traces again.
*/
if (cmdPtr == NULL) {
@@ -4670,9 +4679,9 @@ EvalObjvCore(
}
/*
- * Schedule leave traces. Raise the refCount on the resolved
- * cmdPtr, so that when it passes to the leave traces we know
- * it's still valid.
+ * Schedule leave traces. Raise the refCount on the resolved cmdPtr,
+ * so that when it passes to the leave traces we know it's still
+ * valid.
*/
cmdPtr->refCount++;
@@ -4742,8 +4751,6 @@ TclNRRunCallbacks(
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
#endif /* !defined(TCL_NO_DEPRECATED) */
- NRE_callback *callbackPtr;
- Tcl_NRPostProc *procPtr;
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4761,11 +4768,14 @@ TclNRRunCallbacks(
}
#endif /* !defined(TCL_NO_DEPRECATED) */
- /* This is the trampoline. */
+ /*
+ * This is the trampoline.
+ */
while (TOP_CB(interp) != rootPtr) {
- callbackPtr = TOP_CB(interp);
- procPtr = callbackPtr->procPtr;
+ NRE_callback *callbackPtr = TOP_CB(interp);
+ Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
+
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
@@ -6973,14 +6983,17 @@ TclNRInvoke(
}
cmdPtr = Tcl_GetHashValue(hPtr);
- /* Avoid the exception-handling brain damage when numLevels == 0 . */
+ /*
+ * Avoid the exception-handling brain damage when numLevels == 0
+ */
+
iPtr->numLevels++;
Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
* Normal command resolution of objv[0] isn't going to find cmdPtr.
- * That's the whole point of **hidden** commands. So tell the
- * Eval core machinery not to even try (and risk finding something wrong).
+ * That's the whole point of **hidden** commands. So tell the Eval core
+ * machinery not to even try (and risk finding something wrong).
*/
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
@@ -8374,13 +8387,21 @@ TclDTraceInfo(
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
- /* no "proc" -> use "lambda" */
+
+ /*
+ * no "proc" -> use "lambda"
+ */
+
if (!args[2]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[2] = val ? TclGetString(val) : NULL;
}
k++;
- /* no "class" -> use "object" */
+
+ /*
+ * no "class" -> use "object"
+ */
+
if (!args[5]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[5] = val ? TclGetString(val) : NULL;
@@ -8734,8 +8755,10 @@ TclNRTailcallObjCmd(
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- /* The tailcall data is in a Tcl list: the first element is the
- * namespace, the rest the command to be tailcalled. */
+ /*
+ * The tailcall data is in a Tcl list: the first element is the
+ * namespace, the rest the command to be tailcalled.
+ */
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
listPtr = Tcl_NewListObj(objc, objv);
@@ -9186,6 +9209,75 @@ TclNREvalList(
/*
*----------------------------------------------------------------------
*
+ * CoroTypeObjCmd --
+ *
+ * Implementation of [::tcl::unsupported::corotype] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CoroTypeObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Command *cmdPtr;
+ CoroutineData *corPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the coroutine.
+ */
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
+ if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only get coroutine type of a coroutine", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objv[1]), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * An active coroutine is "active". Can't tell what it might do in the
+ * future.
+ */
+
+ corPtr = cmdPtr->objClientData;
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
+ return TCL_OK;
+ }
+
+ /*
+ * Inactive coroutines are classified by the (effective) command used to
+ * suspend them, which matters when you're injecting a probe.
+ */
+
+ switch (corPtr->nargs) {
+ case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
+ return TCL_OK;
+ case COROUTINE_ARGUMENTS_ARBITRARY:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
+ return TCL_OK;
+ default:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown coroutine type", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NRCoroInjectObjCmd --
*
* Implementation of [::tcl::unsupported::inject] command.
@@ -9416,9 +9508,12 @@ TclNRCoroutineObjCmd(
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
- /* ensure that the command is looked up in the correct namespace */
+ /*
+ * Ensure that the command is looked up in the correct namespace.
+ */
+
iPtr->lookupNsPtr = lookupNsPtr;
- Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+ Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
iPtr->numLevels--;
SAVE_CONTEXT(corPtr->running);
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 1f78d18..246c371 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -771,7 +771,10 @@ TclAppendBytesToByteArray(
"TclAppendBytesToByteArray");
}
if (len == 0) {
- /* Append zero bytes is a no-op. */
+ /*
+ * Append zero bytes is a no-op.
+ */
+
return;
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0440395..e9cc0f0 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -346,14 +346,14 @@ InitFoundation(
*/
Tcl_DStringInit(&buffer);
- for (i=0 ; defineCmds[i].name ; i++) {
+ for (i = 0 ; defineCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::define::");
Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
- for (i=0 ; objdefCmds[i].name ; i++) {
+ for (i = 0 ; objdefCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
@@ -373,10 +373,10 @@ InitFoundation(
* Basic method declarations for the core classes.
*/
- for (i=0 ; objMethods[i].name ; i++) {
+ for (i = 0 ; objMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
}
- for (i=0 ; clsMethods[i].name ; i++) {
+ for (i = 0 ; clsMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
}
@@ -388,7 +388,7 @@ InitFoundation(
TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
- namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
+ namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
@@ -667,10 +667,8 @@ AllocObject(
Tcl_ResetResult(interp);
}
-
configNamespace:
-
- ((Namespace *)oPtr->namespacePtr)->refCount++;
+ ((Namespace *) oPtr->namespacePtr)->refCount++;
/*
* Make the namespace know about the helper commands. This grants access
@@ -874,10 +872,14 @@ TclOODeleteDescendants(
if (clsPtr->mixinSubs.num > 0) {
while (clsPtr->mixinSubs.num > 0) {
- mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
- /* This condition also covers the case where mixinSubclassPtr ==
+ mixinSubclassPtr =
+ clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
+
+ /*
+ * This condition also covers the case where mixinSubclassPtr ==
* clsPtr
*/
+
if (!Deleted(mixinSubclassPtr->thisPtr)
&& !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
@@ -897,7 +899,7 @@ TclOODeleteDescendants(
if (clsPtr->subclasses.num > 0) {
while (clsPtr->subclasses.num > 0) {
- subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
+ subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
&& !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
@@ -918,7 +920,8 @@ TclOODeleteDescendants(
if (clsPtr->instances.num > 0) {
while (clsPtr->instances.num > 0) {
- instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
+ instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
+
/*
* This condition also covers the case where instancePtr == oPtr
*/
@@ -1119,8 +1122,8 @@ ObjectNamespaceDeleted(
if (Deleted(oPtr)) {
/*
- * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
- * guard could be removed.
+ * TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
+ * this guard could be removed.
*/
return;
@@ -1134,7 +1137,10 @@ ObjectNamespaceDeleted(
oPtr->flags |= OBJECT_DELETED;
- /* Let the dominoes fall */
+ /*
+ * Let the dominoes fall!
+ */
+
if (oPtr->classPtr) {
TclOODeleteDescendants(interp, oPtr);
}
@@ -1150,8 +1156,8 @@ ObjectNamespaceDeleted(
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
int result;
-
Tcl_InterpState state;
+
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
@@ -1170,12 +1176,12 @@ ObjectNamespaceDeleted(
/*
* Instruct everyone to no longer use any allocated fields of the object.
- * Also delete the command that refers to the object at this point (if
- * it still exists) because otherwise its pointer to the object
- * points into freed memory.
+ * Also delete the command that refers to the object at this point (if it
+ * still exists) because otherwise its pointer to the object points into
+ * freed memory.
*/
- if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) {
+ if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
@@ -1201,10 +1207,7 @@ ObjectNamespaceDeleted(
* methods on the object.
*/
- /*
- * TODO: Should this be protected with a * !IsRoot() condition?
- */
-
+ /* TODO: Should this be protected with a !IsRoot() condition? */
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
if (oPtr->mixins.num > 0) {
@@ -1765,7 +1768,6 @@ TclNRNewObjectInstance(
TclPushTailcallPoint(interp);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
-
Object *
TclNewObjectInstanceCommon(
@@ -1780,7 +1782,6 @@ TclNewObjectInstanceCommon(
const char *simpleName = NULL;
Namespace *nsPtr = NULL, *dummy;
Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- int isNew;
if (nameStr) {
TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
@@ -1790,21 +1791,14 @@ TclNewObjectInstanceCommon(
* Disallow creation of an object over an existing command.
*/
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
- if (!isNew) {
+ hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
+ if (hPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
-
- /*
- * We could make a hash entry! Don't actually want to do that here so
- * nuke it immediately because we'll create it properly soon.
- */
-
- Tcl_DeleteHashEntry(hPtr);
}
/*
@@ -1837,8 +1831,6 @@ TclNewObjectInstanceCommon(
return oPtr;
}
-
-
static int
FinalizeAlloc(
ClientData data[],
@@ -1974,7 +1966,11 @@ Tcl_CopyObjectInstance(
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
- /* For the reference just created in DUPLICATE */
+
+ /*
+ * For the reference just created in DUPLICATE.
+ */
+
AddRef(mixinPtr->thisPtr);
}
@@ -2012,6 +2008,7 @@ Tcl_CopyObjectInstance(
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
+
/*
* Copy the object's metadata.
*/
@@ -2075,9 +2072,11 @@ Tcl_CopyObjectInstance(
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
- /* For the new item in cls2Ptr->superclasses that memcpy just
- * created
+ /*
+ * For the new item in cls2Ptr->superclasses that memcpy just
+ * created.
*/
+
AddRef(superPtr->thisPtr);
}
@@ -2121,7 +2120,11 @@ Tcl_CopyObjectInstance(
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
- /* For the copy just created in DUPLICATE */
+
+ /*
+ * For the copy just created in DUPLICATE.
+ */
+
AddRef(mixinPtr->thisPtr);
}
@@ -2783,7 +2786,7 @@ Tcl_ObjectContextInvokeNext(
int savedSkip = contextPtr->skip;
int result;
- if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
@@ -2852,7 +2855,7 @@ TclNRObjectContextInvokeNext(
{
register CallContext *contextPtr = (CallContext *) context;
- if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index ace7fd7..c0d2e64 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -328,7 +328,7 @@ TclOOInvokeContext(
if (contextPtr->index == 0) {
int i;
- for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
AddRef(contextPtr->callPtr->chain[i].mPtr);
}
@@ -406,7 +406,7 @@ FinalizeMethodRefs(
CallContext *contextPtr = data[0];
int i;
- for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
}
return result;
@@ -641,7 +641,10 @@ SortMethodNames(
return i;
}
-/* Comparator for SortMethodNames */
+/*
+ * Comparator for SortMethodNames
+ */
+
static int
CmpStr(
const void *ptr1,
@@ -1004,7 +1007,7 @@ AddMethodToCallChain(
* any leading filters.
*/
- for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
+ for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
if (callPtr->chain[i].mPtr == mPtr &&
callPtr->chain[i].isFilter == (doneFilters != NULL)) {
/*
@@ -1016,8 +1019,8 @@ AddMethodToCallChain(
Class *declCls = callPtr->chain[i].filterDeclarer;
- for (; i+1<callPtr->numChain ; i++) {
- callPtr->chain[i] = callPtr->chain[i+1];
+ for (; i + 1 < callPtr->numChain ; i++) {
+ callPtr->chain[i] = callPtr->chain[i + 1];
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
@@ -1817,7 +1820,7 @@ TclOORenderCallChain(
*/
objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
- for (i=0 ; i<callPtr->numChain ; i++) {
+ for (i = 0 ; i < callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 65d6ea1..6a00018 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -50,6 +50,12 @@ struct DeclaredSlot {
resolver, NULL, NULL}}
/*
+ * A [string match] pattern used to determine if a method should be exported.
+ */
+
+#define PUBLIC_PATTERN "[a-z]*"
+
+/*
* Forward declarations.
*/
@@ -278,7 +284,7 @@ TclOOObjectSetFilters(
} else {
filtersList = ckrealloc(oPtr->filters.list, size);
}
- for (i=0 ; i<numFilters ; i++) {
+ for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
@@ -337,7 +343,7 @@ TclOOClassSetFilters(
} else {
filtersList = ckrealloc(classPtr->filters.list, size);
}
- for (i=0 ; i<numFilters ; i++) {
+ for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
@@ -400,7 +406,11 @@ TclOOObjectSetMixins(
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
- /* For the new copy created by memcpy */
+
+ /*
+ * For the new copy created by memcpy().
+ */
+
AddRef(mixinPtr->thisPtr);
}
}
@@ -452,7 +462,11 @@ TclOOClassSetMixins(
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
- /* For the new copy created by memcpy */
+
+ /*
+ * For the new copy created by memcpy.
+ */
+
AddRef(mixinPtr->thisPtr);
}
}
@@ -724,15 +738,16 @@ TclOOUnknownDefinition(
* Got one match, and only one match!
*/
- Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+ Tcl_Obj **newObjv =
+ TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
Tcl_IncrRefCount(newObjv[0]);
if (objc > 2) {
- memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+ memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
}
- result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
+ result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
TclStackFree(interp, newObjv);
return result;
@@ -1039,17 +1054,20 @@ MagicDefinitionInvoke(
obj2Ptr = Tcl_NewObj();
cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
if (cmd == NULL) {
- /* punt this case! */
+ /*
+ * Punt this case!
+ */
+
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
- result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
+ result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
TclResetRewriteEnsemble(interp, 1);
}
@@ -1685,7 +1703,7 @@ TclOODefineDeleteMethodObjCmd(
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
+ for (i = 1; i < objc; i++) {
/*
* Delete the method structure from the appropriate hash table.
*/
@@ -1811,7 +1829,7 @@ TclOODefineExportObjCmd(
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
+ for (i = 1; i < objc; i++) {
/*
* Exporting is done by adding the PUBLIC_METHOD flag to the method
* record. If there is no such method in this object or class (i.e.
@@ -1904,7 +1922,7 @@ TclOODefineForwardObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
@@ -1914,7 +1932,7 @@ TclOODefineForwardObjCmd(
* Create the method structure.
*/
- prefixObj = Tcl_NewListObj(objc-2, objv+2);
+ prefixObj = Tcl_NewListObj(objc - 2, objv + 2);
if (isInstanceForward) {
mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
prefixObj);
@@ -2002,7 +2020,7 @@ TclOODefineMethodObjCmd(
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
} else {
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
}
}
@@ -2124,7 +2142,7 @@ TclOODefineUnexportObjCmd(
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
+ for (i = 1; i < objc; i++) {
/*
* Unexporting is done by removing the PUBLIC_METHOD flag from the
* method record. If there is no such method in this object or class
@@ -2340,7 +2358,7 @@ ClassFilterSet(
int filterc;
Tcl_Obj **filterv;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
@@ -2424,7 +2442,7 @@ ClassMixinSet(
Tcl_Obj **mixinv;
Class **mixins;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
@@ -2445,7 +2463,7 @@ ClassMixinSet(
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
- for (i=0 ; i<mixinc ; i++) {
+ for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
@@ -2529,7 +2547,7 @@ ClassSuperSet(
Tcl_Obj **superv;
Class **superclasses, *superPtr;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"superclassList");
return TCL_ERROR;
@@ -2576,14 +2594,14 @@ ClassSuperSet(
superc = 1;
AddRef(superclasses[0]->thisPtr);
} else {
- for (i=0 ; i<superc ; i++) {
+ for (i = 0; i < superc; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
i--;
goto failedAfterAlloc;
}
- for (j=0 ; j<i ; j++) {
+ for (j = 0; j < i; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
@@ -2705,7 +2723,7 @@ ClassVarsSet(
Tcl_Obj **varv;
int i;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
@@ -2724,7 +2742,7 @@ ClassVarsSet(
return TCL_ERROR;
}
- for (i=0 ; i<varc ; i++) {
+ for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
@@ -2803,7 +2821,7 @@ ObjFilterSet(
int filterc;
Tcl_Obj **filterv;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
@@ -2877,7 +2895,7 @@ ObjMixinSet(
Class **mixins;
int i;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
@@ -2892,7 +2910,7 @@ ObjMixinSet(
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
- for (i=0 ; i<mixinc ; i++) {
+ for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
@@ -2967,7 +2985,7 @@ ObjVarsSet(
int varc, i;
Tcl_Obj **varv;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"variableList");
return TCL_ERROR;
@@ -2980,7 +2998,7 @@ ObjVarsSet(
return TCL_ERROR;
}
- for (i=0 ; i<varc ; i++) {
+ for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index f301ebc..5fe1370 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -971,8 +971,10 @@ AsyncHandlerProc(
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
- asyncPtr = asyncPtr->nextPtr) {
- if (asyncPtr->id == id) break;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) {
+ break;
+ }
}
Tcl_MutexUnlock(&asyncTestMutex);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 15c87b5..ea80320 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -310,8 +310,8 @@ TclCreateAbsoluteTimerHandler(
timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
/*
- * Add the event to the queue in the correct position
- * (ordered by event firing time).
+ * Add the event to the queue in the correct position (ordered by event
+ * firing time).
*/
for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
@@ -1013,8 +1013,8 @@ AfterDelay(
Tcl_GetTime(&now);
endTime = now;
- endTime.sec += (long)(ms/1000);
- endTime.usec += ((int)(ms%1000))*1000;
+ endTime.sec += (long)(ms / 1000);
+ endTime.usec += ((int)(ms % 1000)) * 1000;
if (endTime.usec >= 1000000) {
endTime.sec++;
endTime.usec -= 1000000;
@@ -1042,17 +1042,17 @@ AfterDelay(
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
- if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
- diff = 1;
- }
+ if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
+ diff = 1;
+ }
if (diff > 0) {
- Tcl_Sleep((int) diff);
- if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
- break;
- }
+ Tcl_Sleep((long) diff);
+ if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
+ break;
+ }
} else {
- break;
- }
+ break;
+ }
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 3580f94..ffb9eb9 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -792,6 +792,81 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
interp delete slave
set result
} -result {inject-executed}
+
+test coroutine-9.1 {coro type} {
+ coroutine demo eval {
+ yield
+ yield "PHASE 1"
+ yieldto string cat "PHASE 2"
+ ::tcl::unsupported::corotype [info coroutine]
+ }
+ list [demo] [::tcl::unsupported::corotype demo] \
+ [demo] [::tcl::unsupported::corotype demo] [demo]
+} {{PHASE 1} yield {PHASE 2} yieldto active}
+test coroutine-9.2 {coro type} -setup {
+ catch {rename nosuchcommand ""}
+} -returnCodes error -body {
+ ::tcl::unsupported::corotype nosuchcommand
+} -result {can only get coroutine type of a coroutine}
+test coroutine-9.3 {coro type} -returnCodes error -body {
+ proc notacoroutine {} {}
+ ::tcl::unsupported::corotype notacoroutine
+} -returnCodes error -cleanup {
+ rename notacoroutine {}
+} -result {can only get coroutine type of a coroutine}
+
+test coroutine-10.1 {coroutine general introspection} -setup {
+ set i [interp create]
+} -body {
+ $i eval {
+ # Make the introspection code
+ namespace path tcl::unsupported
+ proc probe {type var} {
+ upvar 1 $var v
+ set f [info frame]
+ incr f -1
+ set result [list $v [dict get [info frame $f] proc]]
+ if {$type eq "yield"} {
+ tailcall yield $result
+ } else {
+ tailcall yieldto string cat $result
+ }
+ }
+ proc pokecoro {c var} {
+ inject $c probe [corotype $c] $var
+ $c
+ }
+
+ # Coroutine implementations
+ proc cbody1 {} {
+ set val [info coroutine]
+ set accum {}
+ while {[set val [yield $val]] ne ""} {
+ lappend accum $val
+ set val ok
+ }
+ return $accum
+ }
+ proc cbody2 {} {
+ set val [info coroutine]
+ set accum {}
+ while {[llength [set val [yieldto string cat $val]]]} {
+ lappend accum {*}$val
+ set val ok
+ }
+ return $accum
+ }
+
+ # Make the coroutines
+ coroutine c1 cbody1
+ coroutine c2 cbody2
+ list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
+ [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
+ [c1] [c2]
+ }
+} -cleanup {
+ interp delete $i
+} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
# cleanup
unset lambda
diff --git a/tests/link.test b/tests/link.test
index 4c4cf99..51a3b65 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -26,6 +26,16 @@ foreach i {int real bool string} {
unset -nocomplain $i
}
+test link-0.1 {leak test} {testlink} {
+ interp create i
+ load {} Tcltest i
+ i eval {
+ testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
+ namespace delete ::
+ }
+ interp delete i
+} {}
+
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 3524a16..fa5f28e 100644..100755
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -680,7 +680,8 @@ NativeReadReparse(
HANDLE hFile;
DWORD returnedLength;
- hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING,
+ hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
+ OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
@@ -842,7 +843,7 @@ tclWinDebugPanic(
#endif
abort();
}
-
+
/*
*---------------------------------------------------------------------------
*
@@ -1450,11 +1451,16 @@ TclpGetUserHome(
if (domain == NULL) {
const char *ptr;
- /* no domain - firstly check it's the current user */
- if ( (ptr = TclpGetUserName(&ds)) != NULL
- && strcasecmp(name, ptr) == 0
- ) {
- /* try safest and fastest way to get current user home */
+ /*
+ * No domain. Firstly check it's the current user
+ */
+
+ ptr = TclpGetUserName(&ds);
+ if (ptr != NULL && strcasecmp(name, ptr) == 0) {
+ /*
+ * Try safest and fastest way to get current user home
+ */
+
ptr = TclGetEnv("HOME", &ds);
if (ptr != NULL) {
Tcl_JoinPath(1, &ptr, bufferPtr);
@@ -1475,18 +1481,28 @@ TclpGetUserHome(
wName = TclUtfToWCharDString(name, nameLen, &ds);
while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
/*
- * user does not exists - if domain was not specified,
- * try again using current domain.
+ * User does not exist; if domain was not specified, try again
+ * using current domain.
*/
+
rc = 1;
- if (domain != NULL) break;
- /* get current domain */
+ if (domain != NULL) {
+ break;
+ }
+
+ /*
+ * Get current domain
+ */
+
rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
- if (rc != 0) break;
+ if (rc != 0) {
+ break;
+ }
domain = INT2PTR(-1); /* repeat once */
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
+
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
size = lstrlenW(wHomeDir);
@@ -1496,15 +1512,22 @@ TclpGetUserHome(
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
+
GetProfilesDirectoryW(buf, &size);
TclWCharToUtfDString(buf, size-1, bufferPtr);
Tcl_DStringAppend(bufferPtr, "/", 1);
Tcl_DStringAppend(bufferPtr, name, nameLen);
}
result = Tcl_DStringValue(bufferPtr);
- /* be sure we return normalized path */
- for (i = 0; i < size; ++i){
- if (result[i] == '\\') result[i] = '/';
+
+ /*
+ * Be sure we return normalized path
+ */
+
+ for (i = 0; i < size; ++i) {
+ if (result[i] == '\\') {
+ result[i] = '/';
+ }
}
NetApiBufferFree((void *) uiPtr);
}
@@ -1592,48 +1615,72 @@ NativeAccess(
/*
* If it's not a directory (assume file), do several fast checks:
*/
+
if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
/*
* If the attributes say this is not writable at all. The file is a
* regular file (i.e., not a directory), then the file is not
- * writable, full stop. For directories, the read-only bit is
+ * writable, full stop. For directories, the read-only bit is
* (mostly) ignored by Windows, so we can't ascertain anything about
* directory access from the attrib data. However, if we have the
- * advanced 'getFileSecurityProc', then more robust ACL checks
- * will be done below.
+ * advanced 'getFileSecurityProc', then more robust ACL checks will be
+ * done below.
*/
+
if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
Tcl_SetErrno(EACCES);
return -1;
}
- /* If doesn't have the correct extension, it can't be executable */
+ /*
+ * If doesn't have the correct extension, it can't be executable
+ */
+
if ((mode & X_OK) && !NativeIsExec(nativePath)) {
Tcl_SetErrno(EACCES);
return -1;
}
- /* Special case for read/write/executable check on file */
+
+ /*
+ * Special case for read/write/executable check on file
+ */
+
if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
DWORD mask = 0;
HANDLE hFile;
- if (mode & R_OK) { mask |= GENERIC_READ; }
- if (mode & W_OK) { mask |= GENERIC_WRITE; }
- if (mode & X_OK) { mask |= GENERIC_EXECUTE; }
+
+ if (mode & R_OK) {
+ mask |= GENERIC_READ;
+ }
+ if (mode & W_OK) {
+ mask |= GENERIC_WRITE;
+ }
+ if (mode & X_OK) {
+ mask |= GENERIC_EXECUTE;
+ }
hFile = CreateFile(nativePath, mask,
- FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
- OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
+ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
+ NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
CloseHandle(hFile);
return 0;
}
- /* fast exit if access was denied */
+
+ /*
+ * Fast exit if access was denied
+ */
+
if (GetLastError() == ERROR_ACCESS_DENIED) {
Tcl_SetErrno(EACCES);
return -1;
}
}
- /* We cannnot verify the access fast, check it below using security info. */
+
+ /*
+ * We cannnot verify the access fast, check it below using security
+ * info.
+ */
}
/*
@@ -2008,13 +2055,12 @@ NativeStat(
* '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.
+ * 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,
@@ -2032,7 +2078,11 @@ NativeStat(
Tcl_SetErrno(ENOENT);
return -1;
}
- /* Mock up the expected structure */
+
+ /*
+ * Mock up the expected structure
+ */
+
memset(&data, 0, sizeof(data));
statPtr->st_atime = 0;
statPtr->st_mtime = 0;
@@ -2315,7 +2365,7 @@ TclpGetNativeCwd(
}
if (clientData != NULL) {
- if (wcscmp((const WCHAR*)clientData, buffer) == 0) {
+ if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
return clientData;
}
}
@@ -2543,10 +2593,12 @@ TclpObjNormalizePath(
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
} else if (nextCheckpoint == 0) {
- /* Path starts with a drive designation
- * that's not actually on the system.
- * We still must normalize up past the
- * first separator. [Bug 3603434] */
+ /*
+ * Path starts with a drive designation that's not
+ * actually on the system. We still must normalize up
+ * past the first separator. [Bug 3603434]
+ */
+
currentPathEndPosition++;
}
}
@@ -2561,11 +2613,10 @@ TclpObjNormalizePath(
*/
/*
- * Check for symlinks, except at last component of path (we
- * don't follow final symlinks). Also a drive (C:/) for
- * example, may sometimes have the reparse flag set for some
- * reason I don't understand. We therefore don't perform this
- * check for drives.
+ * Check for symlinks, except at last component of path (we don't
+ * follow final symlinks). Also a drive (C:/) for example, may
+ * sometimes have the reparse flag set for some reason I don't
+ * understand. We therefore don't perform this check for drives.
*/
if (cur != 0 && !isDrive &&
@@ -2574,8 +2625,8 @@ TclpObjNormalizePath(
if (to != NULL) {
/*
- * Read the reparse point ok. Now, reparse points need
- * not be normalized, otherwise we could use:
+ * Read the reparse point ok. Now, reparse points need not
+ * be normalized, otherwise we could use:
*
* Tcl_GetStringFromObj(to, &pathLen);
* nextCheckpoint = pathLen;
@@ -2615,9 +2666,9 @@ TclpObjNormalizePath(
#ifndef TclNORM_LONG_PATH
/*
- * Now we convert the tail of the current path to its 'long
- * form', and append it to 'dsNorm' which holds the current
- * normalized path
+ * Now we convert the tail of the current path to its 'long form',
+ * and append it to 'dsNorm' which holds the current normalized
+ * path
*/
if (isDrive) {
@@ -2646,10 +2697,10 @@ TclpObjNormalizePath(
int dotLen = currentPathEndPosition-lastValidPathEnd;
/*
- * Path is just dots. We shouldn't really ever see a
- * path like that. However, to be nice we at least
- * don't mangle the path - we just add the dots as a
- * path segment and continue.
+ * Path is just dots. We shouldn't really ever see a path
+ * like that. However, to be nice we at least don't mangle
+ * the path - we just add the dots as a path segment and
+ * continue.
*/
Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
@@ -2667,8 +2718,7 @@ TclpObjNormalizePath(
handle = FindFirstFileW((WCHAR *) nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
/*
- * This is usually the '/' in 'c:/' at end of
- * string.
+ * This is usually the '/' in 'c:/' at end of string.
*/
Tcl_DStringAppend(&dsNorm, (const char *) L"/",
@@ -2698,8 +2748,8 @@ TclpObjNormalizePath(
}
/*
- * If we get here, we've got past one directory delimiter, so
- * we know it is no longer a drive.
+ * If we get here, we've got past one directory delimiter, so we
+ * know it is no longer a drive.
*/
isDrive = 0;
@@ -2993,7 +3043,11 @@ TclNativeCreateNativeRep(
if (validPathPtr == NULL) {
return NULL;
}
- /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */
+
+ /*
+ * refCount of validPathPtr was already incremented in
+ * Tcl_FSGetTranslatedPath
+ */
} else {
/*
* Make sure the normalized path is set.
@@ -3003,72 +3057,100 @@ TclNativeCreateNativeRep(
if (validPathPtr == NULL) {
return NULL;
}
- /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */
+
+ /*
+ * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
+ * so incr refCount here
+ */
+
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
- if (strlen(str)!=(size_t)len) {
- /* String contains NUL-bytes. This is invalid. */
+ if (strlen(str) != (size_t) len) {
+ /*
+ * String contains NUL-bytes. This is invalid.
+ */
+
goto done;
}
- /* For a reserved device, strip a possible postfix ':' */
+
+ /*
+ * For a reserved device, strip a possible postfix ':'
+ */
+
len = WinIsReserved(str);
if (len == 0) {
- /* Let MultiByteToWideChar check for other invalid sequences, like
- * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */
+ /*
+ * Let MultiByteToWideChar check for other invalid sequences, like
+ * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames
+ */
+
len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
if (len==0) {
goto done;
}
}
- /* Overallocate 6 chars, making some room for extended paths */
- wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) );
+
+ /*
+ * Overallocate 6 chars, making some room for extended paths
+ */
+
+ wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
goto done;
}
- MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1);
+ MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
+ len + 1);
+
/*
- ** If path starts with "//?/" or "\\?\" (extended path), translate
- ** any slashes to backslashes but leave the '?' intact
- */
- if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
- && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {
+ * If path starts with "//?/" or "\\?\" (extended path), translate any
+ * slashes to backslashes but leave the '?' intact
+ */
+
+ if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
+ && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) {
wp[0] = wp[1] = wp[3] = '\\';
str += 4;
wp += 4;
}
+
/*
- ** If there is no "\\?\" prefix but there is a drive or UNC
- ** path prefix and the path is larger than MAX_PATH chars,
- ** no Win32 API function can handle that unless it is
- ** prefixed with the extended path prefix. See:
- ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
- **/
- if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))
- && str[1]==':') {
- if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) {
- memmove(wp+4, wp, len*sizeof(WCHAR));
- memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR));
+ * If there is no "\\?\" prefix but there is a drive or UNC path prefix
+ * and the path is larger than MAX_PATH chars, no Win32 API function can
+ * handle that unless it is prefixed with the extended path prefix. See:
+ * <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
+ */
+
+ if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z'))
+ && str[1] == ':') {
+ if (wp == nativePathPtr && len > MAX_PATH
+ && (str[2] == '\\' || str[2] == '/')) {
+ memmove(wp + 4, wp, len * sizeof(WCHAR));
+ memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR));
wp += 4;
}
+
/*
- ** If (remainder of) path starts with "<drive>:",
- ** leave the ':' intact.
+ * If (remainder of) path starts with "<drive>:", leave the ':'
+ * intact.
*/
+
wp += 2;
- } else if (wp==nativePathPtr && len>MAX_PATH
- && (str[0]=='\\' || str[0]=='/')
- && (str[1]=='\\' || str[1]=='/') && str[2]!='?') {
- memmove(wp+6, wp, len*sizeof(WCHAR));
- memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR));
+ } else if (wp == nativePathPtr && len > MAX_PATH
+ && (str[0] == '\\' || str[0] == '/')
+ && (str[1] == '\\' || str[1] == '/') && str[2] != '?') {
+ memmove(wp + 6, wp, len * sizeof(WCHAR));
+ memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR));
wp += 7;
}
+
/*
- ** In the remainder of the path, translate invalid characters to
- ** characters in the Unicode private use area.
- */
+ * In the remainder of the path, translate invalid characters to
+ * characters in the Unicode private use area.
+ */
+
while (*wp != '\0') {
if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
*wp |= 0xF000;
@@ -3079,7 +3161,6 @@ TclNativeCreateNativeRep(
}
done:
-
TclDecrRefCount(validPathPtr);
return nativePathPtr;
}
@@ -3205,21 +3286,28 @@ TclWinFileOwned(
native = Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
- OWNER_SECURITY_INFORMATION, &ownerSid,
- NULL, NULL, NULL, &secd) != ERROR_SUCCESS) {
- /* Either not a file, or we do not have access to it in which
- case we are in all likelihood not the owner */
+ 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.
+ * 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 */
+ /*
+ * Find out how big the buffer needs to be.
+ */
+
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
@@ -3231,15 +3319,20 @@ TclWinFileOwned(
CloseHandle(token);
}
- /* Free allocations and be done */
- if (secd)
+ /*
+ * Free allocations and be done.
+ */
+
+ if (secd) {
LocalFree(secd); /* Also frees ownerSid */
- if (buf)
+ }
+ if (buf) {
ckfree(buf);
+ }
return (owned != 0); /* Convert non-0 to 1 */
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index ee1e9ba..a001816 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -124,8 +124,7 @@ typedef struct PipeInfo {
* write. Set to 0 if no error has been
* detected. This word is shared with the
* writer thread so access must be
- * synchronized with the writable object.
- */
+ * synchronized with the writable object. */
char *writeBuf; /* Current background output buffer. Access is
* synchronized with the writable object. */
int writeBufLen; /* Size of write buffer. Access is
@@ -218,7 +217,7 @@ static const Tcl_ChannelType pipeChannelType = {
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
- NULL /* truncate */
+ NULL /* truncate */
};
/*
@@ -1428,9 +1427,12 @@ ApplicationType(
static const char *
BuildCmdLineBypassBS(
const char *current,
- const char **bspos
-) {
- /* mark first backslash possition */
+ const char **bspos)
+{
+ /*
+ * Mark first backslash position.
+ */
+
if (!*bspos) {
*bspos = current;
}
@@ -1445,14 +1447,14 @@ QuoteCmdLineBackslash(
Tcl_DString *dsPtr,
const char *start,
const char *current,
- const char *bspos
-) {
+ const char *bspos)
+{
if (!bspos) {
- if (current > start) { /* part before current (special) */
+ if (current > start) { /* part before current (special) */
Tcl_DStringAppend(dsPtr, start, (int) (current - start));
}
} else {
- if (bspos > start) { /* part before first backslash */
+ if (bspos > start) { /* part before first backslash */
Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
}
while (bspos++ < current) { /* each backslash twice */
@@ -1467,38 +1469,59 @@ QuoteCmdLinePart(
const char *start,
const char *special,
const char *specMetaChars,
- const char **bspos
-) {
+ const char **bspos)
+{
if (!*bspos) {
- /* rest before special (before quote) */
+ /*
+ * Rest before special (before quote).
+ */
+
QuoteCmdLineBackslash(dsPtr, start, special, NULL);
start = special;
} else {
- /* rest before first backslash and backslashes into new quoted block */
+ /*
+ * Rest before first backslash and backslashes into new quoted block.
+ */
+
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
start = *bspos;
}
+
/*
- * escape all special chars enclosed in quotes like `"..."`, note that here we
- * don't must escape `\` (with `\`), because it's outside of the main quotes,
- * so `\` remains `\`, but important - not at end of part, because results as
- * before the quote, so `%\%\` should be escaped as `"%\%"\\`).
+ * escape all special chars enclosed in quotes like `"..."`, note that
+ * here we don't must escape `\` (with `\`), because it's outside of the
+ * main quotes, so `\` remains `\`, but important - not at end of part,
+ * because results as before the quote, so `%\%\` should be escaped as
+ * `"%\%"\\`).
*/
+
TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
do {
*bspos = NULL;
special++;
if (*special == '\\') {
- /* bypass backslashes (and mark first backslash possition)*/
+ /*
+ * Bypass backslashes (and mark first backslash position).
+ */
+
special = BuildCmdLineBypassBS(special, bspos);
- if (*special == '\0') break;
+ if (*special == '\0') {
+ break;
+ }
}
} while (*special && strchr(specMetaChars, *special));
if (!*bspos) {
- /* unescaped rest before quote */
+ /*
+ * Unescaped rest before quote.
+ */
+
QuoteCmdLineBackslash(dsPtr, start, special, NULL);
} else {
- /* unescaped rest before first backslash (rather belongs to the main block) */
+ /*
+ * Unescaped rest before first backslash (rather belongs to the main
+ * block).
+ */
+
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
}
TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
@@ -1517,13 +1540,14 @@ BuildCommandLine(
const char *arg, *start, *special, *bspos;
int quote = 0, i;
Tcl_DString ds;
-
- /* characters to enclose in quotes if unpaired quote flag set */
static const char specMetaChars[] = "&|^<>!()%";
- /* character to enclose in quotes in any case (regardless unpaired-flag) */
+ /* Characters to enclose in quotes if unpaired
+ * quote flag set. */
static const char specMetaChars2[] = "%";
-
- /* Quote flags:
+ /* Character to enclose in quotes in any case
+ * (regardless of unpaired-flag). */
+ /*
+ * Quote flags:
* CL_ESCAPE - escape argument;
* CL_QUOTE - enclose in quotes;
* CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
@@ -1555,30 +1579,31 @@ BuildCommandLine(
quote = CL_QUOTE;
} else {
for (start = arg;
- *start != '\0' &&
- (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
- start++
- ) {
- if (*start & 0x80) continue;
+ *start != '\0' &&
+ (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
+ start++) {
+ if (*start & 0x80) {
+ continue;
+ }
if (TclIsSpaceProc(*start)) {
- quote |= CL_QUOTE; /* quote only */
- if (bspos) { /* if backslash found - escape & quote */
+ quote |= CL_QUOTE; /* quote only */
+ if (bspos) { /* if backslash found, escape & quote */
quote |= CL_ESCAPE;
break;
}
continue;
}
if (strchr(specMetaChars, *start)) {
- quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */
+ quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */
break;
}
if (*start == '"') {
- quote |= CL_ESCAPE; /* escape only */
+ quote |= CL_ESCAPE; /* escape only */
continue;
}
if (*start == '\\') {
bspos = start;
- if (quote & CL_QUOTE) { /* if quote - escape & quote */
+ if (quote & CL_QUOTE) { /* if quote, escape & quote */
quote |= CL_ESCAPE;
break;
}
@@ -1588,56 +1613,116 @@ BuildCommandLine(
bspos = NULL;
}
if (quote & CL_QUOTE) {
- /* start of argument (main opening quote-char) */
+ /*
+ * Start of argument (main opening quote-char).
+ */
+
TclDStringAppendLiteral(&ds, "\"");
}
if (!(quote & CL_ESCAPE)) {
- /* nothing to escape */
+ /*
+ * Nothing to escape.
+ */
+
Tcl_DStringAppend(&ds, arg, -1);
} else {
start = arg;
for (special = arg; *special != '\0'; ) {
- /* position of `\` is important before quote or at end (equal `\"` because quoted) */
+ /*
+ * Position of `\` is important before quote or at end (equal
+ * `\"` because quoted).
+ */
+
if (*special == '\\') {
- /* bypass backslashes (and mark first backslash possition)*/
+ /*
+ * Bypass backslashes (and mark first backslash position)
+ */
+
special = BuildCmdLineBypassBS(special, &bspos);
- if (*special == '\0') break;
+ if (*special == '\0') {
+ break;
+ }
}
/* ["] */
if (*special == '"') {
- quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */
- /* add part before (and escape backslashes before quote) */
+ /*
+ * Invert the unpaired flag - observe unpaired quotes
+ */
+
+ quote ^= CL_UNPAIRED;
+
+ /*
+ * Add part before (and escape backslashes before quote).
+ */
+
QuoteCmdLineBackslash(&ds, start, special, bspos);
bspos = NULL;
- /* escape using backslash */
+
+ /*
+ * Escape using backslash
+ */
+
TclDStringAppendLiteral(&ds, "\\\"");
start = ++special;
continue;
}
- /* unpaired (escaped) quote causes special handling on meta-chars */
+
+ /*
+ * Unpaired (escaped) quote causes special handling on
+ * meta-chars
+ */
+
if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
- special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos);
- /* start to current or first backslash */
+ special = QuoteCmdLinePart(&ds, start, special,
+ specMetaChars, &bspos);
+
+ /*
+ * Start to current or first backslash
+ */
+
start = !bspos ? special : bspos;
continue;
}
- /* special case for % - should be enclosed always (paired also) */
+
+ /*
+ * Special case for % - should be enclosed always (paired
+ * also)
+ */
+
if (strchr(specMetaChars2, *special)) {
- special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos);
- /* start to current or first backslash */
+ special = QuoteCmdLinePart(&ds, start, special,
+ specMetaChars2, &bspos);
+
+ /*
+ * Start to current or first backslash.
+ */
+
start = !bspos ? special : bspos;
continue;
}
- /* other not special (and not meta) character */
- bspos = NULL; /* reset last backslash possition (not interesting) */
+
+ /*
+ * Other not special (and not meta) character
+ */
+
+ bspos = NULL; /* reset last backslash position (not
+ * interesting) */
special++;
}
- /* rest of argument (and escape backslashes before closing main quote) */
+
+ /*
+ * Rest of argument (and escape backslashes before closing main
+ * quote)
+ */
+
QuoteCmdLineBackslash(&ds, start, special,
- (quote & CL_QUOTE) ? bspos : NULL);
+ (quote & CL_QUOTE) ? bspos : NULL);
}
if (quote & CL_QUOTE) {
- /* end of argument (main closing quote-char) */
+ /*
+ * End of argument (main closing quote-char)
+ */
+
TclDStringAppendLiteral(&ds, "\"");
}
}
@@ -2175,8 +2260,9 @@ PipeOutputProc(
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
- timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI)
- || TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
+ timeout = ((infoPtr->flags & PIPE_ASYNC)
+ || !TclPipeThreadIsAlive(&infoPtr->writeTI)
+ || TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
/*
* The writer thread is blocked waiting for a write to complete and
@@ -2362,6 +2448,7 @@ PipeWatchProc(
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
+
if (!oldMask) {
infoPtr->nextPtr = tsdPtr->firstPipePtr;
tsdPtr->firstPipePtr = infoPtr;
@@ -2831,7 +2918,7 @@ static DWORD WINAPI
PipeReaderThread(
LPVOID arg)
{
- TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
+ TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
HANDLE handle = NULL;
DWORD count, err;
@@ -2842,13 +2929,14 @@ PipeReaderThread(
* Wait for the main thread to signal before attempting to wait on the
* pipe becoming readable.
*/
+
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
- infoPtr = (PipeInfo *)pipeTI->clientData;
+ infoPtr = (PipeInfo *) pipeTI->clientData;
handle = ((WinFile *) infoPtr->readFile)->handle;
}
@@ -3194,7 +3282,7 @@ TclPipeThreadCreateTI(
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = ckalloc(sizeof(TclPipeThreadInfo));
-#endif
+#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
pipeTI->clientData = clientData;
@@ -3233,40 +3321,64 @@ TclPipeThreadWaitForSignal(
}
wakeEvent = pipeTI->evWakeUp;
+
/*
* Wait for the main thread to signal before attempting to do the work.
*/
- /* reset work state of thread (idle/waiting) */
- if ((state = InterlockedCompareExchange(&pipeTI->state,
- PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) {
- /* end of work, check the owner of structure */
+ /*
+ * Reset work state of thread (idle/waiting)
+ */
+
+ state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE,
+ PTI_STATE_WORK);
+ if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
+ /*
+ * End of work, check the owner of structure.
+ */
+
goto end;
}
- /* entering wait */
- waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
- if (waitResult != WAIT_OBJECT_0) {
+ /*
+ * Entering wait
+ */
+ waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
+ if (waitResult != WAIT_OBJECT_0) {
/*
* The control event was not signaled, so end of work (unexpected
* behaviour, main thread can be dead?).
*/
+
goto end;
}
- /* try to set work state of thread */
- if ((state = InterlockedCompareExchange(&pipeTI->state,
- PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) {
- /* end of work */
+ /*
+ * Try to set work state of thread
+ */
+
+ state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK,
+ PTI_STATE_IDLE);
+ if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
+ /*
+ * End of work
+ */
+
goto end;
}
- /* signaled to work */
+ /*
+ * Signaled to work.
+ */
+
return 1;
-end:
- /* end of work, check the owner of the TI structure */
+ end:
+ /*
+ * End of work, check the owner of the TI structure.
+ */
+
if (state != PTI_STATE_STOP) {
*pipeTIPtr = NULL;
} else {
@@ -3296,7 +3408,8 @@ end:
int
TclPipeThreadStopSignal(
- TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent)
+ TclPipeThreadInfo **pipeTIPtr,
+ HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
HANDLE evControl;
@@ -3307,28 +3420,27 @@ TclPipeThreadStopSignal(
}
evControl = pipeTI->evControl;
pipeTI->evWakeUp = wakeEvent;
- switch (
- (state = InterlockedCompareExchange(&pipeTI->state,
- PTI_STATE_STOP, PTI_STATE_IDLE))
- ) {
-
- case PTI_STATE_IDLE:
-
- /* Thread was idle/waiting, notify it goes teardown */
- SetEvent(evControl);
-
- *pipeTIPtr = NULL;
-
- case PTI_STATE_DOWN:
+ state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
+ PTI_STATE_IDLE);
+ switch (state) {
+ case PTI_STATE_IDLE:
+ /*
+ * Thread was idle/waiting, notify it goes teardown
+ */
+ SetEvent(evControl);
+ *pipeTIPtr = NULL;
+ case PTI_STATE_DOWN:
return 1;
- default:
- /*
- * Thread works currently, we should try to end it, own the TI structure
- * (because of possible sharing the joint structures with thread)
- */
- InterlockedExchange(&pipeTI->state, PTI_STATE_END);
+ default:
+ /*
+ * Thread works currently, we should try to end it, own the TI
+ * structure (because of possible sharing the joint structures with
+ * thread)
+ */
+
+ InterlockedExchange(&pipeTI->state, PTI_STATE_END);
break;
}
@@ -3371,46 +3483,63 @@ TclPipeThreadStop(
pipeTI = *pipeTIPtr;
evControl = pipeTI->evControl;
pipeTI->evWakeUp = NULL;
+
/*
* Try to sane stop the pipe worker, corresponding its current state
*/
- switch (
- (state = InterlockedCompareExchange(&pipeTI->state,
- PTI_STATE_STOP, PTI_STATE_IDLE))
- ) {
- case PTI_STATE_IDLE:
+ state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
+ PTI_STATE_IDLE);
+ switch (state) {
+ case PTI_STATE_IDLE:
+ /*
+ * Thread was idle/waiting, notify it goes teardown
+ */
- /* Thread was idle/waiting, notify it goes teardown */
- SetEvent(evControl);
+ SetEvent(evControl);
- /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */
- pipeTI = NULL;
+ /*
+ * We don't need to wait for it at all, thread frees himself (owns the
+ * TI structure)
+ */
+
+ pipeTI = NULL;
break;
- case PTI_STATE_STOP:
- /* already stopped, thread frees himself (owns the TI structure) */
- pipeTI = NULL;
+ case PTI_STATE_STOP:
+ /*
+ * Already stopped, thread frees himself (owns the TI structure)
+ */
+
+ pipeTI = NULL;
break;
- case PTI_STATE_DOWN:
- /* Thread already down (?), do nothing */
+ case PTI_STATE_DOWN:
+ /*
+ * Thread already down (?), do nothing
+ */
- /* we don't need to wait for it, but we should free pipeTI */
- hThread = NULL;
+ /*
+ * We don't need to wait for it, but we should free pipeTI
+ */
+ hThread = NULL;
break;
/* case PTI_STATE_WORK: */
- default:
+ default:
+ /*
+ * Thread works currently, we should try to end it, own the TI
+ * structure (because of possible sharing the joint structures with
+ * thread)
+ */
+
+ state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END,
+ PTI_STATE_WORK);
+ if (state == PTI_STATE_DOWN) {
/*
- * Thread works currently, we should try to end it, own the TI structure
- * (because of possible sharing the joint structures with thread)
+ * We don't need to wait for it, but we should free pipeTI
*/
- if ((state = InterlockedCompareExchange(&pipeTI->state,
- PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN
- ) {
- /* we don't need to wait for it, but we should free pipeTI */
- hThread = NULL;
- };
+ hThread = NULL;
+ }
break;
}
@@ -3425,8 +3554,8 @@ TclPipeThreadStop(
GetExitCodeThread(hThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
-
int inExit = (TclInExit() || TclInThreadExit());
+
/*
* Set the stop event so that if the pipe thread is blocked
* somewhere, it may hereafter sane exit cleanly.
@@ -3437,59 +3566,69 @@ TclPipeThreadStop(
/*
* Cancel all sync-IO of this thread (may be blocked there).
*/
+
if (tclWinProcs.cancelSynchronousIo) {
tclWinProcs.cancelSynchronousIo(hThread);
}
/*
- * Wait at most 20 milliseconds for the reader thread to
- * close (regarding TIP#398-fast-exit).
+ * Wait at most 20 milliseconds for the reader thread to close
+ * (regarding TIP#398-fast-exit).
*/
- /* if we want TIP#398-fast-exit. */
- if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
+ /*
+ * If we want TIP#398-fast-exit.
+ */
+ if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
/*
- * The thread must be blocked waiting for the pipe to
- * become readable in ReadFile(). There isn't a clean way
- * to exit the thread from this condition. We should
- * terminate the child process instead to get the reader
- * thread to fall out of ReadFile with a FALSE. (below) is
- * not the correct way to do this, but will stay here
- * until a better solution is found.
+ * The thread must be blocked waiting for the pipe to become
+ * readable in ReadFile(). There isn't a clean way to exit the
+ * thread from this condition. We should terminate the child
+ * process instead to get the reader thread to fall out of
+ * ReadFile with a FALSE. (below) is not the correct way to do
+ * this, but will stay here until a better solution is found.
*
- * Note that we need to guard against terminating the
- * thread while it is in the middle of Tcl_ThreadAlert
- * because it won't be able to release the notifier lock.
+ * Note that we need to guard against terminating the thread
+ * while it is in the middle of Tcl_ThreadAlert because it
+ * won't be able to release the notifier lock.
*
- * Also note that terminating threads during their initialization or teardown phase
- * may result in ntdll.dll's LoaderLock to remain locked indefinitely.
- * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock.
- * LdrpInitializeThread() is executed within new threads to perform
- * initialization and to execute DllMain() of all loaded dlls.
- * As a result, all new threads are deadlocked in their initialization phase and never execute,
- * even though CreateThread() reports successful thread creation.
- * This results in a very weird process-wide behavior, which is extremely hard to debug.
+ * Also note that terminating threads during their
+ * initialization or teardown phase may result in ntdll.dll's
+ * LoaderLock to remain locked indefinitely. This causes
+ * ntdll.dll's LdrpInitializeThread() to deadlock trying to
+ * acquire LoaderLock. LdrpInitializeThread() is executed
+ * within new threads to perform initialization and to execute
+ * DllMain() of all loaded dlls. As a result, all new threads
+ * are deadlocked in their initialization phase and never
+ * execute, even though CreateThread() reports successful
+ * thread creation. This results in a very weird process-wide
+ * behavior, which is extremely hard to debug.
*
* THREADS SHOULD NEVER BE TERMINATED. Period.
*
- * But for now, check if thread is exiting, and if so, let it die peacefully.
+ * But for now, check if thread is exiting, and if so, let it
+ * die peacefully.
*
- * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's).
+ * Also don't terminate if in exit (otherwise deadlocked in
+ * ntdll.dll's).
*/
- if ( pipeTI->state != PTI_STATE_DOWN
- && WaitForSingleObject(hThread,
- inExit ? 50 : 5000) != WAIT_OBJECT_0
- ) {
+ if (pipeTI->state != PTI_STATE_DOWN
+ && WaitForSingleObject(hThread,
+ inExit ? 50 : 5000) != WAIT_OBJECT_0) {
/* BUG: this leaks memory */
if (inExit || !TerminateThread(hThread, 0)) {
- /* in exit or terminate fails, just give thread a chance to exit */
+ /*
+ * in exit or terminate fails, just give thread a
+ * chance to exit
+ */
+
if (InterlockedExchange(&pipeTI->state,
PTI_STATE_STOP) != PTI_STATE_DOWN) {
pipeTI = NULL;
}
- };
+ }
}
}
}
@@ -3501,11 +3640,11 @@ TclPipeThreadStop(
SetEvent(pipeTI->evWakeUp);
}
CloseHandle(pipeTI->evControl);
-# ifndef _PTI_USE_CKALLOC
+#ifndef _PTI_USE_CKALLOC
free(pipeTI);
-# else
+#else
ckfree(pipeTI);
-# endif
+#endif /* !_PTI_USE_CKALLOC */
}
}
@@ -3534,28 +3673,30 @@ TclPipeThreadExit(
{
LONG state;
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
+
/*
* If state of thread was set to stop (exactly), we can sane free its info
* structure, otherwise it is shared with main thread, so main thread will
* own it.
*/
+
if (!pipeTI) {
return;
}
*pipeTIPtr = NULL;
- if ((state = InterlockedExchange(&pipeTI->state,
- PTI_STATE_DOWN)) == PTI_STATE_STOP) {
+ state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
+ if (state == PTI_STATE_STOP) {
CloseHandle(pipeTI->evControl);
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
-# ifndef _PTI_USE_CKALLOC
+#ifndef _PTI_USE_CKALLOC
free(pipeTI);
-# else
+#else
ckfree(pipeTI);
/* be sure all subsystems used are finalized */
Tcl_FinalizeThread();
-# endif
+#endif /* !_PTI_USE_CKALLOC */
}
}