tests for [invoke] and [namespace invoke]

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:

doc/namespace.n

@@ -206,6 +206,15 @@ 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.

doc/uplevel.n

@@ -95,7 +95,7 @@ proc do {body while condition} {
 }
 .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:

generic/tclBasic.c

@@ -259,6 +259,7 @@ static const CmdInfo builtInCmds[] = {
     {"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},

generic/tclInt.h

@@ -2808,6 +2808,7 @@ 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;
@@ -3440,6 +3441,9 @@ 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[]);

generic/tclNamesp.c

@@ -113,6 +113,10 @@ static int		NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
 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,
@@ -185,6 +189,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = {
     {"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},
@@ -3757,6 +3762,116 @@ NamespaceImportCmd(
     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);
+}
+
 /*
  *----------------------------------------------------------------------
  *

generic/tclProc.c

@@ -718,15 +718,15 @@ TclGetFrame(
     CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
 				 * global frame indicated). */
 {
-	int result;
-	Tcl_Obj obj;
+    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;
+    obj.bytes = (char *) name;
+    obj.length = strlen(name);
+    obj.typePtr = NULL;
+    result = TclObjGetFrame(interp, &obj, framePtrPtr);
+    TclFreeIntRep(&obj);
+    return result;
 }
 
 /*
@@ -865,10 +865,12 @@ Uplevel_Callback(
     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)));
     }
 
     /*
@@ -954,11 +956,91 @@ TclNRUplevelObjCmd(
 	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);
+}
+
 /*
  *----------------------------------------------------------------------
  *

tests/namespace.test

@@ -3323,6 +3323,84 @@ namespace eval : {
 
 : 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 {}}

tests/uplevel.test

@@ -1,4 +1,4 @@
-# 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
@@ -294,6 +294,43 @@ test uplevel-7.3 {var access, LVT in upper level} -setup {
     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