diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | doc/info.n | 14 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 23 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 6 | ||||
| -rw-r--r-- | tests/info.test | 23 |
5 files changed, 60 insertions, 15 deletions
@@ -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 @@ -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} { |