1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
#
# select.test
#
# Tests for the select command.
#---------------------------------------------------------------------------
# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies. Karl Lehenbauer and
# Mark Diekhans make no representations about the suitability of this
# software for any purpose. It is provided "as is" without express or
# implied warranty.
#------------------------------------------------------------------------------
# $Id: select.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $
#------------------------------------------------------------------------------
#
if {[cequal [info procs Test] {}]} {
source [file join [file dirname [info script]] testlib.tcl]
}
if [cequal $tcl_platform(platform) windows] {
echo " * The select tests have not been ported to Win32"
return
}
catch {select} msg
# FIX: Should have an infox check.
if {"$msg" == "select is not available on this version of Unix"} {
echo "**** $msg"
echo "**** tests skipped"
return
}
#
# Note: The behavior of what is returned for write-ready is not consistent,
# some systems (BSD 4.4) don't return a pipe file handle that has been
# written to but not read from. This is the reason for the lsearch checks
# below.
#
pipe pipe1ReadFh pipe1WriteFh
fcntl $pipe1WriteFh nobuf 1
pipe pipe2ReadFh pipe2WriteFh
fcntl $pipe2WriteFh nobuf 1
set pipeReadList [list $pipe1ReadFh $pipe2ReadFh]
set pipeWriteList [list $pipe1WriteFh $pipe2WriteFh]
Test select-1.1 {select tests} {
select $pipeReadList $pipeWriteList {} 0.5
} 0 [list {} $pipeWriteList {}]
Test select-1.2 {select tests} {
puts $pipe1WriteFh "Written to pipe 1"
set ret [select $pipeReadList $pipeWriteList {} 0.5]
list [lindex $ret 0] \
[expr [lsearch [lindex $ret 1] $pipe2WriteFh] >= 0] \
[lindex $ret 2] \
[gets $pipe1ReadFh]
} 0 [list $pipe1ReadFh 1 {} "Written to pipe 1"]
Test select-1.3 {select tests} {
puts $pipe2WriteFh "Written to pipe 2"
set ret [select $pipeReadList $pipeWriteList {} 0.5]
list [lindex $ret 0] \
[expr [lsearch [lindex $ret 1] $pipe1WriteFh] >= 0] \
[lindex $ret 2] \
[gets $pipe2ReadFh]
} 0 [list $pipe2ReadFh 1 {} "Written to pipe 2"]
Test select-1.4 {select tests} {
puts $pipe1WriteFh "Written to pipe 1"
puts $pipe2WriteFh "Written to pipe 2"
set ret [select $pipeReadList {} {} 0.5]
list $ret [gets $pipe1ReadFh] [gets $pipe2ReadFh]
} 0 [list [list $pipeReadList {} {}] "Written to pipe 1" \
"Written to pipe 2"]
Test select-1.5 {select tests} {
select $pipeReadList $pipeWriteList {} 0
} 0 [list {} $pipeWriteList {}]
Test select-1.6 {select tests} {
puts $pipe1WriteFh "Written to pipe 1"
set ret [select $pipeReadList $pipeWriteList]
list [lindex $ret 0] \
[expr [lsearch [lindex $ret 1] $pipe2WriteFh] >= 0] \
[lindex $ret 2] \
[gets $pipe1ReadFh]
} 0 [list $pipe1ReadFh 1 {} "Written to pipe 1"]
Test select-1.7 {select tests} {
puts $pipe1WriteFh "Written to pipe 1"
set ret [select $pipeReadList $pipeWriteList {} 0]
list [lindex $ret 0] \
[expr [lsearch [lindex $ret 1] $pipe2WriteFh] >= 0] \
[lindex $ret 2] \
[gets $pipe1ReadFh]
} 0 [list $pipe1ReadFh 1 {} "Written to pipe 1"]
Test select-1.8 {select tests} {
puts $pipe1WriteFh "Written to pipe 1 #1"
puts $pipe1WriteFh "Written to pipe 1 #2"
set ret1 [select $pipeReadList {} {} 0]
set data1 [gets $pipe1ReadFh]
set ret2 [select $pipeReadList {} {} 0]
set data2 [gets $pipe1ReadFh]
list $ret1 $data1 $ret2 $data2
} 0 [list [list $pipe1ReadFh {} {}] "Written to pipe 1 #1" \
[list $pipe1ReadFh {} {}] "Written to pipe 1 #2"]
Test select-2.1 {select tests} {
select foo $pipeWriteList {} 0
} 1 {can not find channel named "foo"}
Test select-2.2 {select tests} {
select $pipeReadList $pipeWriteList {} X
} 1 {expected floating-point number but got "X"}
# cleanup
::tcltest::cleanupTests
return
|
