TIP #332 IMPLEMENTATION - Half-Close for Bidirectional Channels

3 files changed, 85 insertions, 10 deletions

diff --git a/tests/chan.test b/tests/chan.test
index 39dd111..7dccda7 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: chan.test,v 1.15 2008/07/21 21:02:19 ferrieux Exp $
+# RCS: @(#) $Id: chan.test,v 1.16 2008/12/18 01:14:17 ferrieux Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -29,11 +29,23 @@ test chan-1.2 {chan command general syntax} -body {
 test chan-2.1 {chan command: blocked subcommand} -body {
     chan blocked foo bar
 } -returnCodes error -result "wrong # args: should be \"chan blocked channelId\""
-
 test chan-3.1 {chan command: close subcommand} -body {
-    chan close foo bar
-} -returnCodes error -result "wrong # args: should be \"chan close channelId\""
-
+    chan close foo bar zet
+} -returnCodes error -result "wrong # args: should be \"chan close channelId ?direction?\""
+test chan-3.2 {chan command: close subcommand} -setup {
+    set chan [open [info script] r]
+} -body {
+    chan close $chan bar
+} -cleanup {
+    close $chan
+} -returnCodes error -result "bad direction \"bar\": must be read or write"
+test chan-3.3 {chan command: close subcommand} -setup {
+    set chan [open [info script] r]
+} -body {
+    chan close $chan write
+} -cleanup {
+    close $chan
+} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
 test chan-4.1 {chan command: configure subcommand} -body {
     chan configure
 } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\""
diff --git a/tests/chanio.test b/tests/chanio.test
index 7e53f77..487691a 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -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: chanio.test,v 1.15 2008/06/20 20:48:48 dgp Exp $
+# RCS: @(#) $Id: chanio.test,v 1.16 2008/12/18 01:14:17 ferrieux Exp $
 
 if {[catch {package require tcltest 2}]} {
     chan puts stderr "Skipping tests in [info script].  tcltest 2 required."
@@ -2229,7 +2229,56 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} {stdio unix testchannel o
     chan close $f
     set l
 } {file1 file2}
-
+test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} {
+    set cat [makeFile {
+	fconfigure stdout -buffering line
+	while {[gets stdin line]>=0} {puts $line}
+	puts DONE
+	exit 0
+    } cat.tcl]
+    set ::ff [open "|[list tclsh $cat]" r+]
+    puts $::ff Hey
+    flush $ff
+    close $::ff w
+    after 1000 {set ::done Failed}
+    set ::acc {}
+    fileevent $::ff readable {
+	if {[gets $::ff line]<0} {set ::done Succeeded;return}
+	lappend ::acc $line
+    }
+    vwait ::done
+    close $::ff r
+    list $::done $::acc
+} {Succeeded {Hey DONE}}
+if {0} {test chan-io-28.7 {Tcl_CloseEx (half-close) socket} {
+    set echo [makeFile {
+	proc accept {s args} {set ::sok $s}
+	set s [socket -server accept 0]
+	puts [lindex [fconfigure $s -sockname] 2]
+	flush stdout
+	vwait ::sok
+	fconfigure $::sok -buffering line
+	while {[gets $::sok line]>=0} {puts $::sok $line}
+	puts $::sok DONE
+	exit 0
+    } echo.tcl]
+    set ::ff [open "|[list tclsh $echo]" r]
+    gets $::ff port
+    set ::s [socket 127.0.0.1 $port]
+    puts $::s Hey
+    flush $::s
+    close $::s w
+    after 1000 {set ::done Failed}
+    set ::acc {}
+    fileevent $::s readable {
+	if {[gets $::s line]<0} {set ::done Succeeded;return}
+	lappend ::acc $line
+    }
+    vwait ::done
+    close $::s r
+    close $::ff
+    list $::done $::acc
+} {Succeeded {Hey DONE}}}
 test chan-io-29.1 {Tcl_WriteChars, channel not writable} {
     list [catch {chan puts stdin hello} msg] $msg
 } {1 {channel "stdin" wasn't opened for writing}}
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index a38158e..0018f83 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -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: ioCmd.test,v 1.47 2008/07/21 21:12:49 ferrieux Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.48 2008/12/18 01:14:17 ferrieux Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -182,13 +182,27 @@ test iocmd-6.3 {tell command} {
 
 test iocmd-7.1 {close command} {
     list [catch {close} msg] $msg
-} {1 {wrong # args: should be "close channelId"}}
+} {1 {wrong # args: should be "close channelId ?direction?"}}
 test iocmd-7.2 {close command} {
     list [catch {close a b c d e} msg] $msg
-} {1 {wrong # args: should be "close channelId"}}
+} {1 {wrong # args: should be "close channelId ?direction?"}}
 test iocmd-7.3 {close command} {
     list [catch {close aaa} msg] $msg
 } {1 {can not find channel named "aaa"}}
+test iocmd-7.4 {close command} -setup {
+    set chan [open [info script] r]
+} -body {
+    chan close $chan bar
+} -cleanup {
+    close $chan
+} -returnCodes error -result "bad direction \"bar\": must be read or write"
+test iocmd-7.5 {close command} -setup {
+    set chan [open [info script] r]
+} -body {
+    chan close $chan write
+} -cleanup {
+    close $chan
+} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
 
 test iocmd-8.1 {fconfigure command} {
     list [catch {fconfigure} msg] $msg