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