1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
5 -----------------------------------------------------------------------------
8 -- Copyright : (c) The University of Glasgow, 1992-2001
9 -- License : see libraries/base/LICENSE
11 -- Maintainer : libraries@haskell.org
12 -- Stability : internal
13 -- Portability : non-portable
15 -- String I\/O functions
17 -----------------------------------------------------------------------------
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,
35 import System.IO.Error
38 import System.Posix.Internals
43 import GHC.Handle -- much of the real stuff is in here
48 import GHC.Exception ( ioError, catch )
50 -- ---------------------------------------------------------------------------
51 -- Simple input operations
53 -- If hWaitForInput finds anything in the Handle's buffer, it
54 -- immediately returns. If not, it tries to read from the underlying
55 -- OS handle. Notice that for buffered Handles connected to terminals
56 -- this means waiting until a complete line is available.
58 -- | Computation 'hWaitForInput' @hdl t@
59 -- waits until input is available on handle @hdl@.
60 -- It returns 'True' as soon as input is available on @hdl@,
61 -- or 'False' if no input is available within @t@ milliseconds.
63 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
64 -- NOTE: in the current implementation, this is the only case that works
65 -- correctly (if @t@ is non-zero, then all other concurrent threads are
66 -- blocked until data is available).
68 -- This operation may fail with:
70 -- * 'isEOFError' if the end of file has been reached.
72 hWaitForInput :: Handle -> Int -> IO Bool
73 hWaitForInput h msecs = do
74 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
75 let ref = haBuffer handle_
78 if not (bufferEmpty buf)
83 then do buf' <- fillReadBuffer (haFD handle_) True
84 (haIsStream handle_) buf
87 else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
88 inputReady (fromIntegral (haFD handle_))
89 (fromIntegral msecs) (haIsStream handle_)
92 foreign import ccall unsafe "inputReady"
93 inputReady :: CInt -> CInt -> Bool -> IO CInt
95 -- ---------------------------------------------------------------------------
98 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
99 -- channel managed by @hdl@, blocking until a character is available.
101 -- This operation may fail with:
103 -- * 'isEOFError' if the end of file has been reached.
105 hGetChar :: Handle -> IO Char
107 wantReadableHandle "hGetChar" handle $ \handle_ -> do
109 let fd = haFD handle_
110 ref = haBuffer handle_
113 if not (bufferEmpty buf)
114 then hGetcBuffered fd ref buf
118 case haBufferMode handle_ of
120 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
121 hGetcBuffered fd ref new_buf
122 BlockBuffering _ -> do
123 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
125 -- don't wait for a completely full buffer.
126 hGetcBuffered fd ref new_buf
128 -- make use of the minimal buffer we already have
130 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
133 else do (c,_) <- readCharFromBuffer raw 0
136 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
137 = do (c,r) <- readCharFromBuffer b r
138 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
139 | otherwise = buf{ bufRPtr=r }
140 writeIORef ref new_buf
143 -- ---------------------------------------------------------------------------
146 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
149 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
150 -- channel managed by @hdl@.
152 -- This operation may fail with:
154 -- * 'isEOFError' if the end of file is encountered when reading
155 -- the /first/ character of the line.
157 -- If 'hGetLine' encounters end-of-file at any other point while reading
158 -- in a line, it is treated as a line terminator and the (partial)
161 hGetLine :: Handle -> IO String
163 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
164 case haBufferMode handle_ of
165 NoBuffering -> return Nothing
167 l <- hGetLineBuffered handle_
169 BlockBuffering _ -> do
170 l <- hGetLineBuffered handle_
173 Nothing -> hGetLineUnBuffered h
177 hGetLineBuffered handle_ = do
178 let ref = haBuffer handle_
180 hGetLineBufferedLoop handle_ ref buf []
183 hGetLineBufferedLoop handle_ ref
184 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
186 -- find the end-of-line character, if there is one
188 | r == w = return (False, w)
190 (c,r') <- readCharFromBuffer raw r
192 then return (True, r) -- NB. not r': don't include the '\n'
195 (eol, off) <- loop raw r
198 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
201 xs <- unpack raw r off
203 -- if eol == True, then off is the offset of the '\n'
204 -- otherwise off == w and the buffer is now empty.
206 then do if (w == off + 1)
207 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
208 else writeIORef ref buf{ bufRPtr = off + 1 }
209 return (concat (reverse (xs:xss)))
211 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
212 buf{ bufWPtr=0, bufRPtr=0 }
214 -- Nothing indicates we caught an EOF, and we may have a
215 -- partial line to return.
217 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
218 let str = concat (reverse (xs:xss))
223 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
226 maybeFillReadBuffer fd is_line is_stream buf
228 (do buf <- fillReadBuffer fd is_line is_stream buf
231 (\e -> do if isEOFError e
236 unpack :: RawBuffer -> Int -> Int -> IO [Char]
237 unpack buf r 0 = return ""
238 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
241 | i <# r = (# s, acc #)
243 case readCharArray# buf i s of
244 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
247 hGetLineUnBuffered :: Handle -> IO String
248 hGetLineUnBuffered h = do
261 if isEOFError err then
271 -- -----------------------------------------------------------------------------
274 -- hGetContents on a DuplexHandle only affects the read side: you can
275 -- carry on writing to it afterwards.
277 -- | Computation 'hGetContents' @hdl@ returns the list of characters
278 -- corresponding to the unread portion of the channel or file managed
279 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
280 -- In this state, @hdl@ is effectively closed,
281 -- but items are read from @hdl@ on demand and accumulated in a special
282 -- list returned by 'hGetContents' @hdl@.
284 -- Any operation that fails because a handle is closed,
285 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
286 -- A semi-closed handle becomes closed:
288 -- * if 'hClose' is applied to it;
290 -- * if an I\/O error occurs when reading an item from the handle;
292 -- * or once the entire contents of the handle has been read.
294 -- Once a semi-closed handle becomes closed, the contents of the
295 -- associated list becomes fixed. The contents of this final list is
296 -- only partially specified: it will contain at least all the items of
297 -- the stream that were evaluated prior to the handle becoming closed.
299 -- Any I\/O errors encountered while a handle is semi-closed are simply
302 -- This operation may fail with:
304 -- * 'isEOFError' if the end of file has been reached.
306 hGetContents :: Handle -> IO String
307 hGetContents handle =
308 withHandle "hGetContents" handle $ \handle_ ->
309 case haType handle_ of
310 ClosedHandle -> ioe_closedHandle
311 SemiClosedHandle -> ioe_closedHandle
312 AppendHandle -> ioe_notReadable
313 WriteHandle -> ioe_notReadable
314 _ -> do xs <- lazyRead handle
315 return (handle_{ haType=SemiClosedHandle}, xs )
317 -- Note that someone may close the semi-closed handle (or change its
318 -- buffering), so each time these lazy read functions are pulled on,
319 -- they have to check whether the handle has indeed been closed.
321 lazyRead :: Handle -> IO String
324 withHandle "lazyRead" handle $ \ handle_ -> do
325 case haType handle_ of
326 ClosedHandle -> return (handle_, "")
327 SemiClosedHandle -> lazyRead' handle handle_
329 (IOError (Just handle) IllegalOperation "lazyRead"
330 "illegal handle type" Nothing)
332 lazyRead' h handle_ = do
333 let ref = haBuffer handle_
336 -- even a NoBuffering handle can have a char in the buffer...
339 if not (bufferEmpty buf)
340 then lazyReadHaveBuffer h handle_ fd ref buf
343 case haBufferMode handle_ of
345 -- make use of the minimal buffer we already have
347 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
349 then do handle_ <- hClose_help handle_
351 else do (c,_) <- readCharFromBuffer raw 0
353 return (handle_, c : rest)
355 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
356 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
358 -- we never want to block during the read, so we call fillReadBuffer with
359 -- is_line==True, which tells it to "just read what there is".
360 lazyReadBuffered h handle_ fd ref buf = do
362 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
363 lazyReadHaveBuffer h handle_ fd ref buf
365 -- all I/O errors are discarded. Additionally, we close the handle.
366 (\e -> do handle_ <- hClose_help handle_
370 lazyReadHaveBuffer h handle_ fd ref buf = do
372 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
373 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
377 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
378 unpackAcc buf r 0 acc = return acc
379 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
382 | i <# r = (# s, acc #)
384 case readCharArray# buf i s of
385 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
387 -- ---------------------------------------------------------------------------
390 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
391 -- file or channel managed by @hdl@. Characters may be buffered if
392 -- buffering is enabled for @hdl@.
394 -- This operation may fail with:
396 -- * 'isFullError' if the device is full; or
398 -- * 'isPermissionError' if another system resource limit would be exceeded.
400 hPutChar :: Handle -> Char -> IO ()
402 c `seq` do -- must evaluate c before grabbing the handle lock
403 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
404 let fd = haFD handle_
405 case haBufferMode handle_ of
406 LineBuffering -> hPutcBuffered handle_ True c
407 BlockBuffering _ -> hPutcBuffered handle_ False c
409 withObject (castCharToCChar c) $ \buf -> do
410 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
413 hPutcBuffered handle_ is_line c = do
414 let ref = haBuffer handle_
417 w' <- writeCharIntoBuffer (bufBuf buf) w c
418 let new_buf = buf{ bufWPtr = w' }
419 if bufferFull new_buf || is_line && c == '\n'
421 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
422 writeIORef ref flushed_buf
424 writeIORef ref new_buf
427 hPutChars :: Handle -> [Char] -> IO ()
428 hPutChars handle [] = return ()
429 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
431 -- ---------------------------------------------------------------------------
434 -- We go to some trouble to avoid keeping the handle locked while we're
435 -- evaluating the string argument to hPutStr, in case doing so triggers another
436 -- I/O operation on the same handle which would lead to deadlock. The classic
439 -- putStr (trace "hello" "world")
441 -- so the basic scheme is this:
443 -- * copy the string into a fresh buffer,
444 -- * "commit" the buffer to the handle.
446 -- Committing may involve simply copying the contents of the new
447 -- buffer into the handle's buffer, flushing one or both buffers, or
448 -- maybe just swapping the buffers over (if the handle's buffer was
449 -- empty). See commitBuffer below.
451 -- | Computation 'hPutStr' @hdl s@ writes the string
452 -- @s@ to the file or channel managed by @hdl@.
454 -- This operation may fail with:
456 -- * 'isFullError' if the device is full; or
458 -- * 'isPermissionError' if another system resource limit would be exceeded.
460 hPutStr :: Handle -> String -> IO ()
461 hPutStr handle str = do
462 buffer_mode <- wantWritableHandle "hPutStr" handle
463 (\ handle_ -> do getSpareBuffer handle_)
465 (NoBuffering, _) -> do
466 hPutChars handle str -- v. slow, but we don't care
467 (LineBuffering, buf) -> do
468 writeLines handle buf str
469 (BlockBuffering _, buf) -> do
470 writeBlocks handle buf str
473 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
474 getSpareBuffer Handle__{haBuffer=ref,
479 NoBuffering -> return (mode, error "no buffer!")
481 bufs <- readIORef spare_ref
484 BufferListCons b rest -> do
485 writeIORef spare_ref rest
486 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
488 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
489 return (mode, new_buf)
492 writeLines :: Handle -> Buffer -> String -> IO ()
493 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
495 shoveString :: Int -> [Char] -> IO ()
496 -- check n == len first, to ensure that shoveString is strict in n.
497 shoveString n cs | n == len = do
498 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
499 writeLines hdl new_buf cs
500 shoveString n [] = do
501 commitBuffer hdl raw len n False{-no flush-} True{-release-}
503 shoveString n (c:cs) = do
504 n' <- writeCharIntoBuffer raw n c
507 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
508 writeLines hdl new_buf cs
514 writeBlocks :: Handle -> Buffer -> String -> IO ()
515 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
517 shoveString :: Int -> [Char] -> IO ()
518 -- check n == len first, to ensure that shoveString is strict in n.
519 shoveString n cs | n == len = do
520 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
521 writeBlocks hdl new_buf cs
522 shoveString n [] = do
523 commitBuffer hdl raw len n False{-no flush-} True{-release-}
525 shoveString n (c:cs) = do
526 n' <- writeCharIntoBuffer raw n c
531 -- -----------------------------------------------------------------------------
532 -- commitBuffer handle buf sz count flush release
534 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
535 -- 'count' bytes of data) to handle (handle must be block or line buffered).
539 -- for block/line buffering,
540 -- 1. If there isn't room in the handle buffer, flush the handle
543 -- 2. If the handle buffer is empty,
545 -- then write buf directly to the device.
546 -- else swap the handle buffer with buf.
548 -- 3. If the handle buffer is non-empty, copy buf into the
549 -- handle buffer. Then, if flush != 0, flush
553 :: Handle -- handle to commit to
554 -> RawBuffer -> Int -- address and size (in bytes) of buffer
555 -> Int -- number of bytes of data in buffer
556 -> Bool -- True <=> flush the handle afterward
557 -> Bool -- release the buffer?
560 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
561 wantWritableHandle "commitAndReleaseBuffer" hdl $
562 commitBuffer' hdl raw sz count flush release
564 -- Explicitly lambda-lift this function to subvert GHC's full laziness
565 -- optimisations, which otherwise tends to float out subexpressions
566 -- past the \handle, which is really a pessimisation in this case because
567 -- that lambda is a one-shot lambda.
569 -- Don't forget to export the function, to stop it being inlined too
570 -- (this appears to be better than NOINLINE, because the strictness
571 -- analyser still gets to worker-wrapper it).
573 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
575 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
576 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
579 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
580 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
583 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
587 -- enough room in handle buffer?
588 if (not flush && (size - w > count))
589 -- The > is to be sure that we never exactly fill
590 -- up the buffer, which would require a flush. So
591 -- if copying the new data into the buffer would
592 -- make the buffer full, we just flush the existing
593 -- buffer and the new data immediately, rather than
594 -- copying before flushing.
596 -- not flushing, and there's enough room in the buffer:
597 -- just copy the data in and update bufWPtr.
598 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
599 writeIORef ref old_buf{ bufWPtr = w + count }
600 return (newEmptyBuffer raw WriteBuffer sz)
602 -- else, we have to flush
603 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
606 Buffer{ bufBuf=raw, bufState=WriteBuffer,
607 bufRPtr=0, bufWPtr=count, bufSize=sz }
609 -- if: (a) we don't have to flush, and
610 -- (b) size(new buffer) == size(old buffer), and
611 -- (c) new buffer is not full,
612 -- we can just just swap them over...
613 if (not flush && sz == size && count /= sz)
615 writeIORef ref this_buf
618 -- otherwise, we have to flush the new data too,
619 -- and start with a fresh buffer
621 flushWriteBuffer fd (haIsStream handle_) this_buf
622 writeIORef ref flushed_buf
623 -- if the sizes were different, then allocate
624 -- a new buffer of the correct size.
626 then return (newEmptyBuffer raw WriteBuffer sz)
627 else allocateBuffer size WriteBuffer
629 -- release the buffer if necessary
631 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
632 if release && buf_ret_sz == size
634 spare_bufs <- readIORef spare_buf_ref
635 writeIORef spare_buf_ref
636 (BufferListCons buf_ret_raw spare_bufs)
641 -- ---------------------------------------------------------------------------
642 -- Reading/writing sequences of bytes.
644 -- ---------------------------------------------------------------------------
647 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
648 -- buffer @buf@ to the handle @hdl@. It returns ().
650 -- This operation may fail with:
652 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
653 -- reading end is closed. (If this is a POSIX system, and the program
654 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
655 -- instead, whose default action is to terminate the program).
657 hPutBuf :: Handle -- handle to write to
658 -> Ptr a -- address of buffer
659 -> Int -- number of bytes of data in buffer
661 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
664 :: Handle -- handle to write to
665 -> Ptr a -- address of buffer
666 -> Int -- number of bytes of data in buffer
667 -> IO Int -- returns: number of bytes written
668 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
670 hPutBuf':: Handle -- handle to write to
671 -> Ptr a -- address of buffer
672 -> Int -- number of bytes of data in buffer
673 -> Bool -- allow blocking?
675 hPutBuf' handle ptr count can_block
676 | count == 0 = return 0
677 | count < 0 = illegalBufferSize handle "hPutBuf" count
679 wantWritableHandle "hPutBuf" handle $
680 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
681 bufWrite fd ref is_stream ptr count can_block
683 bufWrite fd ref is_stream ptr count can_block =
684 seq count $ seq fd $ do -- strictness hack
685 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
688 -- enough room in handle buffer?
689 if (size - w > count)
690 -- There's enough room in the buffer:
691 -- just copy the data in and update bufWPtr.
692 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
693 writeIORef ref old_buf{ bufWPtr = w + count }
696 -- else, we have to flush
697 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
698 -- TODO: we should do a non-blocking flush here
699 writeIORef ref flushed_buf
700 -- if we can fit in the buffer, then just loop
702 then bufWrite fd ref is_stream ptr count can_block
704 then do writeChunk fd is_stream (castPtr ptr) count
706 else writeChunkNonBlocking fd is_stream ptr count
708 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
709 writeChunk fd is_stream ptr bytes = loop 0 bytes
711 loop :: Int -> Int -> IO ()
712 loop _ bytes | bytes <= 0 = return ()
714 r <- fromIntegral `liftM`
715 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
716 off (fromIntegral bytes)
717 -- write can't return 0
718 loop (off + r) (bytes - r)
720 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
721 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
723 loop :: Int -> Int -> IO Int
724 loop off bytes | bytes <= 0 = return off
726 #ifndef mingw32_TARGET_OS
727 ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
728 let r = fromIntegral ssize :: Int
730 then do errno <- getErrno
731 if (errno == eAGAIN || errno == eWOULDBLOCK)
733 else throwErrno "writeChunk"
734 else loop (off + r) (bytes - r)
736 (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
739 let r = fromIntegral ssize :: Int
741 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
742 else loop (off + r) (bytes - r)
745 -- ---------------------------------------------------------------------------
748 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
749 -- into the buffer @buf@ until either EOF is reached or
750 -- @count@ 8-bit bytes have been read.
751 -- It returns the number of bytes actually read. This may be zero if
752 -- EOF was reached before any data was read (or if @count@ is zero).
754 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
755 -- smaller than @count@.
757 -- If the handle is a pipe or socket, and the writing end
758 -- is closed, 'hGetBuf' will behave as if EOF was reached.
760 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
762 | count == 0 = return 0
763 | count < 0 = illegalBufferSize h "hGetBuf" count
765 wantReadableHandle "hGetBuf" h $
766 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
767 bufRead fd ref is_stream ptr 0 count
769 -- small reads go through the buffer, large reads are satisfied by
770 -- taking data first from the buffer and then direct from the file
772 bufRead fd ref is_stream ptr so_far count =
773 seq fd $ seq so_far $ seq count $ do -- strictness hack
774 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
776 then if count > sz -- small read?
777 then do rest <- readChunk fd is_stream ptr count
778 return (so_far + rest)
779 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
781 Nothing -> return so_far -- got nothing, we're done
783 writeIORef ref new_buf
784 bufRead fd ref is_stream ptr so_far count
789 memcpy_ptr_baoff ptr raw r (fromIntegral count)
790 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
791 return (so_far + count)
795 memcpy_ptr_baoff ptr raw r (fromIntegral count)
796 writeIORef ref buf{ bufRPtr = r + count }
797 return (so_far + count)
800 let remaining = count - avail
801 so_far' = so_far + avail
802 ptr' = ptr `plusPtr` avail
805 then bufRead fd ref is_stream ptr' so_far' remaining
808 rest <- readChunk fd is_stream ptr' remaining
809 return (so_far' + rest)
811 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
812 readChunk fd is_stream ptr bytes = loop 0 bytes
814 loop :: Int -> Int -> IO Int
815 loop off bytes | bytes <= 0 = return off
817 r <- fromIntegral `liftM`
818 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
819 (castPtr ptr) off (fromIntegral bytes)
822 else loop (off + r) (bytes - r)
825 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
826 -- into the buffer @buf@ until either EOF is reached, or
827 -- @count@ 8-bit bytes have been read, or there is no more data available
828 -- to read immediately.
830 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
831 -- never block waiting for data to become available, instead it returns
832 -- only whatever data is available. To wait for data to arrive before
833 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
835 -- If the handle is a pipe or socket, and the writing end
836 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
838 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
839 hGetBufNonBlocking h ptr count
840 | count == 0 = return 0
841 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
843 wantReadableHandle "hGetBufNonBlocking" h $
844 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
845 bufReadNonBlocking fd ref is_stream ptr 0 count
847 bufReadNonBlocking fd ref is_stream ptr so_far count =
848 seq fd $ seq so_far $ seq count $ do -- strictness hack
849 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
851 then if count > sz -- large read?
852 then do rest <- readChunkNonBlocking fd is_stream ptr count
853 return (so_far + rest)
854 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
855 case buf' of { Buffer{ bufWPtr=w } ->
858 else do writeIORef ref buf'
859 bufReadNonBlocking fd ref is_stream ptr
861 -- NOTE: new count is 'min count w'
862 -- so we will just copy the contents of the
863 -- buffer in the recursive call, and not
870 memcpy_ptr_baoff ptr raw r (fromIntegral count)
871 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
872 return (so_far + count)
876 memcpy_ptr_baoff ptr raw r (fromIntegral count)
877 writeIORef ref buf{ bufRPtr = r + count }
878 return (so_far + count)
881 let remaining = count - avail
882 so_far' = so_far + avail
883 ptr' = ptr `plusPtr` avail
885 -- we haven't attempted to read anything yet if we get to here.
887 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
890 rest <- readChunkNonBlocking fd is_stream ptr' remaining
891 return (so_far' + rest)
894 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
895 readChunkNonBlocking fd is_stream ptr bytes = do
896 #ifndef mingw32_TARGET_OS
897 ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
898 let r = fromIntegral ssize :: Int
900 then do errno <- getErrno
901 if (errno == eAGAIN || errno == eWOULDBLOCK)
903 else throwErrno "readChunk"
906 (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
907 (fromIntegral bytes) ptr
908 let r = fromIntegral ssize :: Int
910 then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
914 slurpFile :: FilePath -> IO (Ptr (), Int)
916 handle <- openFile fname ReadMode
917 sz <- hFileSize handle
918 if sz > fromIntegral (maxBound::Int) then
919 ioError (userError "slurpFile: file too big")
921 let sz_i = fromIntegral sz
922 if sz_i == 0 then return (nullPtr, 0) else do
923 chunk <- mallocBytes sz_i
924 r <- hGetBuf handle chunk sz_i
928 -- ---------------------------------------------------------------------------
931 foreign import ccall unsafe "__hscore_memcpy_src_off"
932 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
933 foreign import ccall unsafe "__hscore_memcpy_src_off"
934 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
935 foreign import ccall unsafe "__hscore_memcpy_dst_off"
936 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
937 foreign import ccall unsafe "__hscore_memcpy_dst_off"
938 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
940 -----------------------------------------------------------------------------
943 illegalBufferSize :: Handle -> String -> Int -> IO a
944 illegalBufferSize handle fn (sz :: Int) =
945 ioException (IOError (Just handle)
947 ("illegal buffer size " ++ showsPrec 9 sz [])