summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclIO.c36
-rw-r--r--tests/cmdAH.test77
3 files changed, 104 insertions, 19 deletions
diff --git a/ChangeLog b/ChangeLog
index 9bc8228..af8bde1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2000-10-06 Jeff Hobbs <hobbs@ajubasolutions.com>
+
+ * tests/cmdAH.test: extra tests for 'file channels' that include
+ multiple interpreter tests and channel sharing
+ * generic/tclIO.c (Tcl_GetChannelNamesEx): corrected function (and
+ consequently 'file channels') to return channels that are actually
+ registered for this specific interp, rather than this thread.
+
+ * doc/CrtChannel.3: fixed spelling mistakes
+
2000-09-29 Jennifer Hom <jenn@ajubasolutions.com>
* library/tcltest1.0/tcltest2.tcl:
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 5e12182..6525b28 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.24 2000/09/28 06:38:20 hobbs Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.25 2000/10/06 21:10:50 hobbs Exp $
*/
#include "tclInt.h"
@@ -8027,15 +8027,30 @@ Tcl_GetChannelNamesEx(interp, pattern)
Tcl_Interp *interp; /* Interp for error reporting. */
char *pattern; /* pattern to filter on. */
{
- ChannelState *statePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- char *name;
- Tcl_Obj *resultPtr;
+ ChannelState *statePtr;
+ char *name; /* name for channel */
+ Tcl_Obj *resultPtr; /* pointer to result object */
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Tcl_HashSearch hSearch; /* Search variable. */
- resultPtr = Tcl_GetObjResult(interp);
- for (statePtr = tsdPtr->firstCSPtr;
- statePtr != NULL;
- statePtr = statePtr->nextCSPtr) {
+ if (interp == (Tcl_Interp *) NULL) {
+ return TCL_OK;
+ }
+
+ /*
+ * Get the channel table that stores the channels registered
+ * for this interpreter.
+ */
+ hTblPtr = GetChannelTable(interp);
+ resultPtr = Tcl_GetObjResult(interp);
+
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != (Tcl_HashEntry *) NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+
+ statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
name = "stdin";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
@@ -8043,8 +8058,13 @@ Tcl_GetChannelNamesEx(interp, pattern)
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
+ /*
+ * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr),
+ * but it's simpler to just grab the name from the statePtr.
+ */
name = statePtr->channelName;
}
+
if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
(Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, -1)) != TCL_OK)) {
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 912cd30..03e76eb 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: cmdAH.test,v 1.11 2000/09/20 23:09:54 jenn Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.12 2000/10/06 21:10:51 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1491,23 +1491,78 @@ test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
} {1 {user "woohgy" doesn't exist}}
# channels
+# In testing 'file channels', we need to make sure that a channel
+# created in one interp isn't visible in another.
+
+interp create simpleInterp
+interp create -safe safeInterp
+interp c
+safeInterp expose file file
test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} {
list [catch {file channels a b} msg] $msg
} {1 {wrong # args: should be "file channels ?pattern?"}}
-test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} {singleTestInterp} {
- file chan
-} {stderr stdout stdin}
-test cmdAH-31.3 {Tcl_FileObjCmd: channels, too many args} {
+test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} {
+ # Normal interps start out with only the standard channels
+ lsort [simpleInterp eval [list file chan]]
+} [lsort {stderr stdout stdin}]
+test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
string equal [file channels] [file channels *]
} {1}
-test cmdAH-31.4 {Tcl_FileObjCmd: channels} {singleTestInterp} {
- set old [file channels gorp.file]
- set f [open gorp.file w]
- set new [file channels file*]
- close $f
- string equal $f $new
+test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
+ lsort [file channels std*]
+} [lsort {stdout stderr stdin}]
+
+set newFileId [open gorp.file w]
+
+test cmdAH-31.5 {Tcl_FileObjCmd: channels} {
+ set res [file channels $newFileId]
+ string equal $newFileId $res
} {1}
+test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {
+ # Safe interps start out with no channels
+ safeInterp eval [list file channels]
+} {}
+test cmdAH-31.7 {Tcl_FileObjCmd: channels in other interp} {
+ list [catch {safeInterp eval [list puts $newFileId "hello"]} msg] $msg
+} [list 1 "can not find channel named \"$newFileId\""]
+
+interp share {} $newFileId safeInterp
+interp share {} stdout safeInterp
+
+test cmdAH-31.8 {Tcl_FileObjCmd: channels in other interp} {
+ # $newFileId should now be visible in both interps
+ list [file channels $newFileId] \
+ [safeInterp eval [list file channels $newFileId]]
+} [list $newFileId $newFileId]
+test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {
+ lsort [safeInterp eval [list file channels]]
+} [lsort [list stdout $newFileId]]
+test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {
+ # we can now write to $newFileId from slave
+ safeInterp eval [list puts $newFileId "hello"]
+} {}
+
+interp transfer {} $newFileId safeInterp
+
+test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} {
+ # $newFileId should now be visible only in safeInterp
+ list [file channels $newFileId] \
+ [safeInterp eval [list file channels $newFileId]]
+} [list {} $newFileId]
+test cmdAH-31.12 {Tcl_FileObjCmd: channels in other interp} {
+ lsort [safeInterp eval [list file channels]]
+} [lsort [list stdout $newFileId]]
+test cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} {
+ safeInterp eval [list close $newFileId]
+ safeInterp eval [list file channels]
+} {stdout}
+
+# This shouldn't work, but just in case a test above failed...
+catch {close $newFileId}
+
+interp delete safeInterp
+interp delete simpleInterp
# cleanup
catch {testsetplatform $platform}