9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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.23 2008/06/20 16:49:11 dgp Exp $
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
|
|
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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.24 2009/11/12 17:41:31 andreas_kupries Exp $
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
|
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
|
catch {close $b}
close $pipe
rename ::done {}
after 1000 ;# Give Windows time to kill the process
removeFile err
catch {unset ::forever}
} -result {AB BA}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
|
catch {close $b}
close $pipe
rename ::done {}
after 1000 ;# Give Windows time to kill the process
removeFile err
catch {unset ::forever}
} -result {AB BA}
test io-53.11 {Bug 2895565} -setup {
set in [makeFile {} in]
set f [open $in w]
fconfigure $f -encoding utf-8 -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
close $f
set inChan [open $in r]
fconfigure $inChan -translation binary
set out [makeFile {} out]
set outChan [open $out w]
fconfigure $outChan -encoding cp1252 -translation crlf
proc CopyDone {bytes args} {
variable done
if {[llength $args]} {
set done "Error: '[lindex $args 0]' after $bytes bytes copied"
} else {
set done "$bytes bytes copied"
}
}
} -body {
variable done
after 2000 [list set [namespace which -variable done] timeout]
fcopy $inChan $outChan -size 40 -command [namespace which CopyDone]
vwait [namespace which -variable done]
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
|