Implement TIP 728: interp set

Author: dkfellows

doc/interp.n

@@ -390,6 +390,16 @@ may get stack overflows before reaching the limit set by the command. If
 this happens, see if there is a mechanism in your system for increasing
 the maximum size of the C stack.
 .RE
+.\" METHOD: set
+.TP
+\fBinterp set\fI path varName\fR ?\fIvalue\fR?
+.VS 9.1
+Writes to, or reads from, the variable \fIvarName\fR in the interpreter
+specifed by \fIpath\fR. If \fIvalue\fR is given, writes to the variable and
+returns its new value; if \fIvalue\fR is omitted, reads from the variable.
+As with the \fBset\fR command, traces may affect what the value of the
+variable is.
+.VE 9.1
 .\" METHOD: share
 .TP
 \fBinterp share\fI srcPath channel destPath\fR
@@ -601,6 +611,17 @@ may get stack overflows before reaching the limit set by the command. If
 this happens, see if there is a mechanism in your system for increasing
 the maximum size of the C stack.
 .RE
+.RE
+.\" METHOD: set
+.TP
+\fIchild \fBset\fR \fIvarName\fR ?\fIvalue\fR?
+.VS 9.1
+Writes to, or reads from, the variable \fIvarName\fR in the \fIchild\fR
+interpreter. If \fIvalue\fR is given, writes to the variable and
+returns its new value; if \fIvalue\fR is omitted, reads from the variable.
+As with the \fBset\fR command, traces may affect what the value of the
+variable is.
+.VE 9.1
 .SH "SAFE INTERPRETERS"
 .PP
 A safe interpreter is one with restricted functionality, so that

generic/tclInterp.c

@@ -256,6 +256,9 @@ static int		ChildInvokeHidden(Tcl_Interp *interp,
 static int		ChildMarkTrusted(Tcl_Interp *interp,
 			    Tcl_Interp *childInterp);
 static Tcl_CmdDeleteProc	ChildObjCmdDeleteProc;
+static int		ChildSet(Tcl_Interp *interp,
+			    Tcl_Interp *childInterp, Tcl_Obj *varNameObj,
+			    Tcl_Obj *valueObj);
 static int		ChildRecursionLimit(Tcl_Interp *interp,
 			    Tcl_Interp *childInterp, Tcl_Size objc,
 			    Tcl_Obj *const objv[]);
@@ -635,7 +638,7 @@ NRInterpCmd(
 	"eval",		"exists",	"expose",	"hide",
 	"hidden",	"issafe",	"invokehidden",
 	"limit",	"marktrusted",	"recursionlimit",
-	"share",
+	"set",		"share",
 #ifndef TCL_NO_DEPRECATED
 	"slaves",
 #endif
@@ -647,15 +650,16 @@ NRInterpCmd(
 	"eval",		"exists",	"expose",
 	"hide",		"hidden",	"issafe",
 	"invokehidden",	"limit",	"marktrusted",	"recursionlimit",
-	"share",	"target",	"transfer",
+	"set",		"share",	"target",	"transfer",
 	NULL
     };
     enum interpOptionEnum {
 	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_CANCEL,
 	OPT_CHILDREN,	OPT_CREATE,	OPT_DEBUG,	OPT_DELETE,
 	OPT_EVAL,	OPT_EXISTS,	OPT_EXPOSE,	OPT_HIDE,
 	OPT_HIDDEN,	OPT_ISSAFE,	OPT_INVOKEHID,
-	OPT_LIMIT,	OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE,
+	OPT_LIMIT,	OPT_MARKTRUSTED, OPT_RECLIMIT,	OPT_SET,
+	OPT_SHARE,
 #ifndef TCL_NO_DEPRECATED
 	OPT_SLAVES,
 #endif
@@ -903,6 +907,17 @@ NRInterpCmd(
 	    return TCL_ERROR;
 	}
 	return ChildEval(interp, childInterp, objc - 3, objv + 3);
+    case OPT_SET:
+	if (objc < 4 || objc > 5) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "path varName ?value?");
+	    return TCL_ERROR;
+	}
+	childInterp = GetInterp(interp, objv[2]);
+	if (childInterp == NULL) {
+	    return TCL_ERROR;
+	}
+	return ChildSet(interp, childInterp, objv[3],
+		objc > 4 ? objv[4] : NULL);
     case OPT_EXISTS: {
 	int exists = 1;
 
@@ -2521,13 +2536,13 @@ NRChildCmd(
 	"alias",	"aliases",	"bgerror",	"debug",
 	"eval",		"expose",	"hide",		"hidden",
 	"issafe",	"invokehidden",	"limit",	"marktrusted",
-	"recursionlimit", NULL
+	"recursionlimit", "set",	NULL
     };
     enum childCmdOptionsEnum {
 	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_DEBUG,
 	OPT_EVAL,	OPT_EXPOSE,	OPT_HIDE,	OPT_HIDDEN,
 	OPT_ISSAFE,	OPT_INVOKEHIDDEN, OPT_LIMIT,	OPT_MARKTRUSTED,
-	OPT_RECLIMIT
+	OPT_RECLIMIT,	OPT_SET
     } index;
 
     if (childInterp == NULL) {
@@ -2689,6 +2704,12 @@ NRChildCmd(
 	    return TCL_ERROR;
 	}
 	return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2);
+    case OPT_SET:
+	if (objc < 3 || objc > 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "varName ?value?");
+	    return TCL_ERROR;
+	}
+	return ChildSet(interp, childInterp, objv[2], objc>3 ? objv[3] : NULL);
     default:
 	TCL_UNREACHABLE();
     }
