summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog9
-rw-r--r--doc/info.n14
-rw-r--r--generic/tclCmdIL.c23
-rw-r--r--generic/tclIOUtil.c6
-rw-r--r--tests/info.test23
5 files changed, 60 insertions, 15 deletions
diff --git a/ChangeLog b/ChangeLog
index 39ca0df..241dc24 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2000-05-27 Jeff Hobbs <hobbs@scriptics.com>
+
+ * 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]
+
2000-05-26 Jeff Hobbs <hobbs@scriptics.com>
* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): reworked to operate in
diff --git a/doc/info.n b/doc/info.n
index fe5748b..14d55ad 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -2,14 +2,15 @@
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
+'\" Copyright (c) 1998-2000 Ajuba Solutions
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: info.n,v 1.3 2000/01/26 21:36:35 ericm Exp $
+'\" RCS: @(#) $Id: info.n,v 1.4 2000/05/27 23:58:00 hobbs Exp $
'\"
.so man.macros
-.TH info n 7.5 Tcl "Tcl Built-In Commands"
+.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
@@ -147,12 +148,15 @@ matching \fIpattern\fR are returned.
Matching is determined using the same rules as for
\fBstring match\fR.
.TP
-\fBinfo script\fR
+\fBinfo script\fR ?\fIfilename\fR?
If a Tcl script file is currently being evaluated (i.e. there is a
call to \fBTcl_EvalFile\fR active or there is an active invocation
of the \fBsource\fR command), then this command returns the name
-of the innermost file being processed. Otherwise the command returns an
-empty string.
+of the innermost file being processed. If \fIfilename\fR is specified,
+then the return value of this command will be modified for the
+duration of the active invocation to return that name. This is
+useful in virtual file system applications.
+Otherwise the command returns an empty string.
.TP
\fBinfo sharedlibextension\fR
Returns the extension used on this platform for the names of files
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) {
diff --git a/tests/info.test b/tests/info.test
index d5a29a7..4098d2a 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: info.test,v 1.15 2000/04/10 17:19:00 ericm Exp $
+# RCS: @(#) $Id: info.test,v 1.16 2000/05/27 23:58:01 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -501,8 +501,8 @@ test info-15.8 {info procs option with a global shadowing proc} {
}
test info-16.1 {info script option} {
- list [catch {info script x} msg] $msg
-} {1 {wrong # args: should be "info script"}}
+ list [catch {info script x x} msg] $msg
+} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
file tail [info sc]
} "info.test"
@@ -519,6 +519,23 @@ test info-16.5 {resetting "info script" after errors} {
catch {source _nonexistent_}
file tail [info script]
} "info.test"
+test info-16.6 {info script option} {
+ set script [info script]
+ list [file tail [info script]] \
+ [info script newname.txt] \
+ [file tail [info script $script]]
+} [list info.test newname.txt info.test]
+test info-16.7 {info script option} {
+ set script [info script]
+ info script newname.txt
+ list [source gorp.info] [file tail [info script]] \
+ [file tail [info script $script]]
+} [list gorp.info newname.txt info.test]
+removeFile gorp.info
+makeFile {list [info script] [info script foo.bar]} gorp.info
+test info-16.3 {info script option} {
+ list [source gorp.info] [file tail [info script]]
+} [list [list gorp.info foo.bar] info.test]
removeFile gorp.info
test info-17.1 {info sharedlibextension option} {