From 0710d7d9550bdc462fbab7f3368db75c780d8f1a Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 27 Apr 2019 17:56:49 +0000 Subject: Implement 383 as two commands for two scenarios: injection and probing --- generic/tclBasic.c | 227 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 223 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 84c87d0..5d13e8d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -171,9 +171,14 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; -static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_ObjCmdProc NRInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; +static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; +static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; +static Tcl_NRPostProc InjectHandler; +static Tcl_NRPostProc InjectHandlerPostCall; + MODULE_SCOPE const TclStubs tclStubs; /* @@ -242,6 +247,8 @@ static const CmdInfo builtInCmds[] = { {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, + {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, + {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, @@ -974,7 +981,7 @@ Tcl_CreateInterp(void) cmdPtr->compileProc = &TclCompileAssembleCmd; Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, - NRCoroInjectObjCmd, NULL, NULL); + NRInjectObjCmd, NULL, NULL); /* Export unsupported commands */ nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); @@ -9186,7 +9193,219 @@ TclNREvalList( /* *---------------------------------------------------------------------- * - * NRCoroInjectObjCmd -- + * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd -- + * + * Implementation of [coroinject] and [coroprobe] commands. + * + *---------------------------------------------------------------------- + */ + +static int +TclNRCoroInjectObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + int numLevels, unused; + int *stackLevel = &unused; + + /* + * Usage more or less like tailcall: + * coroinject coroName cmd ?arg1 arg2 ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + + corPtr = cmdPtr->objClientData; + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + return TCL_ERROR; + } + + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. + */ + + iPtr->execEnvPtr = corPtr->eePtr; + TclNRAddCallback(interp, InjectHandler, corPtr, + Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); + iPtr->execEnvPtr = savedEEPtr; + + return TCL_OK; +} + +static int +TclNRCoroProbeObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + int numLevels, unused; + int *stackLevel = &unused; + + /* + * Usage more or less like tailcall: + * coroprobe coroName cmd ?arg1 arg2 ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a probe command into a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + + corPtr = cmdPtr->objClientData; + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a probe command into a suspended coroutine", + -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + return TCL_ERROR; + } + + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. + */ + + iPtr->execEnvPtr = corPtr->eePtr; + TclNRAddCallback(interp, InjectHandler, corPtr, + Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr); + iPtr->execEnvPtr = savedEEPtr; + + /* + * Now we transfer control to the coroutine to run our probe. TRICKY STUFF + * copied from the [yield] implementation. + * + * Push the callback to restore the caller's context on yield back. + */ + + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, + NULL, NULL, NULL); + + /* + * Record the stackLevel at which the resume is happening, then swap + * the interp's environment to make it suitable to run this coroutine. + */ + + corPtr->stackLevel = stackLevel; + numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = iPtr->numLevels; + + /* + * Do the actual stack swap. + */ + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); + iPtr->execEnvPtr = corPtr->eePtr; + iPtr->numLevels += numLevels; + return TCL_OK; +} + +static int +InjectHandler( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Tcl_Obj *listPtr = data[1]; + int nargs = PTR2INT(data[2]); + ClientData isProbe = data[3]; + int objc; + Tcl_Obj **objv; + + if (!isProbe) { + if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj("yield", -1)); + } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj("yieldto", -1)); + } else { + /* + * I don't think this is reachable... + */ + + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + } + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); + } + Tcl_IncrRefCount(listPtr); + TclMarkTailcall(interp); + TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, + INT2PTR(nargs), isProbe); + TclListObjGetElements(NULL, listPtr, &objc, &objv); + return TclNREvalObjv(interp, objc, objv, 0, NULL); +} + +static int +InjectHandlerPostCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Tcl_Obj *listPtr = data[1]; + int nargs = PTR2INT(data[2]); + ClientData isProbe = data[3]; + int numLevels; + + Tcl_DecrRefCount(listPtr); + if (isProbe) { + /* + * If we were doing a probe, splice ourselves back out of the stack + * cleanly here. General injection should instead just look after + * itself. + */ + + corPtr->nargs = nargs; + corPtr->stackLevel = NULL; + numLevels = iPtr->numLevels; + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + iPtr->execEnvPtr = corPtr->callerEEPtr; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NRInjectObjCmd -- * * Implementation of [::tcl::unsupported::inject] command. * @@ -9194,7 +9413,7 @@ TclNREvalList( */ static int -NRCoroInjectObjCmd( +NRInjectObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, -- cgit v0.12 From cd37605bd0cea4fecc9ae7a51c8c361568523357 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 27 Apr 2019 18:08:53 +0000 Subject: Remove unused variables --- generic/tclBasic.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5d13e8d..321253d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9210,8 +9210,6 @@ TclNRCoroInjectObjCmd( Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; /* * Usage more or less like tailcall: -- cgit v0.12 From 5bb0cef260b0c771b1ff8619ff8b46e4bfe8307f Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Apr 2019 07:11:39 +0000 Subject: Documenting, both internally and in manpage --- doc/coroutine.n | 106 ++++++++++++++++++++++++++++++++++++++++++++++----- generic/tclBasic.c | 109 ++++++++++++++++++++++++++++++++++++----------------- 2 files changed, 171 insertions(+), 44 deletions(-) diff --git a/doc/coroutine.n b/doc/coroutine.n index 52775ef..3c1cf6c 100644 --- a/doc/coroutine.n +++ b/doc/coroutine.n @@ -14,10 +14,13 @@ coroutine, yield, yieldto \- Create and produce values from coroutines .nf \fBcoroutine \fIname command\fR ?\fIarg...\fR? \fByield\fR ?\fIvalue\fR? -.VS TIP396 \fByieldto\fR \fIcommand\fR ?\fIarg...\fR? \fIname\fR ?\fIvalue...\fR? -.VE TIP396 +.sp +.VS "8.7, TIP383" +\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR? +\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR? +.VE "8.7, TIP383" .fi .BE .SH DESCRIPTION @@ -39,7 +42,6 @@ the context to be suspended. If the coroutine context never yields and instead returns conventionally, the result of the \fBcoroutine\fR command will be the result of the evaluation of the context. .PP -.VS TIP396 The coroutine may also suspend its execution by use of the \fByieldto\fR command, which instead of returning, cedes execution to some command called \fIcommand\fR (resolved in the context of the coroutine) and to which \fIany @@ -58,11 +60,10 @@ with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR command, like this: .PP .CS -proc yieldm {value} { - \fByieldto\fR return -level 0 $value +proc yieldMultiple {value} { + tailcall \fByieldto\fR string cat $value } .CE -.VE TIP396 .PP The coroutine can also be deleted by destroying the command \fIname\fR, and the name of the current coroutine can be retrieved by using @@ -75,6 +76,51 @@ At the point when \fIcommand\fR is called, the current namespace will be the global namespace and there will be no stack frames above it (in the sense of \fBupvar\fR and \fBuplevel\fR). However, which command to call will be determined in the namespace that the \fBcoroutine\fR command was called from. +.PP +.VS "8.7, TIP383" +A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d) +may have its state inspected (or modified) at that point by using +\fBcoroprobe\fR to run a command at the point where the coroutine is at. The +command takes the name of the coroutine to run the command in, \fIcoroName\fR, +and the name of a command (any any arguments it requires) to immediately run +at that point. The result of that command is the result of the \fBcoroprobe\fR +command, and the gross state of the coroutine remains the same afterwards +(i.e., the coroutine is still expecting the results of a \fByield\fR or +\fByieldto\fR as before) though variables may have been changed. +.PP +Similarly, the \fBcoroinject\fR command may be used to place a command to be +run inside a suspended coroutine (when it is resumed) to process arguments, +with quite a bit of similarity to \fBcoroprobe\fR. However, with +\fBcoroinject\fR there are several key differences: +.VE "8.7, TIP383" +.IP \(bu +.VS "8.7, TIP383" +The coroutine is not immediately resumed after the injection has been done. A +consequence of this is that multiple injections may be done before the +coroutine is resumed. There injected commands are performed in \fIreverse +order of definition\fR (that is, they are internally stored on a stack). +.VE "8.7, TIP383" +.IP \(bu +.VS "8.7, TIP383" +An additional two arguments are appended to the list of arguments to be run +(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements). +The first is the name of the command that suspended the coroutine (\fByield\fR +or \fByieldto\fR), and the second is the argument (or list of arguments, in +the case of \fByieldto\fR) that is the current resumption value. +.VE "8.7, TIP383" +.IP \(bu +.VS "8.7, TIP383" +The result of the injected command is used as the result of the \fByield\fR or +\fByieldto\fR that caused the coroutine to become suspended. Where there are +multiple injected commands, the result of one becomes the resumption value +processed by the next. +.PP +The injection is a one-off. It is not retained once it has been executed. It +may \fByield\fR or \fByieldto\fR as part of its execution. +.PP +Note that running coroutines may be neither probed nor injected; the +operations may only be applied to +.VE "8.7, TIP383" .SH EXAMPLES .PP This example shows a coroutine that will produce an infinite sequence of @@ -138,7 +184,6 @@ for {set i 1} {$i <= 20} {incr i} { } .CE .PP -.VS TIP396 This example shows how a value can be passed around a group of three coroutines that yield to each other: .PP @@ -150,14 +195,57 @@ proc juggler {name target {value ""}} { while {$value ne ""} { puts "$name : $value" set value [string range $value 0 end-1] - lassign [\fByieldto\fR $target $value] value + lassign [\fByieldto\fR \fI$target\fR $value] value } } \fBcoroutine\fR j1 juggler Larry [ \fBcoroutine\fR j2 juggler Curly [ \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!" .CE -.VE TIP396 +.PP +.VS "8.7, TIP383" +This example shows a simple coroutine that collects non-empty values and +returns a list of them when not given an argument. It also shows how we can +look inside the coroutine to find out what it is doing, and how we can modify +the input on a one-off basis. +.PP +.CS +proc collectorImpl {} { + set me [info coroutine] + set accumulator {} + for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} { + lappend accumulator $val + } + return $accumulator +} + +\fBcoroutine\fR collect collectorImpl +\fIcollect\fR 123 +\fIcollect\fR "abc def" +\fIcollect\fR 456 + +puts [\fBcoroprobe \fIcollect\fR set accumulator] +# ==> 123 {abc def} 456 + +\fIcollect\fR "pqr" + +\fBcoroinject \fIcollect\fR apply {{type value} { + puts "Received '$value' at a $type in [info coroutine]" + return [string toupper $value] +}} + +\fIcollect\fR rst +# ==> Received 'rst' at a yield in ::collect +\fIcollect\fR xyz + +puts [\fIcollect\fR] +# ==> 123 {abc def} 456 pqr RST xyz +.CE +.PP +This example shows a simple coroutine that collects non-empty values and +returns a list of them when not given an argument. It also shows how we can +look inside the coroutine to find out what it is doing. +.VE "8.7, TIP383" .SS "DETAILED SEMANTICS" .PP This example demonstrates that coroutines start from the global namespace, and diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 321253d..02e3129 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9200,6 +9200,27 @@ TclNREvalList( *---------------------------------------------------------------------- */ +static inline CoroutineData * +GetCoroutineFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + const char *errMsg) +{ + /* + * How to get a coroutine from its handle. + */ + + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); + + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objPtr), NULL); + return NULL; + } + return cmdPtr->objClientData; +} + static int TclNRCoroInjectObjCmd( ClientData clientData, @@ -9207,7 +9228,6 @@ TclNRCoroInjectObjCmd( int objc, Tcl_Obj *const objv[]) { - Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; @@ -9221,16 +9241,11 @@ TclNRCoroInjectObjCmd( return TCL_ERROR; } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); + corPtr = GetCoroutineFromObj(interp, objv[1], + "can only inject a command into a coroutine"); + if (!corPtr) { return TCL_ERROR; } - - corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a suspended coroutine", -1)); @@ -9258,7 +9273,6 @@ TclNRCoroProbeObjCmd( int objc, Tcl_Obj *const objv[]) { - Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; int numLevels, unused; @@ -9274,16 +9288,11 @@ TclNRCoroProbeObjCmd( return TCL_ERROR; } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a probe command into a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); + corPtr = GetCoroutineFromObj(interp, objv[1], + "can only inject a probe command into a coroutine"); + if (!corPtr) { return TCL_ERROR; } - - corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a probe command into a suspended coroutine", @@ -9303,8 +9312,8 @@ TclNRCoroProbeObjCmd( iPtr->execEnvPtr = savedEEPtr; /* - * Now we transfer control to the coroutine to run our probe. TRICKY STUFF - * copied from the [yield] implementation. + * Now we immediately transfer control to the coroutine to run our probe. + * TRICKY STUFF copied from the [yield] implementation. * * Push the callback to restore the caller's context on yield back. */ @@ -9332,6 +9341,27 @@ TclNRCoroProbeObjCmd( iPtr->numLevels += numLevels; return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * InjectHandler, InjectHandlerPostProc -- + * + * Part of the implementation of [coroinject] and [coroprobe]. These are + * run inside the context of the coroutine being injected/probed into. + * + * InjectHandler runs a script (possibly adding arguments) in the context + * of the coroutine. The script is specified as a one-shot list (with + * reference count equal to 1) in data[1]. This function also arranges + * for InjectHandlerPostProc to be the part that runs after the script + * completes. + * + * InjectHandlerPostProc cleans up after InjectHandler (deleting the + * list) and, for the [coroprobe] command *only*, yields back to the + * caller context (i.e., where [coroprobe] was run). + *s + *---------------------------------------------------------------------- + */ static int InjectHandler( @@ -9347,6 +9377,10 @@ InjectHandler( Tcl_Obj **objv; if (!isProbe) { + /* + * If this is [coroinject], add the extra arguments now. + */ + if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) { Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("yield", -1)); @@ -9362,6 +9396,11 @@ InjectHandler( } Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); } + + /* + * Call the user's script; we're in the right place. + */ + Tcl_IncrRefCount(listPtr); TclMarkTailcall(interp); TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, @@ -9382,14 +9421,20 @@ InjectHandlerPostCall( ClientData isProbe = data[3]; int numLevels; + /* + * Delete the command words for what we just executed. + */ + Tcl_DecrRefCount(listPtr); - if (isProbe) { - /* - * If we were doing a probe, splice ourselves back out of the stack - * cleanly here. General injection should instead just look after - * itself. - */ + /* + * If we were doing a probe, splice ourselves back out of the stack + * cleanly here. General injection should instead just look after itself. + * + * Code from guts of [yield] implementation. + */ + + if (isProbe) { corPtr->nargs = nargs; corPtr->stackLevel = NULL; numLevels = iPtr->numLevels; @@ -9417,7 +9462,6 @@ NRInjectObjCmd( int objc, Tcl_Obj *const objv[]) { - Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; @@ -9431,16 +9475,11 @@ NRInjectObjCmd( return TCL_ERROR; } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); + corPtr = GetCoroutineFromObj(interp, objv[1], + "can only inject a command into a coroutine"); + if (!corPtr) { return TCL_ERROR; } - - corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a suspended coroutine", -1)); -- cgit v0.12 From 7f8f3b946d5b7418549021a8dab4fb8d761a1b79 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Apr 2019 16:01:57 +0000 Subject: Basic tests --- tests/coroutine.test | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 3580f94..0d95495 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -792,6 +792,113 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp delete slave set result } -result {inject-executed} + +test coroutine-9.1 {coroprobe with yield} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2 {}} +test coroutine-9.2 {coroprobe with yieldto} -body { + coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} + list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2 {{a b} {c d}}} +test coroutine-9.3 {coroprobe errors} -setup { + catch {rename demo {}} +} -body { + coroprobe demo set i +} -returnCodes error -result {can only inject a probe command into a coroutine} +test coroutine-9.4 {coroprobe errors} -body { + proc demo {} { foreach i {1 2} yield } + coroprobe demo set i +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {can only inject a probe command into a coroutine} +test coroutine-9.5 {coroprobe errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} +test coroutine-9.6 {coroprobe errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe demo +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} +test coroutine-9.7 {coroprobe errors in probe command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe demo set +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "set varName ?newValue?"} +test coroutine-9.8 {coroprobe errors in probe command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + list [catch {coroprobe demo set}] [demo] [coroprobe demo set i] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2} + +test coroutine-10.1 {coroinject with yield} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} yield }} + coroinject demo apply {{op val} {lappend ::result $op $val}} + list $result [demo x] [demo y] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {{yield x} y} {yield x}} +test coroutine-10.2 {coroinject stacking} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} yield }} + coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}} + coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}} + list $result [demo x] [demo y] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {x y} {yield x B yield x A}} +test coroutine-10.3 {coroinject with yieldto} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} + coroinject demo apply {{op val} {lappend ::result $op $val;return $val}} + list $result [demo x mp] [demo y le] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}} +test coroutine-10.4 {coroinject errors} -setup { + catch {rename demo {}} +} -body { + coroinject demo set i +} -returnCodes error -result {can only inject a command into a coroutine} +test coroutine-10.5 {coroinject errors} -body { + proc demo {} { foreach i {1 2} yield } + coroinject demo set i +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {can only inject a command into a coroutine} +test coroutine-10.6 {coroinject errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} +test coroutine-10.7 {coroinject errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject demo +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} +test coroutine-10.8 {coroinject errors in injected command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject demo apply {args {error "ERR: $args"}} + list [catch demo msg] $msg [catch demo msg] $msg +} -cleanup { + catch {rename demo {}} +} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} # cleanup unset lambda -- cgit v0.12 From 3db1b8bbad948c57135d221bf3e57e661a3b8dcc Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Apr 2019 16:17:05 +0000 Subject: Advanced feature tests --- tests/coroutine.test | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 0d95495..fe46c8b 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -840,6 +840,22 @@ test coroutine-9.8 {coroprobe errors in probe command} -body { } -cleanup { catch {rename demo {}} } -result {1 {} 2} +test coroutine-9.9 {coroprobe: advanced features} -setup { + set i [interp create] +} -body { + $i eval { + coroutine demo apply {{} { + set f [info level],[info frame] + foreach i {1 2} yield + }} + coroprobe demo apply {{} { + upvar 1 f f + list [info coroutine] [info level] [info frame] $f + }} + } +} -cleanup { + interp delete $i +} -result {::demo 2 3 1,2} test coroutine-10.1 {coroinject with yield} -setup { set result {} @@ -899,6 +915,28 @@ test coroutine-10.8 {coroinject errors in injected command} -body { } -cleanup { catch {rename demo {}} } -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} +test coroutine-10.9 {coroinject: advanced features} -setup { + set i [interp create] +} -body { + $i eval { + coroutine demo apply {{} { + set l [info level] + set f [info frame] + lmap i {1 2} yield + }} + coroinject demo apply {{arg op val} { + global result + upvar 1 f f l l + lappend result [info coroutine] $arg $op $val + lappend result [info level] $l [info frame] $f + lappend result [yield $arg] + return [string toupper $val] + }} grill + list [demo ABC] [demo pqr] [demo def] $result + } +} -cleanup { + interp delete $i +} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} # cleanup unset lambda -- cgit v0.12 From c0c8a1cbd0b9842eb58c4bad983e58138506306b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 30 Apr 2019 07:44:20 +0000 Subject: Starting to implement a temporary directory creator. --- unix/tclUnixFCmd.c | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e963589..0089d91 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2273,6 +2273,84 @@ DefaultTempDir(void) return TCL_TEMPORARY_FILE_DIRECTORY; } +/* + *---------------------------------------------------------------------- + * + * TclpCreateTemporaryDirectory -- + * + * Creates a temporary directory, possibly based on the supplied bits and + * pieces of template supplied in the arguments. + * + * Results: + * An object (refcount 0) containing the name of the newly-created + * directory, or NULL on failure. + * + * Side effects: + * Accesses the native filesystem. Makes a directory. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpCreateTemporaryDirectory( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +{ + Tcl_DString template, tmp; + const char *string; + Tcl_Obj *resultingNameObj; + +#define DEFAULT_TEMP_DIR_PREFIX "tcl" + + /* + * Build the template in writable memory from the user-supplied pieces and + * some defaults. + */ + + if (dirObj) { + string = TclGetString(dirObj); + Tcl_UtfToExternalDString(NULL, string, dirObj->length, &template); + } else { + Tcl_DStringInit(&template); + Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ + } + + TclDStringAppendLiteral(&template, "/"); + + if (basenameObj) { + string = TclGetString(basenameObj); + if (basenameObj->length) { + Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); + TclDStringAppendDString(&template, &tmp); + Tcl_DStringFree(&tmp); + } else { + TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); + } + } else { + TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); + } + + TclDStringAppendLiteral(&template, ".XXXXXX"); + + /* + * Make the temporary directory. + */ + + if (mkdtemp(Tcl_DStringValue(&template)) == NULL) { + Tcl_DStringFree(&template); + return NULL; + } + + /* + * The template has been updated. Tell the caller what it was. + */ + + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template), + Tcl_DStringLength(&template), &tmp); + Tcl_DStringFree(&template); + return TclDStringToObj(&tmp); +} + #if defined(__CYGWIN__) static void -- cgit v0.12 From 688e4e85455890e8a7bdf3435bf88206ce97f9ea Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 30 Apr 2019 13:31:59 +0000 Subject: Windows implementation of TclpCreateTemporaryDirectory --- unix/tclUnixFCmd.c | 2 +- win/tclWinFCmd.c | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 102 insertions(+), 1 deletion(-) diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 0089d91..80e7ed0 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2330,7 +2330,7 @@ TclpCreateTemporaryDirectory( TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); } - TclDStringAppendLiteral(&template, ".XXXXXX"); + TclDStringAppendLiteral(&template, "_XXXXXX"); /* * Make the temporary directory. diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 14bb252..c626ece 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1957,6 +1957,107 @@ TclpObjListVolumes(void) } /* + *---------------------------------------------------------------------- + * + * TclpCreateTemporaryDirectory -- + * + * Creates a temporary directory, possibly based on the supplied bits and + * pieces of template supplied in the arguments. + * + * Results: + * An object (refcount 0) containing the name of the newly-created + * directory, or NULL on failure. + * + * Side effects: + * Accesses the native filesystem. Makes a directory. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpCreateTemporaryDirectory( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +{ + Tcl_DString base, name; /* Contains WCHARs */ + int baseLen; + + /* + * Build the path in writable memory from the user-supplied pieces and + * some defaults. First, the parent temporary directory. + */ + + if (dirObj) { + Tcl_GetString(dirObj); + if (dirObj->length < 1) { + goto useSystemTemp; + } + Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base); + if (dirObj->bytes[dirObj->length - 1] != '/') { + TclUtfToWCharDString("/", -1, &base); + } + } else { + useSystemTemp: + WCHAR tempBuf[MAX_PATH + 1]; + DWORD len = GetTempPathW(MAX_PATH, tempBuf); + + Tcl_DStringInit(&base); + Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR)); + } + + /* + * Next, the base of the directory name. + */ + +#define DEFAULT_TEMP_DIR_PREFIX "tcl" +#define SUFFIX_LENGTH 8 + + if (basenameObj) { + Tcl_WinUtfToTChar(Tcl_GetString(basenameObj), -1, &name); + TclDStringAppendDString(&base, &name); + Tcl_DStringFree(&name); + } else { + TclUtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base); + } + TclUtfToWCharDString("_", -1, &base); + + /* + * Now we keep on trying random suffixes until we get one that works. Note + * that SUFFIX_LENGTH is longer than on Unix because we expect to be not + * on a case-sensitive filesystem. + */ + + baseLen = Tcl_DStringLength(&base); + do { + char tempbuf[SUFFIX_LENGTH + 1]; + int i; + static const char randChars[] = + "QWERTYUIOPASDFGHJKLZXCVBNM1234567890"; + static const int numRandChars = sizeof(randChars) - 1; + + /* + * Put a random suffix on the end. + */ + + tempbuf[SUFFIX_LENGTH] = '\0'; + for (i = 0 ; i < SUFFIX_LENGTH; i++) { + tempbuf[i] = randChars[(int) (rand() * numRandChars)]; + } + Tcl_DStringSetLength(&base, baseLen); + TclUtfToWCharDString(tempbuf, -1, &base); + } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)); + + /* + * We actually made the directory, so we're done! Report what we made back + * as a (clean) Tcl_Obj. + */ + + Tcl_WinTCharToUtf((LPCWSTR) Tcl_DStringValue(&base), -1, &name); + Tcl_DStringFree(&base); + return TclDStringToObj(&name); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From ae1d2d2d40e05b234f974ec40e5f073f10107b42 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 30 Apr 2019 13:35:53 +0000 Subject: Export API --- generic/tclInt.decls | 6 ++++++ generic/tclIntDecls.h | 6 ++++++ generic/tclStubInit.c | 1 + unix/tclUnixFCmd.c | 1 - 4 files changed, 13 insertions(+), 1 deletion(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 106b4e9..3870f3d 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1028,6 +1028,12 @@ declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } + +# TIP 431: temporary directory creation function +declare 258 { + Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +} ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index eddbcb3..56abe77 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -653,6 +653,9 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); +/* 258 */ +EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj); typedef struct TclIntStubs { int magic; @@ -916,6 +919,7 @@ typedef struct TclIntStubs { int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1359,6 +1363,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclpCreateTemporaryDirectory \ + (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2eb2259..ec6e735 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -749,6 +749,7 @@ static const TclIntStubs tclIntStubs = { TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticPackage, /* 257 */ + TclpCreateTemporaryDirectory, /* 258 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 80e7ed0..861ff66 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2298,7 +2298,6 @@ TclpCreateTemporaryDirectory( { Tcl_DString template, tmp; const char *string; - Tcl_Obj *resultingNameObj; #define DEFAULT_TEMP_DIR_PREFIX "tcl" -- cgit v0.12 From fd0444bf94a1f315cb724abf0374890fb9b7e310 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 30 Apr 2019 18:31:47 +0000 Subject: Implementation of [file tempdir]; hand-tested on OSX... --- generic/tclCmdAH.c | 1 + generic/tclFCmd.c | 147 ++++++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclInt.h | 1 + unix/tclUnixFCmd.c | 4 +- win/tclWinFCmd.c | 27 +++++++--- 5 files changed, 172 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1811c5c..dd98ef3 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1093,6 +1093,7 @@ TclInitFileCmd( {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index a4dded2..8ef0456 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1345,7 +1345,7 @@ TclFileReadLinkCmd( /* *--------------------------------------------------------------------------- * - * TclFileTemporaryCmd + * TclFileTemporaryCmd -- * * This function implements the "tempfile" subcommand of the "file" * command. @@ -1505,6 +1505,151 @@ TclFileTemporaryCmd( } /* + *--------------------------------------------------------------------------- + * + * TclFileTempDirCmd -- + * + * This function implements the "tempdir" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary directory. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileTempDirCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirNameObj; /* Object that will contain the directory + * name. */ + Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?template?"); + return TCL_ERROR; + } + + if (objc > 1) { + int length; + Tcl_Obj *templateObj = objv[1]; + const char *string = TclGetStringFromObj(templateObj, &length); + const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it, and only gives a base name if there's at least one + * character after the last directory separator. + */ + + if (strchr(string, '/') == NULL + && (!onWindows || strchr(string, '\\') == NULL)) { + /* + * No directory separator, so just assume we have a file name. + * This is a bit wrong on Windows where we could have problems + * with disk name prefixes... but those are much less common in + * naked form so we just pass through and let the OS figure it out + * instead. + */ + + nameBaseObj = templateObj; + Tcl_IncrRefCount(nameBaseObj); + } else if (string[length-1] != '/' + && (!onWindows || string[length-1] != '\\')) { + /* + * If the template has a non-terminal directory separator, split + * into dirname and tail. + */ + + baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); + nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL); + } else { + /* + * Otherwise, there must be a terminal directory separator, so + * just the directory is given. + */ + + baseDirObj = templateObj; + Tcl_IncrRefCount(baseDirObj); + } + + /* + * Only allow creation of temporary directories in the native + * filesystem since they are frequently used for integration with + * external tools or system libraries. + */ + + if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj) + != &tclNativeFilesystem) { + TclDecrRefCount(baseDirObj); + baseDirObj = NULL; + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (baseDirObj && !TclGetString(baseDirObj)[0]) { + TclDecrRefCount(baseDirObj); + baseDirObj = NULL; + } + if (nameBaseObj && !TclGetString(nameBaseObj)[0]) { + TclDecrRefCount(nameBaseObj); + nameBaseObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (baseDirObj) { + TclDecrRefCount(baseDirObj); + } + if (nameBaseObj) { + TclDecrRefCount(nameBaseObj); + } + + /* + * Deal with results. + */ + + if (dirNameObj == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create temporary directory: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirNameObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index 3db1264..9a2ef85 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2967,6 +2967,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 861ff66..3e1a5c2 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2314,7 +2314,9 @@ TclpCreateTemporaryDirectory( Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ } - TclDStringAppendLiteral(&template, "/"); + if (Tcl_DStringValue(&template)[Tcl_DStringLength(&template) - 1] != '/') { + TclDStringAppendLiteral(&template, "/"); + } if (basenameObj) { string = TclGetString(basenameObj); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index c626ece..a08d54a 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1981,6 +1981,7 @@ TclpCreateTemporaryDirectory( { Tcl_DString base, name; /* Contains WCHARs */ int baseLen; + DWORD error; /* * Build the path in writable memory from the user-supplied pieces and @@ -1993,8 +1994,8 @@ TclpCreateTemporaryDirectory( goto useSystemTemp; } Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base); - if (dirObj->bytes[dirObj->length - 1] != '/') { - TclUtfToWCharDString("/", -1, &base); + if (dirObj->bytes[dirObj->length - 1] != '\\') { + TclUtfToWCharDString("\\", -1, &base); } } else { useSystemTemp: @@ -2022,9 +2023,10 @@ TclpCreateTemporaryDirectory( TclUtfToWCharDString("_", -1, &base); /* - * Now we keep on trying random suffixes until we get one that works. Note - * that SUFFIX_LENGTH is longer than on Unix because we expect to be not - * on a case-sensitive filesystem. + * Now we keep on trying random suffixes until we get one that works + * (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that + * SUFFIX_LENGTH is longer than on Unix because we expect to be not on a + * case-sensitive filesystem. */ baseLen = Tcl_DStringLength(&base); @@ -2039,13 +2041,26 @@ TclpCreateTemporaryDirectory( * Put a random suffix on the end. */ + error = ERROR_SUCCESS; tempbuf[SUFFIX_LENGTH] = '\0'; for (i = 0 ; i < SUFFIX_LENGTH; i++) { tempbuf[i] = randChars[(int) (rand() * numRandChars)]; } Tcl_DStringSetLength(&base, baseLen); TclUtfToWCharDString(tempbuf, -1, &base); - } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)); + } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL) + && (error = GetLastError()) == ERROR_ALREADY_EXISTS); + + /* + * Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and + * ERROR_ACCESS_DENIED. + */ + + if (error != ERROR_SUCCESS) { + TclWinConvertError(error); + Tcl_DStringFree(&base); + return NULL; + } /* * We actually made the directory, so we're done! Report what we made back -- cgit v0.12 From 6937b4c6707f892f964f153b2512891695a00b01 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 30 Apr 2019 20:18:11 +0000 Subject: Document it --- doc/file.n | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/doc/file.n b/doc/file.n index ad35dd5..0929204 100644 --- a/doc/file.n +++ b/doc/file.n @@ -433,6 +433,36 @@ If \fIname\fR contains no separators then returns \fIname\fR. So, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. .TP +\fBfile tempdir\fR ?\fItemplate\fR? +'\" TIP #210 +.VS "8.7, TIP 431" +Creates a temporary directory (guaranteed to be newly created and writable by +the current script) and returns its name. If \fItemplate\fR is given, it +specifies one of or both of the directory to contain the temporary directory, +and the base part of the directory name; it is considered to have the location +of the directory if there is a directory separator in the name, and the base +part is everything after the last directory separator (if non-empty). +The default containing directory is determined by system-specific operations, +and the default base name prefix is +.QW \fBtcl\fR . +.RS +.PP +The following output is typical and illustrative; the actual output will vary +between platforms: +.PP +.CS +% \fBfile tempdir\fR +/var/tmp/tcl_u0kuy5 + % \fBfile tempdir\fR /tmp/myapp +/tmp/myapp_8o7r9L +% \fBfile tempdir\fR /tmp/ +/tmp/tcl_1mOJHD +% \fBfile tempdir\fR myapp +/var/tmp/myapp_0ihS0n +.CE +.RE +.VE "8.7, TIP 431" +.TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? '\" TIP #210 .VS 8.6 -- cgit v0.12 From cedf26696f0576981f44118918709716b5f5c7f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 May 2019 18:36:30 +0000 Subject: Tests --- generic/tclBasic.c | 1 + tests/cmdAH.test | 44 ++++++++++++++++++++++++++++++++++++++++++-- tests/interp.test | 2 +- 3 files changed, 44 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 84c87d0..4db275d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -365,6 +365,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { {"file", "size"}, {"file", "stat"}, {"file", "tail"}, + {"file", "tempdir"}, {"file", "tempfile"}, {"file", "type"}, {"file", "volumes"}, diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 88c0367..3184747 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -235,7 +235,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1526,7 +1526,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} @@ -1658,6 +1658,46 @@ test cmdAH-32.6 {file tempfile - templates} -body { } -constraints {unix nonPortable} -cleanup { catch {file delete $name} } -result ok + +test cmdAH-33.1 {file tempdir} -body { + file tempdir a b +} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"} +test cmdAH-33.2 {file tempdir} -body { + set d [file tempdir] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {tcl_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.3 {file tempdir} -body { + set d [file tempdir gorp] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {gorp_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.4 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file tempdir $base/] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.5 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file tempdir $base/gorp] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} diff --git a/tests/interp.test b/tests/interp.test index 29e3b2d..76ac01f 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} foreach i [interp slaves] { interp delete $i -- cgit v0.12 From 6902811461c2a7091cc7b076cfad37eeb155fdf3 Mon Sep 17 00:00:00 2001 From: fvogel Date: Mon, 13 May 2019 04:00:48 +0000 Subject: Let branch compile with MSVC 2008 --- win/tclWinFCmd.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index a08d54a..57ffa53 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1982,6 +1982,8 @@ TclpCreateTemporaryDirectory( Tcl_DString base, name; /* Contains WCHARs */ int baseLen; DWORD error; + WCHAR tempBuf[MAX_PATH + 1]; + DWORD len = GetTempPathW(MAX_PATH, tempBuf); /* * Build the path in writable memory from the user-supplied pieces and @@ -1999,9 +2001,6 @@ TclpCreateTemporaryDirectory( } } else { useSystemTemp: - WCHAR tempBuf[MAX_PATH + 1]; - DWORD len = GetTempPathW(MAX_PATH, tempBuf); - Tcl_DStringInit(&base); Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR)); } -- cgit v0.12 From 6b6e030ea49677db8df33c856429465459e58f9a Mon Sep 17 00:00:00 2001 From: fvogel Date: Mon, 13 May 2019 09:54:49 +0000 Subject: Fix crashing bug in tempdir name creation --- win/tclWinFCmd.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 57ffa53..2531ba6 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -2043,7 +2043,7 @@ TclpCreateTemporaryDirectory( error = ERROR_SUCCESS; tempbuf[SUFFIX_LENGTH] = '\0'; for (i = 0 ; i < SUFFIX_LENGTH; i++) { - tempbuf[i] = randChars[(int) (rand() * numRandChars)]; + tempbuf[i] = randChars[(int) (rand() % numRandChars)]; } Tcl_DStringSetLength(&base, baseLen); TclUtfToWCharDString(tempbuf, -1, &base); -- cgit v0.12 From 0f34d49b76e87e5f454a9b468e981bc71f43907c Mon Sep 17 00:00:00 2001 From: fvogel Date: Mon, 13 May 2019 17:56:36 +0000 Subject: Fix new tests cmdAH-33.[45] by making them pass on Windows --- tests/cmdAH.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3184747..789e77a 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1681,7 +1681,7 @@ test cmdAH-33.4 {file tempdir} -setup { file mkdir $base } -body { set pre [glob -nocomplain -directory $base *] - set d [file tempdir $base/] + set d [file normalize [file tempdir $base/]] list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ $pre [glob -nocomplain -directory $d *] } -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup { @@ -1692,7 +1692,7 @@ test cmdAH-33.5 {file tempdir} -setup { file mkdir $base } -body { set pre [glob -nocomplain -directory $base *] - set d [file tempdir $base/gorp] + set d [file normalize [file tempdir $base/gorp]] list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ $pre [glob -nocomplain -directory $d *] } -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { -- cgit v0.12 From cbd3fd20bd2ade1a59cde97cfa4e2b112f88445a Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 17 May 2019 08:09:29 +0000 Subject: Add test for what happens when the directory in the template doesn't exist; doc it too. --- doc/file.n | 13 +++++++------ tests/cmdAH.test | 16 ++++++++++++++++ 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/doc/file.n b/doc/file.n index 0929204..554da39 100644 --- a/doc/file.n +++ b/doc/file.n @@ -438,12 +438,13 @@ return \fBb\fR. .VS "8.7, TIP 431" Creates a temporary directory (guaranteed to be newly created and writable by the current script) and returns its name. If \fItemplate\fR is given, it -specifies one of or both of the directory to contain the temporary directory, -and the base part of the directory name; it is considered to have the location -of the directory if there is a directory separator in the name, and the base -part is everything after the last directory separator (if non-empty). -The default containing directory is determined by system-specific operations, -and the default base name prefix is +specifies one of or both of the existing directory (on a filesystem controlled +by the operating system) to contain the temporary directory, and the base part +of the directory name; it is considered to have the location of the directory +if there is a directory separator in the name, and the base part is everything +after the last directory separator (if non-empty). The default containing +directory is determined by system-specific operations, and the default base +name prefix is .QW \fBtcl\fR . .RS .PP diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 789e77a..f8ab361 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1698,6 +1698,22 @@ test cmdAH-33.5 {file tempdir} -setup { } -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { catch {file delete -force $base} } +test cmdAH-33.6 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/ +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} +test cmdAH-33.7 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/foobar +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} -- cgit v0.12 From cfff0de87eebaee43b86d95f8d726adaf1291cb4 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 17 May 2019 08:13:32 +0000 Subject: Remove misleading comment in nroff source --- doc/file.n | 1 - 1 file changed, 1 deletion(-) diff --git a/doc/file.n b/doc/file.n index 554da39..6f97f0b 100644 --- a/doc/file.n +++ b/doc/file.n @@ -434,7 +434,6 @@ If \fIname\fR contains no separators then returns \fIname\fR. So, return \fBb\fR. .TP \fBfile tempdir\fR ?\fItemplate\fR? -'\" TIP #210 .VS "8.7, TIP 431" Creates a temporary directory (guaranteed to be newly created and writable by the current script) and returns its name. If \fItemplate\fR is given, it -- cgit v0.12 From f4fbdbee8e29d3f1a1f419e85d2a0a091382d8e6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2019 08:01:08 +0000 Subject: Add to error info when passing an error out of [coroprobe] --- generic/tclBasic.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 02e3129..0117055 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9435,6 +9435,10 @@ InjectHandlerPostCall( */ if (isProbe) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (injected coroutine probe command)"); + } corPtr->nargs = nargs; corPtr->stackLevel = NULL; numLevels = iPtr->numLevels; -- cgit v0.12