@@ -2878,6 +2899,51 @@ ChildEval(
     return result;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * ChildSet --
+ *
+ *	Helper function to read and write a variable in a child interpreter.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Depends on whether the variable has traces. If so, this can have
+ *	extensive arbitrary side effects.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ChildSet(
+    Tcl_Interp *interp,
+    Tcl_Interp *childInterp,
+    Tcl_Obj *varNameObj,
+    Tcl_Obj *valueObj)
+{
+    int result = TCL_ERROR;
+    Tcl_Obj *resultObj;
+    Tcl_Preserve(childInterp);
+
+    // Modelled after the guts of Tcl_SetObjCmd().
+    if (valueObj) {
+	resultObj = Tcl_ObjSetVar2(childInterp, varNameObj, NULL, valueObj,
+		TCL_LEAVE_ERR_MSG);
+    } else {
+	resultObj = Tcl_ObjGetVar2(childInterp, varNameObj, NULL,
+		TCL_LEAVE_ERR_MSG);
+    }
+    if (resultObj) {
+	Tcl_SetObjResult(childInterp, resultObj);
+	result = TCL_OK;
+    }
+
+    Tcl_TransferResult(childInterp, result, interp);
+    Tcl_Release(childInterp);
+    return result;
+}
+
 /*
  *----------------------------------------------------------------------
  *

library/package.tcl

@@ -348,17 +348,17 @@ proc pkg_mkIndex {args} {
 	    $c eval [list ::tcl::DiscoverPackageContents $dir $file $direct]
 	} on error msg {
 	    if {$doVerbose} {
-		set what [$c eval set ::tcl::debug]
+		set what [$c set ::tcl::debug]
 		tclLog "warning: error while $what $file: $msg"
 	    }
 	} on ok {} {
 	    if {$doVerbose} {
-		set what [$c eval set ::tcl::debug]
+		set what [$c set ::tcl::debug]
 		tclLog "successful $what of $file"
 	    }
-	    set type [$c eval set ::tcl::type]
-	    set cmds [lsort [dict keys [$c eval set ::tcl::newCmds]]]
-	    set pkgs [$c eval set ::tcl::newPkgs]
+	    set type [$c set ::tcl::type]
+	    set cmds [lsort [dict keys [$c set ::tcl::newCmds]]]
+	    set pkgs [$c set ::tcl::newPkgs]
 	    if {$doVerbose} {
 		if {!$direct} {
 		    tclLog "commands provided were $cmds"

library/safe.tcl

@@ -428,7 +428,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au
 	    lappend tokens_auto_path [dict get $remap_access_path $dir]
 	}
     }
-    ::interp eval $child [list set auto_path $tokens_auto_path]
+    ::interp set $child auto_path $tokens_auto_path
 
     # Add the tcl::tm directories to the access path.
     set morepaths [::tcl::tm::list]
@@ -767,7 +767,7 @@ proc ::safe::SyncAccessPath {child} {
 
     set child_access_path $state(access_path,child)
     if {$AutoPathSync} {
-	::interp eval $child [list set auto_path $child_access_path]
+	::interp set $child auto_path $child_access_path
 
 	Log $child "auto_path in $child has been set to $child_access_path"\
 		NOTICE
@@ -777,8 +777,7 @@ proc ::safe::SyncAccessPath {child} {
     # list of access path's. See -> InterpSetConfig for the code which
     # ensures this condition.
 
-    ::interp eval $child [list \
-	      set tcl_library [lindex $child_access_path 0]]
+    ::interp set $child tcl_library [lindex $child_access_path 0]
     return
 }