ADDED doc/invoke.n Index: doc/invoke.n ================================================================== --- /dev/null +++ doc/invoke.n @@ -0,0 +1,116 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1997 Sun Microsystems, Inc. +'\" Copyright (c) 2019 Donal K Fellows. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH invoke n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +invoke \- Execute a command in a different stack frame +.SH SYNOPSIS +\fBinvoke \fIlevel command \fR?\fIarg ...\fR? +.BE +.SH DESCRIPTION +.PP +The \fBinvoke\fR command concatenates \fIcommand\fR with all of the \fIarg\fR +arguments as if they had been passed to \fBlist\fR; it then evaluates the +result in the variable context indicated by \fIlevel\fR. \fBInvoke\fR returns +the result of that evaluation. +.PP +If \fIlevel\fR is an integer then it gives a distance (up the procedure +calling stack) to move before executing the command. If \fIlevel\fR consists +of \fB#\fR followed by a integer then the level gives an absolute level. +.PP +For example, suppose that procedure \fBa\fR was invoked from top-level, and +that it called \fBb\fR, and that \fBb\fR called \fBc\fR. Suppose that \fBc\fR +invokes the \fBinvoke\fR command. If \fIlevel\fR is \fB1\fR or \fB#2\fR, then +the command will be executed in the variable context of \fBb\fR. If +\fIlevel\fR is \fB2\fR or \fB#1\fR then the command will be executed in the +variable context of \fBa\fR. If \fIlevel\fR is \fB3\fR or \fB#0\fR then the +command will be executed at top-level (only global variables will be visible). +.PP +The \fBinvoke\fR command causes the invoking procedure to disappear from the +procedure calling stack while the command is being executed. In the above +example, suppose \fBc\fR invokes the command +.PP +.CS +\fBinvoke\fR 1 set x "some arbitrary string" +.CE +.PP +where \fBd\fR is another Tcl procedure. The \fBset\fR command will modify the +variable \fBx\fR in \fBb\fR's context, at level 3, as if called from \fBb\fR: +the procedure \fBc\fR does not appear to be on the call stack when the +\fBset\fR is executing. The \fBinfo level\fR command may be used to obtain +the level of the current procedure. +.PP +\fBInvoke\fR makes it possible to implement new control constructs as Tcl +procedures, and is useful in situations where the caller of \fBinvoke\fR is in +control of the arguments (unlike with \fBuplevel\fR which is more suitable for +calling a script provided by the caller of the procedure). +.PP +The \fBnamespace eval\fR and \fBapply\fR commands and TclOO methods offer +other ways (besides procedure calls) that the Tcl naming context can change. +They add a call frame to the stack to represent the namespace context. This +means each \fBnamespace eval\fR command counts as another call level for +\fBinvoke\fR and \fBupvar\fR commands. For example, \fBinfo level 1\fR will +return a list describing a command that is either the outermost procedure call +or the outermost \fBnamespace eval\fR command. Also, \fBinvoke #0\fR +evaluates a command at top-level in the outermost namespace (the global +namespace). +.SH EXAMPLE +As stated above, the \fBinvoke\fR command is useful for creating new control +constructs. This example shows how (ignoring \fBupvar\fRed variables and +arrays) it can be used to create a \fIlambda\fR command that creates a lambda +term (using \fBapply\fR) that can be in the same namespace context as the +caller of \fBlambda\fR with a copy (effectively read-only) of the local +variables in the stack frame it was called from, for effectively +lexically-scoped variables: +.PP +.CS +proc \fIlambda\fR {args body} { + set locals [\fBinvoke\fR 1 info locals] + set arguments [list {*}$locals {*}$args] + set ns [\fBinvoke\fR 1 namespace current] + set values [lmap var $locals {\fBinvoke\fR 1 set $var}] + return [list apply [list $arguments $body $ns] {*}$values] +} + +\fI# Demonstrating it in use\fR +namespace eval foo { + variable b {} + + proc bar {x y} { + set z [expr {$x + $y}] + + return [\fIlambda\fR a { + variable b + lappend b $a + return $x,$y,$z,$a,[join $b "|"] + }] + } +} + +set with23 [foo::bar 2 3] +puts [{*}$with23 "demo"] +\fI# ==> 2,3,5,demo,demo\fR +puts [{*}$with23 "again"] +\fI# ==> 2,3,5,again,demo|again\fR + +set with45 [foo::bar 4 5] +puts [{*}$with45 "more"] +\fI# ==> 4,5,9,more,demo|again|more\fR +puts [{*}$with23 "again"] +\fI# ==> 2,3,5,again,demo|again|more|again\fR +.CE +.SH "SEE ALSO" +apply(n), namespace(n), uplevel(n), upvar(n) +.SH KEYWORDS +context, level, namespace, stack frame, variable +.\" Local Variables: +.\" mode: nroff +.\" End: Index: doc/namespace.n ================================================================== --- doc/namespace.n +++ doc/namespace.n @@ -203,10 +203,19 @@ In other words, you can import only the commands that are in a namespace at the time when the \fBnamespace import\fR command is executed. If another command is defined and exported in this namespace later on, it will not be imported. .RE +.TP +\fBnamespace invoke\fR \fInamespace cmd\fR ?\fIarg ...\fR? +.VS "TIP 284" +Invokes the command called \fIcmd\fR, as resolved from namespace +\fInamespace\fR, with the supplied arguments; the command is invoked +in the scope of the caller of \fBnamespace invoke\fR, so there are no +intervening stack frames. If \fInamespace\fR does not exist, the +command returns an error. +.VE "TIP 284" .TP \fBnamespace inscope\fR \fInamespace\fR \fIscript\fR ?\fIarg ...\fR? . Executes a script in the context of the specified \fInamespace\fR. This command is not expected to be used directly by programmers; Index: doc/uplevel.n ================================================================== --- doc/uplevel.n +++ doc/uplevel.n @@ -93,11 +93,11 @@ } } } .CE .SH "SEE ALSO" -apply(n), namespace(n), upvar(n) +apply(n), invoke(n), namespace(n), upvar(n) .SH KEYWORDS context, level, namespace, stack frame, variable .\" Local Variables: .\" mode: nroff .\" End: Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -257,10 +257,11 @@ {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, + {"invoke", Tcl_InvokeObjCmd, NULL, TclNRInvokeObjCmd, CMD_IS_SAFE}, {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -2806,10 +2806,11 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvokeObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -3437,10 +3438,13 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_InvokeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -111,10 +111,14 @@ static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void NamespaceFree(Namespace *nsPtr); static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int NamespaceInvokeCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NRNamespaceInvokeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceInscopeCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NRNamespaceInscopeCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, @@ -183,10 +187,11 @@ {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"invoke", NamespaceInvokeCmd, TclCompileBasicMin2ArgCmd, NRNamespaceInvokeCmd, NULL, 0}, {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, @@ -3754,10 +3759,120 @@ return result; } } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * NamespaceInvokeCmd -- + * + * Invoked to implement the "namespace invoke" command that invokes a + * command in a predefined namespace. Handles the syntax: + * + * namespace invoke ns cmd ?arg1? ?arg2? ... + * + * This invokes the command cmd, as resolved from namespace ns, with the + * supplied arguments. It is similar to: + * + * namespace eval ns [list cmd ?arg1? ?arg2? ...] + * + * up to the fact that it executes in the caller's context: it does *not* + * push a new CallFrame. + * + * Results: + * Returns TCL_OK if the namespace is found and the command is executed + * successfully. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns the result of the command in the interpreter's result object. + * If anything goes wrong, this function returns an error message as the + * result. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceInvokeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *namespacePtr; + int result; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg...?"); + return TCL_ERROR; + } + + /* + * Try to resolve the namespace reference, caching the result in the + * namespace object along the way. If the namespace is not found, return + * an error. + */ + + result = TclGetNamespaceFromObj(interp, objv[1], &namespacePtr); + if (result != TCL_OK) { + return result; + } + if (namespacePtr == NULL) { + Tcl_AppendResult(interp, "unknown namespace \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + + /* + * Invoke the command in the requested namespace + */ + + iPtr->lookupNsPtr = (Namespace *) namespacePtr; + return Tcl_EvalObjv(interp, objc - 2, objv + 2, TCL_EVAL_INVOKE); +} + +static int +NRNamespaceInvokeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *namespacePtr; + int result; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg...?"); + return TCL_ERROR; + } + + /* + * Try to resolve the namespace reference, caching the result in the + * namespace object along the way. If the namespace is not found, return + * an error. + */ + + result = TclGetNamespaceFromObj(interp, objv[1], &namespacePtr); + if (result != TCL_OK) { + return result; + } + if (namespacePtr == NULL) { + Tcl_AppendResult(interp, "unknown namespace \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + + /* + * Invoke the command in the requested namespace + */ + + iPtr->lookupNsPtr = (Namespace *) namespacePtr; + return TclNREvalObjv(interp, objc - 2, objv + 2, TCL_EVAL_INVOKE, NULL); +} /* *---------------------------------------------------------------------- * * NamespaceInscopeCmd -- Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -716,19 +716,19 @@ Tcl_Interp *interp, /* Interpreter in which to find frame. */ const char *name, /* String describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - int result; - Tcl_Obj obj; - - obj.bytes = (char *) name; - obj.length = strlen(name); - obj.typePtr = NULL; - result = TclObjGetFrame(interp, &obj, framePtrPtr); - TclFreeIntRep(&obj); - return result; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeIntRep(&obj); + return result; } /* *---------------------------------------------------------------------- * @@ -863,14 +863,16 @@ ClientData data[], Tcl_Interp *interp, int result) { CallFrame *savedVarFramePtr = data[0]; + const char *msgPiece = data[1]; if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp))); + "\n (\"%s\" body line %d)", + msgPiece, Tcl_GetErrorLine(interp))); } /* * Restore the variable frame, and return. */ @@ -952,14 +954,94 @@ */ objPtr = Tcl_ConcatObj(objc, objv); } - TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, - NULL); + TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, "uplevel", + NULL, NULL); return TclNREvalObjEx(interp, objPtr, 0, invoker, word); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_InvokeObjCmd -- + * + * This object function is invoked to process the "invoke" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_InvokeObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRInvokeObjCmd, dummy, objc, objv); +} + +int +TclNRInvokeObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr, *framePtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "level command ?arg ...?"); + return TCL_ERROR; + } + + /* + * Find the level to use for executing the command. + */ + + result = TclObjGetFrame(interp, objv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } else if (result == 0) { + /* + * Must have a level, and whatever we've got, that's what we haven't + * got. + */ + + const char *name = TclGetString(objv[1]); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); + return TCL_ERROR; + } + + /* + * Modify the interpreter state to execute in the given frame. + */ + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + + /* + * Execute the residual arguments as a command. + */ + + TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, "invoke", + NULL, NULL); + return TclNREvalObjv(interp, objc - 2, objv + 2, TCL_EVAL_INVOKE, NULL); +} /* *---------------------------------------------------------------------- * * TclFindProc -- Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -3321,10 +3321,88 @@ } } : p1 } 16fe1b5807 + +namespace eval ::namespace-57 { +test namespace-57.1 {namespace invoke} -returnCodes error -body { + namespace invoke +} -result {wrong # args: should be "namespace invoke name cmd ?arg...?"} +test namespace-57.2 {namespace invoke} -returnCodes error -body { + namespace invoke no_such_namespace namespace current +} -result {namespace "no_such_namespace" not found in "::namespace-57"} +test namespace-57.3 {namespace invoke} -returnCodes error -body { + namespace invoke :: definitely_no_such_command +} -result {invalid command name "definitely_no_such_command"} +test namespace-57.4 {namespace invoke doesn't push a namespace} -body { + namespace invoke :: namespace current +} -result ::namespace-57 +test namespace-57.5 {namespace invoke resolves in the given ns} -setup { + namespace eval ns {} +} -body { + proc target {} {return "in origin"} + proc ns::target {} {return "in target"} + namespace invoke ns target +} -cleanup { + rename target {} + namespace delete ns +} -result {in target} +test namespace-57.6 {namespace invoke resolves in the given ns} -setup { + namespace eval ns {} +} -body { + namespace eval ns::tcl {} + namespace invoke ns tcl::prefix match {a bcd e} b +} -cleanup { + namespace delete ns +} -result bcd +test namespace-57.7 {namespace invoke resolves in the given ns} -setup { + namespace eval ns {} +} -body { + namespace eval ns::tcl {proc prefix args {return ok}} + namespace invoke ns tcl::prefix match {a bcd e} b +} -cleanup { + namespace delete ns +} -result ok +test namespace-57.8 {namespace invoke resolves in the given ns} -setup { + namespace eval ns {} + namespace eval ns2 { + proc foo {} {return "this is in ns2"} + } +} -body { + namespace eval ns { + namespace path ::namespace-57::ns2 + } + namespace invoke ns foo +} -cleanup { + namespace delete ns +} -result {this is in ns2} +test namespace-57.9 {namespace invoke preserves word boundaries} -setup { + namespace eval ns { + proc count args {list [llength $args] $args} + } +} -body { + namespace invoke ns count a {b c} gorp +} -cleanup { + namespace delete ns +} -result {3 {a {b c} gorp}} +test namespace-57.10 {namespace invoke is NRE-aware} -setup { + namespace eval ns {} +} -body { + proc ns::count args { + yield $args + return [llength $args] + } + coroutine c apply {args { + yield + namespace invoke ns count {*}$args + } ::namespace-57} a {b c} gorp + list [c] [c] +} -cleanup { + namespace delete ns +} -result {{a {b c} gorp} 3} +} # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} Index: tests/uplevel.test ================================================================== --- tests/uplevel.test +++ tests/uplevel.test @@ -1,6 +1,6 @@ -# Commands covered: uplevel +# Commands covered: uplevel, invoke # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # @@ -292,14 +292,51 @@ moo } -cleanup { rename foo {} rename moo {} } -result {3 3 3} + +test invoke-1.1 {invoke command usage} -returnCodes error -body { + invoke +} -result {wrong # args: should be "invoke level command ?arg ...?"} +test invoke-1.2 {invoke command usage} -returnCodes error -body { + invoke 0 +} -result {wrong # args: should be "invoke level command ?arg ...?"} +test invoke-1.3 {invoke command usage} -returnCodes error -body { + invoke list a b c +} -result {bad level "list"} +test invoke-1.4 {invoke command usage} -returnCodes error -body { + invoke 50000 list a b c +} -result {bad level "50000"} +test invoke-1.5 {invoke preserves word boundaries} -body { + invoke 0 list "a b" c +} -result {{a b} c} +test invoke-1.6 {invoke walks the stack} -body { + apply {x { + apply {x { + apply {x { + apply {{x levels} { + lmap l $levels {string cat $l -> [invoke $l set x]} + }} jkl {3 2 1 0 #1 #2 #3 #4} + }} ghi + }} def + }} abc +} -result {3->abc 2->def 1->ghi 0->jkl #1->abc #2->def #3->ghi #4->jkl} +test invoke-1.7 {invoke is NRE-aware} -body { + coroutine c apply {{} { + set x [yield] + list [apply {x { + invoke 1 eval {set x [yield $x]} + return $x + }} $x,$x] $x + }} + list [c 135] [c 246] +} -result {135 {135,135 246}} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: