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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
-- !!! Testing hGetBuf(NonBlocking), hPutBuf(NonBlocking)
import System.Posix
import System.IO
import Control.Concurrent
import Foreign
import Foreign.C
import System.Exit
import Control.Exception
import Control.Monad
main = do
-- test should run quickly, but arrange to kill it if it hangs for any reason:
main_t <- myThreadId
forkIO $ do
threadDelay 10000000
throwTo main_t (ErrorCall "killed")
zipWithM_ ($)
[ f rbuf wbuf
| f <- [hGetBufTest, hGetBufNBTest, hGetBufSomeTest],
rbuf <- [buf1,buf2,buf3],
wbuf <- [buf1,buf2,buf3]
]
[1..]
msg = "hello!"
msg_length = length msg
buf1 = NoBuffering
buf2 = BlockBuffering (Just 5)
buf3 = BlockBuffering (Just 10)
-- chosen to be larger than buf2 & smaller than buf3, so that we exercise
-- all code paths:
read_size = 8 :: Int
-- ----------------------------------------------------------------------------
-- hGetBuf/hPutBuf:
-- - test that it always reads all the data that is available
-- (with buffer size <, =, > message size).
-- - test that at the EOF, it returns a short read.
-- - the writing end is using hPutBuf, with various buffer sizes, and
-- doing an hFlush at the end of each write.
hGetBufTest rbuf wbuf n = do
(read,write) <- createPipe
hread <- fdToHandle read
hwrite <- fdToHandle write
m1 <- newEmptyMVar
m2 <- newEmptyMVar
finished <- newEmptyMVar
hSetBuffering hread rbuf
hSetBuffering hwrite wbuf
forkIO (readProc m1 m2 finished hread)
writeProc m1 m2 hwrite
takeMVar finished
putStrLn ("test " ++ show n ++ " OK")
readProc :: MVar () -> MVar () -> MVar () -> Handle -> IO ()
readProc m1 m2 finished h = do
buf <- mallocBytes 20
let
loop 0 = return ()
loop n = do putMVar m2 (); takeMVar m1
r <- hGetBuf h buf msg_length
if (r /= msg_length)
then do hPutStr stderr ("error: " ++ show r)
exitFailure
else do s <- peekCStringLen (buf,r)
hPutStr stdout (show n ++ " ")
loop (n-1)
loop 100
hPutStr stdout "\n"
putMVar m2 (); takeMVar m1
r <- hGetBuf h buf read_size -- EOF, should get short read
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
r <- hGetBuf h buf read_size -- EOF, should get zero-length read
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
hClose h
putMVar finished ()
writeProc :: MVar () -> MVar () -> Handle -> IO ()
writeProc m1 m2 h = do
let
loop 0 = return ()
loop n =
withCStringLen msg $ \ (s,len) -> do
takeMVar m2
hPutBuf h s len
hFlush h
putMVar m1 ()
loop (n-1)
loop 100
takeMVar m2
withCString "end" $ \s -> do
hPutBuf h s 3
putMVar m1 ()
hClose h
-- -----------------------------------------------------------------------------
-- hGetBufNonBlocking:
hGetBufNBTest rbuf wbuf n = do
(read,write) <- createPipe
hread <- fdToHandle read
hwrite <- fdToHandle write
m1 <- newEmptyMVar
m2 <- newEmptyMVar
finished <- newEmptyMVar
hSetBuffering hread rbuf
hSetBuffering hwrite wbuf
forkIO (readProcNB m1 m2 finished hread)
writeProcNB m1 m2 hwrite
takeMVar finished
putStrLn ("test " ++ show n ++ " OK")
readProcNB :: MVar () -> MVar () -> MVar () -> Handle -> IO ()
readProcNB m1 m2 finished h = do
buf <- mallocBytes 20
-- first, test that we can do a non-blocking read:
r <- hGetBufNonBlocking h buf read_size
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
let
loop 0 = return ()
loop n = do putMVar m2 (); takeMVar m1
r <- hGetBufNonBlocking h buf read_size
if (r /= msg_length)
then do hPutStr stderr ("error: " ++ show r)
exitFailure
else do s <- peekCStringLen (buf,r)
hPutStr stdout (show n ++ " ")
loop (n-1)
loop 100
hPutStr stdout "\n"
putMVar m2 (); takeMVar m1
r <- hGetBufNonBlocking h buf read_size -- EOF, should get short read
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
r <- hGetBufNonBlocking h buf read_size -- EOF, should get zero-length read
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
hClose h
putMVar finished ()
writeProcNB :: MVar () -> MVar () -> Handle -> IO ()
writeProcNB m1 m2 h = do
let
loop 0 = return ()
loop n =
withCStringLen msg $ \ (s,len) -> do
takeMVar m2
hPutBufNonBlocking h s len
hFlush h
putMVar m1 ()
loop (n-1)
loop 100
takeMVar m2
withCString "end" $ \s -> do
hPutBuf h s 3
hFlush h
putMVar m1 ()
hClose h
-- -----------------------------------------------------------------------------
-- hGetBufSome:
hGetBufSomeTest rbuf wbuf n = do
(read,write) <- createPipe
hread <- fdToHandle read
hwrite <- fdToHandle write
m1 <- newEmptyMVar
m2 <- newEmptyMVar
finished <- newEmptyMVar
hSetBuffering hread rbuf
hSetBuffering hwrite wbuf
forkIO (readProcSome m1 m2 finished hread)
writeProcNB m1 m2 hwrite
takeMVar finished
putStrLn ("test " ++ show n ++ " OK")
readProcSome :: MVar () -> MVar () -> MVar () -> Handle -> IO ()
readProcSome m1 m2 finished h = do
buf <- mallocBytes 20
let
loop 0 = return ()
loop n = do putMVar m2 (); takeMVar m1
r <- hGetBufSome h buf read_size
if (r /= msg_length)
then do hPutStr stderr ("error: " ++ show r)
exitFailure
else do s <- peekCStringLen (buf,r)
hPutStr stdout (show n ++ " ")
loop (n-1)
loop 100
hPutStr stdout "\n"
putMVar m2 (); takeMVar m1
r <- hGetBufSome h buf read_size -- EOF, should get short read
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
r <- hGetBufSome h buf read_size -- EOF, should get zero-length read
s <- peekCStringLen (buf,r)
putStrLn ("got " ++ show r ++ ": " ++ s)
hClose h
putMVar finished ()
|
