* 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.

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}