44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
testConstraint testobj [llength [info commands testobj]]
testConstraint testservicemode [llength [info commands testservicemode]]
# Some things fail under Windows in Continuous Integration systems for subtle
# reasons such as CI often running with elevated privileges in a container.
testConstraint notWinCI [expr {
$::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
>
>
|
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
testConstraint testobj [llength [info commands testobj]]
testConstraint testservicemode [llength [info commands testservicemode]]
# Some things fail under Windows in Continuous Integration systems for subtle
# reasons such as CI often running with elevated privileges in a container.
testConstraint notWinCI [expr {
$::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# File permissions broken on wsl without some "exotic" wsl configuration
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
|
set x [gets $f]
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unix} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
set x [format "0o%o" [expr {$stats(mode)&0o777}]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {0o600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode)&0o777}]
} [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
|
|
|
|
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
|
set x [gets $f]
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unix notWsl} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
set x [format "0o%o" [expr {$stats(mode)&0o777}]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {0o600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {unix umask notWsl} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode)&0o777}]
} [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
|
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
|
fcopy $b $a -command [list geof $b]
puts stderr 2COPY
}
puts stderr ...
}
puts stderr SRV
set l {}
set srv [socket -server new 9999]
puts stderr WAITING
fileevent stdin readable bye
puts OK
vwait forever
}
# wait for OK from server.
gets $pipe
# Now the two clients.
proc ::done {sock} {
if {[eof $sock]} { close $sock ; return }
lappend ::forever [gets $sock]
return
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
|
|
>
|
|
|
|
|
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
|
fcopy $b $a -command [list geof $b]
puts stderr 2COPY
}
puts stderr ...
}
puts stderr SRV
set l {}
set srv [socket -server new -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
puts stderr WAITING
fileevent stdin readable bye
puts "OK $port"
vwait forever
}
# wait for OK from server.
lassign [gets $pipe] ok port
# Now the two clients.
proc ::done {sock} {
if {[eof $sock]} { close $sock ; return }
lappend ::forever [gets $sock]
return
}
set a [socket 127.0.0.1 $port]
set b [socket 127.0.0.1 $port]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
|