* tests/io.test (io-53.9): Added testcase for [Bug 780533], based

	  on Alexandre's test script. Also fixed problem with timer in
	  preceding test, was not canceled properly in the ok case.

1 files changed, 51 insertions, 3 deletions

diff --git a/tests/io.test b/tests/io.test
index b118e4c..24e6580 100644
--- a/tests/io.test
+++ b/tests/io.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: io.test,v 1.40.2.13 2008/04/03 18:06:53 andreas_kupries Exp $
+# RCS: @(#) $Id: io.test,v 1.40.2.14 2008/04/04 20:01:00 andreas_kupries Exp $
 
 if {[catch {package require tcltest 2}]} {
     puts stderr "Skipping tests in [info script].  tcltest 2 required."
@@ -6947,11 +6947,12 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup {
     lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
     # Now let the async part happen. Should capture the error in cmd
     # via bgerror. If not break the event loop via timer.
-    after 1000 {
+    set token [after 1000 {
 	lappend ::RES {bgerror/FAIL timeout}
 	set ::forever has-been-reached
-    }
+    }]
     vwait ::forever
+    catch {after cancel $token}
     # Report
     set ::RES
 } -cleanup {
@@ -6964,6 +6965,53 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup {
     removeFile foo
     removeFile bar
 } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}}
+test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
+    set out [makeFile {} out]
+    set err [makeFile {} err]
+    set pipe [open "|[info nameofexecutable] 2> $err" r+]
+    fconfigure $pipe -translation binary -buffering line
+    puts $pipe {
+	fconfigure stdout -translation binary -buffering line
+	puts stderr Waiting...
+	after 1000
+	foreach x {a b c} {
+	    puts stderr Looping...
+	    puts $x
+	    after 500
+	}
+	proc bye args {
+	    if {[gets stdin line]<0} {
+		puts stderr "CHILD: EOF detected, exiting"
+		exit
+	    } else {
+		puts stderr "CHILD: ignoring line: $line"
+	    }
+	}
+	puts stderr Now-sleeping-forever
+	fileevent stdin readable bye
+	vwait forever
+    }
+    proc ::done args {
+	set ::forever OK
+	return
+    }
+    set ::forever {}
+    set out [open $out w]
+} -constraints {stdio openpipe fcopy} -body {
+    fcopy $pipe $out -size 6 -command ::done
+    set token [after 5000 {
+	set ::forever {fcopy hangs}
+    }]
+    vwait ::forever
+    catch {after cancel $token}
+    set ::forever
+} -cleanup {
+    close $pipe
+    rename ::done {}
+    removeFile out
+    removeFile err
+    catch {unset ::forever}
+} -result OK
 
 test io-54.1 {Recursive channel events} {socket fileevent} {
     # This test checks to see if file events are delivered during recursive