* tests/info.test:

	* doc/info.n:
	* generic/tclIOUtil.c (Tcl_EvalFile):
	* generic/tclCmdIL.c (InfoScriptCmd): added ability to set the
	info script return value [info script ?newFileName?].  This will
	be beneficial for virtual file system programs. [Bug: 4225]

2 files changed, 22 insertions, 7 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index d9a29b6..5135476 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdIL.c,v 1.26 2000/05/09 17:50:38 ericm Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.27 2000/05/27 23:58:01 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -1578,14 +1578,17 @@ InfoProcsCmd(dummy, interp, objc, objv)
  *      script file that is currently being evaluated. Handles the
  *      following syntax:
  *
- *          info script
+ *          info script ?newName?
+ *
+ *	If newName is specified, it will set that as the internal name.
  *
  * Results:
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
  *
  * Side effects:
  *      Returns a result in the interpreter's result object. If there is
- *	an error, the result is an error message.
+ *	an error, the result is an error message.  It may change the
+ *	internal script filename.
  *
  *----------------------------------------------------------------------
  */
@@ -1598,11 +1601,21 @@ InfoScriptCmd(dummy, interp, objc, objv)
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     Interp *iPtr = (Interp *) interp;
-    if (objc != 2) {
-        Tcl_WrongNumArgs(interp, 2, objv, NULL);
+    if ((objc != 2) && (objc != 3)) {
+        Tcl_WrongNumArgs(interp, 2, objv, "?filename?");
         return TCL_ERROR;
     }
 
+    if (objc == 3) {
+	int length;
+	char *filename = Tcl_GetStringFromObj(objv[2], &length);
+
+	if (iPtr->scriptFile != NULL) {
+	    ckfree(iPtr->scriptFile);
+	}
+	iPtr->scriptFile = ckalloc((unsigned) (length + 1));
+	strcpy(iPtr->scriptFile, filename);
+    }
     if (iPtr->scriptFile != NULL) {
         Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
     }
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 41db745..f4412e5 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIOUtil.c,v 1.10 2000/05/11 00:16:53 hobbs Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.11 2000/05/27 23:58:01 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -324,9 +324,11 @@ Tcl_EvalFile(interp, fileName)
 
     iPtr = (Interp *) interp;
     oldScriptFile = iPtr->scriptFile;
-    iPtr->scriptFile = fileName;
+    iPtr->scriptFile = ckalloc((unsigned) (strlen(fileName) + 1));
+    strcpy(iPtr->scriptFile, fileName);
     string = Tcl_GetStringFromObj(objPtr, &length);
     result = Tcl_EvalEx(interp, string, length, 0);
+    ckfree(iPtr->scriptFile);
     iPtr->scriptFile = oldScriptFile;
 
     if (result == TCL_RETURN) {