[project @ 2003-09-23 18:59:43 by sof]
[packages/old-time.git] / GHC / IO.hs
1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
2
3 #undef DEBUG_DUMP
4
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module : GHC.IO
8 -- Copyright : (c) The University of Glasgow, 1992-2001
9 -- License : see libraries/base/LICENSE
10 --
11 -- Maintainer : libraries@haskell.org
12 -- Stability : internal
13 -- Portability : non-portable
14 --
15 -- String I\/O functions
16 --
17 -----------------------------------------------------------------------------
18
19 module GHC.IO (
20 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
21 commitBuffer', -- hack, see below
22 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
23 hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
24 {- NOTE: As far as I can tell, not defined.
25 createPipe, createPipeEx,
26 -}
27 memcpy_ba_baoff,
28 memcpy_ptr_baoff,
29 memcpy_baoff_ba,
30 memcpy_baoff_ptr,
31 ) where
32
33 #include "config.h"
34
35 import Foreign
36 import Foreign.C
37
38 import System.IO.Error
39 import Data.Maybe
40 import Control.Monad
41 import System.Posix.Internals
42
43 import GHC.Enum
44 import GHC.Base
45 import GHC.IOBase
46 import GHC.Handle -- much of the real stuff is in here
47 import GHC.Real
48 import GHC.Num
49 import GHC.Show
50 import GHC.List
51 import GHC.Exception ( ioError, catch )
52 import GHC.Conc
53
54 -- ---------------------------------------------------------------------------
55 -- Simple input operations
56
57 -- If hWaitForInput finds anything in the Handle's buffer, it
58 -- immediately returns. If not, it tries to read from the underlying
59 -- OS handle. Notice that for buffered Handles connected to terminals
60 -- this means waiting until a complete line is available.
61
62 -- | Computation 'hWaitForInput' @hdl t@
63 -- waits until input is available on handle @hdl@.
64 -- It returns 'True' as soon as input is available on @hdl@,
65 -- or 'False' if no input is available within @t@ milliseconds.
66 --
67 -- This operation may fail with:
68 --
69 -- * 'isEOFError' if the end of file has been reached.
70
71 hWaitForInput :: Handle -> Int -> IO Bool
72 hWaitForInput h msecs = do
73 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
74 let ref = haBuffer handle_
75 buf <- readIORef ref
76
77 if not (bufferEmpty buf)
78 then return True
79 else do
80
81 r <- throwErrnoIfMinus1Retry "hWaitForInput"
82 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
83 return (r /= 0)
84
85 foreign import ccall unsafe "inputReady"
86 inputReady :: CInt -> CInt -> Bool -> IO CInt
87
88 -- ---------------------------------------------------------------------------
89 -- hGetChar
90
91 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
92 -- channel managed by @hdl@, blocking until a character is available.
93 --
94 -- This operation may fail with:
95 --
96 -- * 'isEOFError' if the end of file has been reached.
97
98 hGetChar :: Handle -> IO Char
99 hGetChar handle =
100 wantReadableHandle "hGetChar" handle $ \handle_ -> do
101
102 let fd = haFD handle_
103 ref = haBuffer handle_
104
105 buf <- readIORef ref
106 if not (bufferEmpty buf)
107 then hGetcBuffered fd ref buf
108 else do
109
110 -- buffer is empty.
111 case haBufferMode handle_ of
112 LineBuffering -> do
113 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
114 hGetcBuffered fd ref new_buf
115 BlockBuffering _ -> do
116 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
117 -- ^^^^
118 -- don't wait for a completely full buffer.
119 hGetcBuffered fd ref new_buf
120 NoBuffering -> do
121 -- make use of the minimal buffer we already have
122 let raw = bufBuf buf
123 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
124 if r == 0
125 then ioe_EOF
126 else do (c,_) <- readCharFromBuffer raw 0
127 return c
128
129 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
130 = do (c,r) <- readCharFromBuffer b r
131 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
132 | otherwise = buf{ bufRPtr=r }
133 writeIORef ref new_buf
134 return c
135
136 -- ---------------------------------------------------------------------------
137 -- hGetLine
138
139 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
140 -- the duration.
141
142 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
143 -- channel managed by @hdl@.
144 --
145 -- This operation may fail with:
146 --
147 -- * 'isEOFError' if the end of file is encountered when reading
148 -- the /first/ character of the line.
149 --
150 -- If 'hGetLine' encounters end-of-file at any other point while reading
151 -- in a line, it is treated as a line terminator and the (partial)
152 -- line is returned.
153
154 hGetLine :: Handle -> IO String
155 hGetLine h = do
156 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
157 case haBufferMode handle_ of
158 NoBuffering -> return Nothing
159 LineBuffering -> do
160 l <- hGetLineBuffered handle_
161 return (Just l)
162 BlockBuffering _ -> do
163 l <- hGetLineBuffered handle_
164 return (Just l)
165 case m of
166 Nothing -> hGetLineUnBuffered h
167 Just l -> return l
168
169
170 hGetLineBuffered handle_ = do
171 let ref = haBuffer handle_
172 buf <- readIORef ref
173 hGetLineBufferedLoop handle_ ref buf []
174
175
176 hGetLineBufferedLoop handle_ ref
177 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
178 let
179 -- find the end-of-line character, if there is one
180 loop raw r
181 | r == w = return (False, w)
182 | otherwise = do
183 (c,r') <- readCharFromBuffer raw r
184 if c == '\n'
185 then return (True, r) -- NB. not r': don't include the '\n'
186 else loop raw r'
187 in do
188 (eol, off) <- loop raw r
189
190 #ifdef DEBUG_DUMP
191 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
192 #endif
193
194 xs <- unpack raw r off
195
196 -- if eol == True, then off is the offset of the '\n'
197 -- otherwise off == w and the buffer is now empty.
198 if eol
199 then do if (w == off + 1)
200 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
201 else writeIORef ref buf{ bufRPtr = off + 1 }
202 return (concat (reverse (xs:xss)))
203 else do
204 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
205 buf{ bufWPtr=0, bufRPtr=0 }
206 case maybe_buf of
207 -- Nothing indicates we caught an EOF, and we may have a
208 -- partial line to return.
209 Nothing -> do
210 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
211 let str = concat (reverse (xs:xss))
212 if not (null str)
213 then return str
214 else ioe_EOF
215 Just new_buf ->
216 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
217
218
219 maybeFillReadBuffer fd is_line is_stream buf
220 = catch
221 (do buf <- fillReadBuffer fd is_line is_stream buf
222 return (Just buf)
223 )
224 (\e -> do if isEOFError e
225 then return Nothing
226 else ioError e)
227
228
229 unpack :: RawBuffer -> Int -> Int -> IO [Char]
230 unpack buf r 0 = return ""
231 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
232 where
233 unpack acc i s
234 | i <# r = (# s, acc #)
235 | otherwise =
236 case readCharArray# buf i s of
237 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
238
239
240 hGetLineUnBuffered :: Handle -> IO String
241 hGetLineUnBuffered h = do
242 c <- hGetChar h
243 if c == '\n' then
244 return ""
245 else do
246 l <- getRest
247 return (c:l)
248 where
249 getRest = do
250 c <-
251 catch
252 (hGetChar h)
253 (\ err -> do
254 if isEOFError err then
255 return '\n'
256 else
257 ioError err)
258 if c == '\n' then
259 return ""
260 else do
261 s <- getRest
262 return (c:s)
263
264 -- -----------------------------------------------------------------------------
265 -- hGetContents
266
267 -- hGetContents on a DuplexHandle only affects the read side: you can
268 -- carry on writing to it afterwards.
269
270 -- | Computation 'hGetContents' @hdl@ returns the list of characters
271 -- corresponding to the unread portion of the channel or file managed
272 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
273 -- In this state, @hdl@ is effectively closed,
274 -- but items are read from @hdl@ on demand and accumulated in a special
275 -- list returned by 'hGetContents' @hdl@.
276 --
277 -- Any operation that fails because a handle is closed,
278 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
279 -- A semi-closed handle becomes closed:
280 --
281 -- * if 'hClose' is applied to it;
282 --
283 -- * if an I\/O error occurs when reading an item from the handle;
284 --
285 -- * or once the entire contents of the handle has been read.
286 --
287 -- Once a semi-closed handle becomes closed, the contents of the
288 -- associated list becomes fixed. The contents of this final list is
289 -- only partially specified: it will contain at least all the items of
290 -- the stream that were evaluated prior to the handle becoming closed.
291 --
292 -- Any I\/O errors encountered while a handle is semi-closed are simply
293 -- discarded.
294 --
295 -- This operation may fail with:
296 --
297 -- * 'isEOFError' if the end of file has been reached.
298
299 hGetContents :: Handle -> IO String
300 hGetContents handle =
301 withHandle "hGetContents" handle $ \handle_ ->
302 case haType handle_ of
303 ClosedHandle -> ioe_closedHandle
304 SemiClosedHandle -> ioe_closedHandle
305 AppendHandle -> ioe_notReadable
306 WriteHandle -> ioe_notReadable
307 _ -> do xs <- lazyRead handle
308 return (handle_{ haType=SemiClosedHandle}, xs )
309
310 -- Note that someone may close the semi-closed handle (or change its
311 -- buffering), so each time these lazy read functions are pulled on,
312 -- they have to check whether the handle has indeed been closed.
313
314 lazyRead :: Handle -> IO String
315 lazyRead handle =
316 unsafeInterleaveIO $
317 withHandle "lazyRead" handle $ \ handle_ -> do
318 case haType handle_ of
319 ClosedHandle -> return (handle_, "")
320 SemiClosedHandle -> lazyRead' handle handle_
321 _ -> ioException
322 (IOError (Just handle) IllegalOperation "lazyRead"
323 "illegal handle type" Nothing)
324
325 lazyRead' h handle_ = do
326 let ref = haBuffer handle_
327 fd = haFD handle_
328
329 -- even a NoBuffering handle can have a char in the buffer...
330 -- (see hLookAhead)
331 buf <- readIORef ref
332 if not (bufferEmpty buf)
333 then lazyReadHaveBuffer h handle_ fd ref buf
334 else do
335
336 case haBufferMode handle_ of
337 NoBuffering -> do
338 -- make use of the minimal buffer we already have
339 let raw = bufBuf buf
340 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
341 if r == 0
342 then do handle_ <- hClose_help handle_
343 return (handle_, "")
344 else do (c,_) <- readCharFromBuffer raw 0
345 rest <- lazyRead h
346 return (handle_, c : rest)
347
348 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
349 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
350
351 -- we never want to block during the read, so we call fillReadBuffer with
352 -- is_line==True, which tells it to "just read what there is".
353 lazyReadBuffered h handle_ fd ref buf = do
354 catch
355 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
356 lazyReadHaveBuffer h handle_ fd ref buf
357 )
358 -- all I/O errors are discarded. Additionally, we close the handle.
359 (\e -> do handle_ <- hClose_help handle_
360 return (handle_, "")
361 )
362
363 lazyReadHaveBuffer h handle_ fd ref buf = do
364 more <- lazyRead h
365 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
366 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
367 return (handle_, s)
368
369
370 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
371 unpackAcc buf r 0 acc = return acc
372 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
373 where
374 unpack acc i s
375 | i <# r = (# s, acc #)
376 | otherwise =
377 case readCharArray# buf i s of
378 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
379
380 -- ---------------------------------------------------------------------------
381 -- hPutChar
382
383 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
384 -- file or channel managed by @hdl@. Characters may be buffered if
385 -- buffering is enabled for @hdl@.
386 --
387 -- This operation may fail with:
388 --
389 -- * 'isFullError' if the device is full; or
390 --
391 -- * 'isPermissionError' if another system resource limit would be exceeded.
392
393 hPutChar :: Handle -> Char -> IO ()
394 hPutChar handle c =
395 c `seq` do -- must evaluate c before grabbing the handle lock
396 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
397 let fd = haFD handle_
398 case haBufferMode handle_ of
399 LineBuffering -> hPutcBuffered handle_ True c
400 BlockBuffering _ -> hPutcBuffered handle_ False c
401 NoBuffering ->
402 withObject (castCharToCChar c) $ \buf -> do
403 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
404 return ()
405
406 hPutcBuffered handle_ is_line c = do
407 let ref = haBuffer handle_
408 buf <- readIORef ref
409 let w = bufWPtr buf
410 w' <- writeCharIntoBuffer (bufBuf buf) w c
411 let new_buf = buf{ bufWPtr = w' }
412 if bufferFull new_buf || is_line && c == '\n'
413 then do
414 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
415 writeIORef ref flushed_buf
416 else do
417 writeIORef ref new_buf
418
419
420 hPutChars :: Handle -> [Char] -> IO ()
421 hPutChars handle [] = return ()
422 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
423
424 -- ---------------------------------------------------------------------------
425 -- hPutStr
426
427 -- We go to some trouble to avoid keeping the handle locked while we're
428 -- evaluating the string argument to hPutStr, in case doing so triggers another
429 -- I/O operation on the same handle which would lead to deadlock. The classic
430 -- case is
431 --
432 -- putStr (trace "hello" "world")
433 --
434 -- so the basic scheme is this:
435 --
436 -- * copy the string into a fresh buffer,
437 -- * "commit" the buffer to the handle.
438 --
439 -- Committing may involve simply copying the contents of the new
440 -- buffer into the handle's buffer, flushing one or both buffers, or
441 -- maybe just swapping the buffers over (if the handle's buffer was
442 -- empty). See commitBuffer below.
443
444 -- | Computation 'hPutStr' @hdl s@ writes the string
445 -- @s@ to the file or channel managed by @hdl@.
446 --
447 -- This operation may fail with:
448 --
449 -- * 'isFullError' if the device is full; or
450 --
451 -- * 'isPermissionError' if another system resource limit would be exceeded.
452
453 hPutStr :: Handle -> String -> IO ()
454 hPutStr handle str = do
455 buffer_mode <- wantWritableHandle "hPutStr" handle
456 (\ handle_ -> do getSpareBuffer handle_)
457 case buffer_mode of
458 (NoBuffering, _) -> do
459 hPutChars handle str -- v. slow, but we don't care
460 (LineBuffering, buf) -> do
461 writeLines handle buf str
462 (BlockBuffering _, buf) -> do
463 writeBlocks handle buf str
464
465
466 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
467 getSpareBuffer Handle__{haBuffer=ref,
468 haBuffers=spare_ref,
469 haBufferMode=mode}
470 = do
471 case mode of
472 NoBuffering -> return (mode, error "no buffer!")
473 _ -> do
474 bufs <- readIORef spare_ref
475 buf <- readIORef ref
476 case bufs of
477 BufferListCons b rest -> do
478 writeIORef spare_ref rest
479 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
480 BufferListNil -> do
481 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
482 return (mode, new_buf)
483
484
485 writeLines :: Handle -> Buffer -> String -> IO ()
486 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
487 let
488 shoveString :: Int -> [Char] -> IO ()
489 -- check n == len first, to ensure that shoveString is strict in n.
490 shoveString n cs | n == len = do
491 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
492 writeLines hdl new_buf cs
493 shoveString n [] = do
494 commitBuffer hdl raw len n False{-no flush-} True{-release-}
495 return ()
496 shoveString n (c:cs) = do
497 n' <- writeCharIntoBuffer raw n c
498 if (c == '\n')
499 then do
500 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
501 writeLines hdl new_buf cs
502 else
503 shoveString n' cs
504 in
505 shoveString 0 s
506
507 writeBlocks :: Handle -> Buffer -> String -> IO ()
508 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
509 let
510 shoveString :: Int -> [Char] -> IO ()
511 -- check n == len first, to ensure that shoveString is strict in n.
512 shoveString n cs | n == len = do
513 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
514 writeBlocks hdl new_buf cs
515 shoveString n [] = do
516 commitBuffer hdl raw len n False{-no flush-} True{-release-}
517 return ()
518 shoveString n (c:cs) = do
519 n' <- writeCharIntoBuffer raw n c
520 shoveString n' cs
521 in
522 shoveString 0 s
523
524 -- -----------------------------------------------------------------------------
525 -- commitBuffer handle buf sz count flush release
526 --
527 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
528 -- 'count' bytes of data) to handle (handle must be block or line buffered).
529 --
530 -- Implementation:
531 --
532 -- for block/line buffering,
533 -- 1. If there isn't room in the handle buffer, flush the handle
534 -- buffer.
535 --
536 -- 2. If the handle buffer is empty,
537 -- if flush,
538 -- then write buf directly to the device.
539 -- else swap the handle buffer with buf.
540 --
541 -- 3. If the handle buffer is non-empty, copy buf into the
542 -- handle buffer. Then, if flush != 0, flush
543 -- the buffer.
544
545 commitBuffer
546 :: Handle -- handle to commit to
547 -> RawBuffer -> Int -- address and size (in bytes) of buffer
548 -> Int -- number of bytes of data in buffer
549 -> Bool -- True <=> flush the handle afterward
550 -> Bool -- release the buffer?
551 -> IO Buffer
552
553 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
554 wantWritableHandle "commitAndReleaseBuffer" hdl $
555 commitBuffer' hdl raw sz count flush release
556
557 -- Explicitly lambda-lift this function to subvert GHC's full laziness
558 -- optimisations, which otherwise tends to float out subexpressions
559 -- past the \handle, which is really a pessimisation in this case because
560 -- that lambda is a one-shot lambda.
561 --
562 -- Don't forget to export the function, to stop it being inlined too
563 -- (this appears to be better than NOINLINE, because the strictness
564 -- analyser still gets to worker-wrapper it).
565 --
566 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
567 --
568 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
569 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
570
571 #ifdef DEBUG_DUMP
572 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
573 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
574 #endif
575
576 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
577 <- readIORef ref
578
579 buf_ret <-
580 -- enough room in handle buffer?
581 if (not flush && (size - w > count))
582 -- The > is to be sure that we never exactly fill
583 -- up the buffer, which would require a flush. So
584 -- if copying the new data into the buffer would
585 -- make the buffer full, we just flush the existing
586 -- buffer and the new data immediately, rather than
587 -- copying before flushing.
588
589 -- not flushing, and there's enough room in the buffer:
590 -- just copy the data in and update bufWPtr.
591 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
592 writeIORef ref old_buf{ bufWPtr = w + count }
593 return (newEmptyBuffer raw WriteBuffer sz)
594
595 -- else, we have to flush
596 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
597
598 let this_buf =
599 Buffer{ bufBuf=raw, bufState=WriteBuffer,
600 bufRPtr=0, bufWPtr=count, bufSize=sz }
601
602 -- if: (a) we don't have to flush, and
603 -- (b) size(new buffer) == size(old buffer), and
604 -- (c) new buffer is not full,
605 -- we can just just swap them over...
606 if (not flush && sz == size && count /= sz)
607 then do
608 writeIORef ref this_buf
609 return flushed_buf
610
611 -- otherwise, we have to flush the new data too,
612 -- and start with a fresh buffer
613 else do
614 flushWriteBuffer fd (haIsStream handle_) this_buf
615 writeIORef ref flushed_buf
616 -- if the sizes were different, then allocate
617 -- a new buffer of the correct size.
618 if sz == size
619 then return (newEmptyBuffer raw WriteBuffer sz)
620 else allocateBuffer size WriteBuffer
621
622 -- release the buffer if necessary
623 case buf_ret of
624 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
625 if release && buf_ret_sz == size
626 then do
627 spare_bufs <- readIORef spare_buf_ref
628 writeIORef spare_buf_ref
629 (BufferListCons buf_ret_raw spare_bufs)
630 return buf_ret
631 else
632 return buf_ret
633
634 -- ---------------------------------------------------------------------------
635 -- Reading/writing sequences of bytes.
636
637 -- ---------------------------------------------------------------------------
638 -- hPutBuf
639
640 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
641 -- buffer @buf@ to the handle @hdl@. It returns ().
642 --
643 -- This operation may fail with:
644 --
645 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
646 -- reading end is closed. (If this is a POSIX system, and the program
647 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
648 -- instead, whose default action is to terminate the program).
649
650 hPutBuf :: Handle -- handle to write to
651 -> Ptr a -- address of buffer
652 -> Int -- number of bytes of data in buffer
653 -> IO ()
654 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
655
656 hPutBufNonBlocking
657 :: Handle -- handle to write to
658 -> Ptr a -- address of buffer
659 -> Int -- number of bytes of data in buffer
660 -> IO Int -- returns: number of bytes written
661 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
662
663 hPutBuf':: Handle -- handle to write to
664 -> Ptr a -- address of buffer
665 -> Int -- number of bytes of data in buffer
666 -> Bool -- allow blocking?
667 -> IO Int
668 hPutBuf' handle ptr count can_block
669 | count == 0 = return 0
670 | count < 0 = illegalBufferSize handle "hPutBuf" count
671 | otherwise =
672 wantWritableHandle "hPutBuf" handle $
673 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
674 bufWrite fd ref is_stream ptr count can_block
675
676 bufWrite fd ref is_stream ptr count can_block =
677 seq count $ seq fd $ do -- strictness hack
678 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
679 <- readIORef ref
680
681 -- enough room in handle buffer?
682 if (size - w > count)
683 -- There's enough room in the buffer:
684 -- just copy the data in and update bufWPtr.
685 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
686 writeIORef ref old_buf{ bufWPtr = w + count }
687 return count
688
689 -- else, we have to flush
690 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
691 writeIORef ref flushed_buf
692 -- if we can fit in the buffer, then just loop
693 if count < size
694 then bufWrite fd ref is_stream ptr count can_block
695 else if can_block
696 then do writeChunk fd is_stream (castPtr ptr) count
697 return count
698 else writeChunkNonBlocking fd is_stream ptr count
699
700 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
701 writeChunk fd is_stream ptr bytes = loop 0 bytes
702 where
703 loop :: Int -> Int -> IO ()
704 loop _ bytes | bytes <= 0 = return ()
705 loop off bytes = do
706 r <- fromIntegral `liftM`
707 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
708 off (fromIntegral bytes)
709 -- write can't return 0
710 loop (off + r) (bytes - r)
711
712 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
713 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
714 where
715 loop :: Int -> Int -> IO Int
716 loop off bytes | bytes <= 0 = return off
717 loop off bytes = do
718 #ifndef mingw32_TARGET_OS
719 ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
720 let r = fromIntegral ssize :: Int
721 if (r == -1)
722 then do errno <- getErrno
723 if (errno == eAGAIN || errno == eWOULDBLOCK)
724 then return off
725 else throwErrno "writeChunk"
726 else loop (off + r) (bytes - r)
727 #else
728 (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
729 (fromIntegral bytes)
730 (ptr `plusPtr` off)
731 let r = fromIntegral ssize :: Int
732 if r == (-1)
733 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
734 else loop (off + r) (bytes - r)
735 #endif
736
737 -- ---------------------------------------------------------------------------
738 -- hGetBuf
739
740 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
741 -- into the buffer @buf@ until either EOF is reached or
742 -- @count@ 8-bit bytes have been read.
743 -- It returns the number of bytes actually read. This may be zero if
744 -- EOF was reached before any data was read (or if @count@ is zero).
745 --
746 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
747 -- smaller than @count@.
748 --
749 -- If the handle is a pipe or socket, and the writing end
750 -- is closed, 'hGetBuf' will behave as if EOF was reached.
751
752 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
753 hGetBuf h ptr count = hGetBuf' h ptr count True
754
755 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
756 hGetBufNonBlocking h ptr count = hGetBuf' h ptr count False
757
758 hGetBuf' :: Handle -> Ptr a -> Int -> Bool -> IO Int
759 hGetBuf' handle ptr count can_block
760 | count == 0 = return 0
761 | count < 0 = illegalBufferSize handle "hGetBuf" count
762 | otherwise =
763 wantReadableHandle "hGetBuf" handle $
764 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
765 bufRead fd ref is_stream ptr 0 count can_block
766
767 bufRead fd ref is_stream ptr so_far count can_block =
768 seq fd $ seq so_far $ seq count $ do -- strictness hack
769 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
770 if bufferEmpty buf
771 then if count < sz
772 then do
773 mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf
774 case mb_buf of
775 Nothing -> return 0
776 Just new_buf -> do
777 writeIORef ref new_buf
778 bufRead fd ref is_stream ptr so_far count can_block
779 else if can_block
780 then readChunk fd is_stream ptr count
781 else readChunkNonBlocking fd is_stream ptr count
782 else do
783 let avail = w - r
784 if (count == avail)
785 then do
786 memcpy_ptr_baoff ptr raw r (fromIntegral count)
787 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
788 return (so_far + count)
789 else do
790 if (count < avail)
791 then do
792 memcpy_ptr_baoff ptr raw r (fromIntegral count)
793 writeIORef ref buf{ bufRPtr = r + count }
794 return (so_far + count)
795 else do
796
797 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
798 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
799
800 let remaining = count - avail
801 so_far' = so_far + avail
802 ptr' = ptr `plusPtr` avail
803
804 if remaining < sz
805 then bufRead fd ref is_stream ptr' so_far' remaining can_block
806 else do
807
808 rest <- if can_block
809 then readChunk fd is_stream ptr' remaining
810 else readChunkNonBlocking fd is_stream ptr' remaining
811 return (so_far' + rest)
812
813 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
814 readChunk fd is_stream ptr bytes = loop 0 bytes
815 where
816 loop :: Int -> Int -> IO Int
817 loop off bytes | bytes <= 0 = return off
818 loop off bytes = do
819 r <- fromIntegral `liftM`
820 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
821 (castPtr ptr) off (fromIntegral bytes)
822 if r == 0
823 then return off
824 else loop (off + r) (bytes - r)
825
826 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
827 readChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
828 where
829 loop :: Int -> Int -> IO Int
830 loop off bytes | bytes <= 0 = return off
831 loop off bytes = do
832 #ifndef mingw32_TARGET_OS
833 ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
834 let r = fromIntegral ssize :: Int
835 if (r == -1)
836 then do errno <- getErrno
837 if (errno == eAGAIN || errno == eWOULDBLOCK)
838 then return off
839 else throwErrno "readChunk"
840 else if (r == 0)
841 then return off
842 else loop (off + r) (bytes - r)
843 #else
844 (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
845 (fromIntegral bytes)
846 (ptr `plusPtr` off)
847 let r = fromIntegral ssize :: Int
848 if r == (-1)
849 then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
850 else if (r == 0)
851 then return off
852 else loop (off + r) (bytes - r)
853 #endif
854
855 slurpFile :: FilePath -> IO (Ptr (), Int)
856 slurpFile fname = do
857 handle <- openFile fname ReadMode
858 sz <- hFileSize handle
859 if sz > fromIntegral (maxBound::Int) then
860 ioError (userError "slurpFile: file too big")
861 else do
862 let sz_i = fromIntegral sz
863 if sz_i == 0 then return (nullPtr, 0) else do
864 chunk <- mallocBytes sz_i
865 r <- hGetBuf handle chunk sz_i
866 hClose handle
867 return (chunk, r)
868
869 -- ---------------------------------------------------------------------------
870 -- memcpy wrappers
871
872 foreign import ccall unsafe "__hscore_memcpy_src_off"
873 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
874 foreign import ccall unsafe "__hscore_memcpy_src_off"
875 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
876 foreign import ccall unsafe "__hscore_memcpy_dst_off"
877 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
878 foreign import ccall unsafe "__hscore_memcpy_dst_off"
879 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
880
881 -----------------------------------------------------------------------------
882 -- Internal Utils
883
884 illegalBufferSize :: Handle -> String -> Int -> IO a
885 illegalBufferSize handle fn (sz :: Int) =
886 ioException (IOError (Just handle)
887 InvalidArgument fn
888 ("illegal buffer size " ++ showsPrec 9 sz [])
889 Nothing)