1 {-# OPTIONS_GHC -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 -----------------------------------------------------------------------------
21 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
22 commitBuffer', -- hack, see below
23 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
24 hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
34 import System.IO.Error
37 import System.Posix.Internals
42 import GHC.Handle -- much of the real stuff is in here
47 import GHC.Exception ( ioError, catch )
49 #ifdef mingw32_HOST_OS
53 -- ---------------------------------------------------------------------------
54 -- Simple input operations
56 -- If hWaitForInput finds anything in the Handle's buffer, it
57 -- immediately returns. If not, it tries to read from the underlying
58 -- OS handle. Notice that for buffered Handles connected to terminals
59 -- this means waiting until a complete line is available.
61 -- | Computation 'hWaitForInput' @hdl t@
62 -- waits until input is available on handle @hdl@.
63 -- It returns 'True' as soon as input is available on @hdl@,
64 -- or 'False' if no input is available within @t@ milliseconds.
66 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
68 -- This operation may fail with:
70 -- * 'isEOFError' if the end of file has been reached.
72 -- NOTE for GHC users: unless you use the @-threaded@ flag,
73 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
74 -- threads for the duration of the call. It behaves like a
75 -- @safe@ foreign call in this respect.
77 hWaitForInput :: Handle -> Int -> IO Bool
78 hWaitForInput h msecs = do
79 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
80 let ref = haBuffer handle_
83 if not (bufferEmpty buf)
88 then do buf' <- fillReadBuffer (haFD handle_) True
89 (haIsStream handle_) buf
92 else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
93 fdReady (haFD handle_) 0 {- read -}
95 (fromIntegral $ fromEnum $ haIsStream handle_)
98 foreign import ccall safe "fdReady"
99 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
101 -- ---------------------------------------------------------------------------
104 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
105 -- channel managed by @hdl@, blocking until a character is available.
107 -- This operation may fail with:
109 -- * 'isEOFError' if the end of file has been reached.
111 hGetChar :: Handle -> IO Char
113 wantReadableHandle "hGetChar" handle $ \handle_ -> do
115 let fd = haFD handle_
116 ref = haBuffer handle_
119 if not (bufferEmpty buf)
120 then hGetcBuffered fd ref buf
124 case haBufferMode handle_ of
126 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
127 hGetcBuffered fd ref new_buf
128 BlockBuffering _ -> do
129 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
131 -- don't wait for a completely full buffer.
132 hGetcBuffered fd ref new_buf
134 -- make use of the minimal buffer we already have
136 r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1
139 else do (c,_) <- readCharFromBuffer raw 0
142 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
143 = do (c,r) <- readCharFromBuffer b r
144 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
145 | otherwise = buf{ bufRPtr=r }
146 writeIORef ref new_buf
149 -- ---------------------------------------------------------------------------
152 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
155 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
156 -- channel managed by @hdl@.
158 -- This operation may fail with:
160 -- * 'isEOFError' if the end of file is encountered when reading
161 -- the /first/ character of the line.
163 -- If 'hGetLine' encounters end-of-file at any other point while reading
164 -- in a line, it is treated as a line terminator and the (partial)
167 hGetLine :: Handle -> IO String
169 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
170 case haBufferMode handle_ of
171 NoBuffering -> return Nothing
173 l <- hGetLineBuffered handle_
175 BlockBuffering _ -> do
176 l <- hGetLineBuffered handle_
179 Nothing -> hGetLineUnBuffered h
182 hGetLineBuffered :: Handle__ -> IO String
183 hGetLineBuffered handle_ = do
184 let ref = haBuffer handle_
186 hGetLineBufferedLoop handle_ ref buf []
188 hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
190 hGetLineBufferedLoop handle_ ref
191 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
193 -- find the end-of-line character, if there is one
195 | r == w = return (False, w)
197 (c,r') <- readCharFromBuffer raw r
199 then return (True, r) -- NB. not r': don't include the '\n'
202 (eol, off) <- loop raw r
205 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
208 xs <- unpack raw r off
210 -- if eol == True, then off is the offset of the '\n'
211 -- otherwise off == w and the buffer is now empty.
213 then do if (w == off + 1)
214 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
215 else writeIORef ref buf{ bufRPtr = off + 1 }
216 return (concat (reverse (xs:xss)))
218 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
219 buf{ bufWPtr=0, bufRPtr=0 }
221 -- Nothing indicates we caught an EOF, and we may have a
222 -- partial line to return.
224 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
225 let str = concat (reverse (xs:xss))
230 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
233 maybeFillReadBuffer fd is_line is_stream buf
235 (do buf <- fillReadBuffer fd is_line is_stream buf
238 (\e -> do if isEOFError e
243 unpack :: RawBuffer -> Int -> Int -> IO [Char]
244 unpack buf r 0 = return ""
245 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
248 | i <# r = (# s, acc #)
250 case readCharArray# buf i s of
251 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
254 hGetLineUnBuffered :: Handle -> IO String
255 hGetLineUnBuffered h = do
268 if isEOFError err then
278 -- -----------------------------------------------------------------------------
281 -- hGetContents on a DuplexHandle only affects the read side: you can
282 -- carry on writing to it afterwards.
284 -- | Computation 'hGetContents' @hdl@ returns the list of characters
285 -- corresponding to the unread portion of the channel or file managed
286 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
287 -- In this state, @hdl@ is effectively closed,
288 -- but items are read from @hdl@ on demand and accumulated in a special
289 -- list returned by 'hGetContents' @hdl@.
291 -- Any operation that fails because a handle is closed,
292 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
293 -- A semi-closed handle becomes closed:
295 -- * if 'hClose' is applied to it;
297 -- * if an I\/O error occurs when reading an item from the handle;
299 -- * or once the entire contents of the handle has been read.
301 -- Once a semi-closed handle becomes closed, the contents of the
302 -- associated list becomes fixed. The contents of this final list is
303 -- only partially specified: it will contain at least all the items of
304 -- the stream that were evaluated prior to the handle becoming closed.
306 -- Any I\/O errors encountered while a handle is semi-closed are simply
309 -- This operation may fail with:
311 -- * 'isEOFError' if the end of file has been reached.
313 hGetContents :: Handle -> IO String
314 hGetContents handle =
315 withHandle "hGetContents" handle $ \handle_ ->
316 case haType handle_ of
317 ClosedHandle -> ioe_closedHandle
318 SemiClosedHandle -> ioe_closedHandle
319 AppendHandle -> ioe_notReadable
320 WriteHandle -> ioe_notReadable
321 _ -> do xs <- lazyRead handle
322 return (handle_{ haType=SemiClosedHandle}, xs )
324 -- Note that someone may close the semi-closed handle (or change its
325 -- buffering), so each time these lazy read functions are pulled on,
326 -- they have to check whether the handle has indeed been closed.
328 lazyRead :: Handle -> IO String
331 withHandle "lazyRead" handle $ \ handle_ -> do
332 case haType handle_ of
333 ClosedHandle -> return (handle_, "")
334 SemiClosedHandle -> lazyRead' handle handle_
336 (IOError (Just handle) IllegalOperation "lazyRead"
337 "illegal handle type" Nothing)
339 lazyRead' h handle_ = do
340 let ref = haBuffer handle_
343 -- even a NoBuffering handle can have a char in the buffer...
346 if not (bufferEmpty buf)
347 then lazyReadHaveBuffer h handle_ fd ref buf
350 case haBufferMode handle_ of
352 -- make use of the minimal buffer we already have
354 r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
356 then do (handle_,_) <- hClose_help handle_
358 else do (c,_) <- readCharFromBuffer raw 0
360 return (handle_, c : rest)
362 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
363 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
365 -- we never want to block during the read, so we call fillReadBuffer with
366 -- is_line==True, which tells it to "just read what there is".
367 lazyReadBuffered h handle_ fd ref buf = do
369 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
370 lazyReadHaveBuffer h handle_ fd ref buf
372 -- all I/O errors are discarded. Additionally, we close the handle.
373 (\e -> do (handle_,_) <- hClose_help handle_
377 lazyReadHaveBuffer h handle_ fd ref buf = do
379 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
380 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
384 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
385 unpackAcc buf r 0 acc = return acc
386 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
389 | i <# r = (# s, acc #)
391 case readCharArray# buf i s of
392 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
394 -- ---------------------------------------------------------------------------
397 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
398 -- file or channel managed by @hdl@. Characters may be buffered if
399 -- buffering is enabled for @hdl@.
401 -- This operation may fail with:
403 -- * 'isFullError' if the device is full; or
405 -- * 'isPermissionError' if another system resource limit would be exceeded.
407 hPutChar :: Handle -> Char -> IO ()
408 hPutChar handle c = do
410 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
411 let fd = haFD handle_
412 case haBufferMode handle_ of
413 LineBuffering -> hPutcBuffered handle_ True c
414 BlockBuffering _ -> hPutcBuffered handle_ False c
416 with (castCharToCChar c) $ \buf -> do
417 writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
420 hPutcBuffered handle_ is_line c = do
421 let ref = haBuffer handle_
424 w' <- writeCharIntoBuffer (bufBuf buf) w c
425 let new_buf = buf{ bufWPtr = w' }
426 if bufferFull new_buf || is_line && c == '\n'
428 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
429 writeIORef ref flushed_buf
431 writeIORef ref new_buf
434 hPutChars :: Handle -> [Char] -> IO ()
435 hPutChars handle [] = return ()
436 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
438 -- ---------------------------------------------------------------------------
441 -- We go to some trouble to avoid keeping the handle locked while we're
442 -- evaluating the string argument to hPutStr, in case doing so triggers another
443 -- I/O operation on the same handle which would lead to deadlock. The classic
446 -- putStr (trace "hello" "world")
448 -- so the basic scheme is this:
450 -- * copy the string into a fresh buffer,
451 -- * "commit" the buffer to the handle.
453 -- Committing may involve simply copying the contents of the new
454 -- buffer into the handle's buffer, flushing one or both buffers, or
455 -- maybe just swapping the buffers over (if the handle's buffer was
456 -- empty). See commitBuffer below.
458 -- | Computation 'hPutStr' @hdl s@ writes the string
459 -- @s@ to the file or channel managed by @hdl@.
461 -- This operation may fail with:
463 -- * 'isFullError' if the device is full; or
465 -- * 'isPermissionError' if another system resource limit would be exceeded.
467 hPutStr :: Handle -> String -> IO ()
468 hPutStr handle str = do
469 buffer_mode <- wantWritableHandle "hPutStr" handle
470 (\ handle_ -> do getSpareBuffer handle_)
472 (NoBuffering, _) -> do
473 hPutChars handle str -- v. slow, but we don't care
474 (LineBuffering, buf) -> do
475 writeLines handle buf str
476 (BlockBuffering _, buf) -> do
477 writeBlocks handle buf str
480 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
481 getSpareBuffer Handle__{haBuffer=ref,
486 NoBuffering -> return (mode, error "no buffer!")
488 bufs <- readIORef spare_ref
491 BufferListCons b rest -> do
492 writeIORef spare_ref rest
493 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
495 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
496 return (mode, new_buf)
499 writeLines :: Handle -> Buffer -> String -> IO ()
500 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
502 shoveString :: Int -> [Char] -> IO ()
503 -- check n == len first, to ensure that shoveString is strict in n.
504 shoveString n cs | n == len = do
505 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
506 writeLines hdl new_buf cs
507 shoveString n [] = do
508 commitBuffer hdl raw len n False{-no flush-} True{-release-}
510 shoveString n (c:cs) = do
511 n' <- writeCharIntoBuffer raw n c
514 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
515 writeLines hdl new_buf cs
521 writeBlocks :: Handle -> Buffer -> String -> IO ()
522 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
524 shoveString :: Int -> [Char] -> IO ()
525 -- check n == len first, to ensure that shoveString is strict in n.
526 shoveString n cs | n == len = do
527 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
528 writeBlocks hdl new_buf cs
529 shoveString n [] = do
530 commitBuffer hdl raw len n False{-no flush-} True{-release-}
532 shoveString n (c:cs) = do
533 n' <- writeCharIntoBuffer raw n c
538 -- -----------------------------------------------------------------------------
539 -- commitBuffer handle buf sz count flush release
541 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
542 -- 'count' bytes of data) to handle (handle must be block or line buffered).
546 -- for block/line buffering,
547 -- 1. If there isn't room in the handle buffer, flush the handle
550 -- 2. If the handle buffer is empty,
552 -- then write buf directly to the device.
553 -- else swap the handle buffer with buf.
555 -- 3. If the handle buffer is non-empty, copy buf into the
556 -- handle buffer. Then, if flush != 0, flush
560 :: Handle -- handle to commit to
561 -> RawBuffer -> Int -- address and size (in bytes) of buffer
562 -> Int -- number of bytes of data in buffer
563 -> Bool -- True <=> flush the handle afterward
564 -> Bool -- release the buffer?
567 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
568 wantWritableHandle "commitAndReleaseBuffer" hdl $
569 commitBuffer' raw sz count flush release
571 -- Explicitly lambda-lift this function to subvert GHC's full laziness
572 -- optimisations, which otherwise tends to float out subexpressions
573 -- past the \handle, which is really a pessimisation in this case because
574 -- that lambda is a one-shot lambda.
576 -- Don't forget to export the function, to stop it being inlined too
577 -- (this appears to be better than NOINLINE, because the strictness
578 -- analyser still gets to worker-wrapper it).
580 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
582 commitBuffer' raw sz@(I# _) count@(I# _) flush release
583 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
586 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
587 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
590 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
594 -- enough room in handle buffer?
595 if (not flush && (size - w > count))
596 -- The > is to be sure that we never exactly fill
597 -- up the buffer, which would require a flush. So
598 -- if copying the new data into the buffer would
599 -- make the buffer full, we just flush the existing
600 -- buffer and the new data immediately, rather than
601 -- copying before flushing.
603 -- not flushing, and there's enough room in the buffer:
604 -- just copy the data in and update bufWPtr.
605 then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
606 writeIORef ref old_buf{ bufWPtr = w + count }
607 return (newEmptyBuffer raw WriteBuffer sz)
609 -- else, we have to flush
610 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
613 Buffer{ bufBuf=raw, bufState=WriteBuffer,
614 bufRPtr=0, bufWPtr=count, bufSize=sz }
616 -- if: (a) we don't have to flush, and
617 -- (b) size(new buffer) == size(old buffer), and
618 -- (c) new buffer is not full,
619 -- we can just just swap them over...
620 if (not flush && sz == size && count /= sz)
622 writeIORef ref this_buf
625 -- otherwise, we have to flush the new data too,
626 -- and start with a fresh buffer
628 flushWriteBuffer fd (haIsStream handle_) this_buf
629 writeIORef ref flushed_buf
630 -- if the sizes were different, then allocate
631 -- a new buffer of the correct size.
633 then return (newEmptyBuffer raw WriteBuffer sz)
634 else allocateBuffer size WriteBuffer
636 -- release the buffer if necessary
638 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
639 if release && buf_ret_sz == size
641 spare_bufs <- readIORef spare_buf_ref
642 writeIORef spare_buf_ref
643 (BufferListCons buf_ret_raw spare_bufs)
648 -- ---------------------------------------------------------------------------
649 -- Reading/writing sequences of bytes.
651 -- ---------------------------------------------------------------------------
654 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
655 -- buffer @buf@ to the handle @hdl@. It returns ().
657 -- This operation may fail with:
659 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
660 -- reading end is closed. (If this is a POSIX system, and the program
661 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
662 -- instead, whose default action is to terminate the program).
664 hPutBuf :: Handle -- handle to write to
665 -> Ptr a -- address of buffer
666 -> Int -- number of bytes of data in buffer
668 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
671 :: Handle -- handle to write to
672 -> Ptr a -- address of buffer
673 -> Int -- number of bytes of data in buffer
674 -> IO Int -- returns: number of bytes written
675 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
677 hPutBuf':: Handle -- handle to write to
678 -> Ptr a -- address of buffer
679 -> Int -- number of bytes of data in buffer
680 -> Bool -- allow blocking?
682 hPutBuf' handle ptr count can_block
683 | count == 0 = return 0
684 | count < 0 = illegalBufferSize handle "hPutBuf" count
686 wantWritableHandle "hPutBuf" handle $
687 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
688 bufWrite fd ref is_stream ptr count can_block
690 bufWrite fd ref is_stream ptr count can_block =
691 seq count $ seq fd $ do -- strictness hack
692 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
695 -- enough room in handle buffer?
696 if (size - w > count)
697 -- There's enough room in the buffer:
698 -- just copy the data in and update bufWPtr.
699 then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)
700 writeIORef ref old_buf{ bufWPtr = w + count }
703 -- else, we have to flush
704 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
705 -- TODO: we should do a non-blocking flush here
706 writeIORef ref flushed_buf
707 -- if we can fit in the buffer, then just loop
709 then bufWrite fd ref is_stream ptr count can_block
711 then do writeChunk fd is_stream (castPtr ptr) count
713 else writeChunkNonBlocking fd is_stream ptr count
715 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
716 writeChunk fd is_stream ptr bytes = loop 0 bytes
718 loop :: Int -> Int -> IO ()
719 loop _ bytes | bytes <= 0 = return ()
721 r <- fromIntegral `liftM`
722 writeRawBufferPtr "writeChunk" fd is_stream ptr
723 off (fromIntegral bytes)
724 -- write can't return 0
725 loop (off + r) (bytes - r)
727 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
728 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
730 loop :: Int -> Int -> IO Int
731 loop off bytes | bytes <= 0 = return off
733 #ifndef mingw32_HOST_OS
734 ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)
735 let r = fromIntegral ssize :: Int
737 then do errno <- getErrno
738 if (errno == eAGAIN || errno == eWOULDBLOCK)
740 else throwErrno "writeChunk"
741 else loop (off + r) (bytes - r)
743 (ssize, rc) <- asyncWrite (fromIntegral fd)
744 (fromIntegral $ fromEnum is_stream)
747 let r = fromIntegral ssize :: Int
749 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
750 else loop (off + r) (bytes - r)
753 -- ---------------------------------------------------------------------------
756 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
757 -- into the buffer @buf@ until either EOF is reached or
758 -- @count@ 8-bit bytes have been read.
759 -- It returns the number of bytes actually read. This may be zero if
760 -- EOF was reached before any data was read (or if @count@ is zero).
762 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
763 -- smaller than @count@.
765 -- If the handle is a pipe or socket, and the writing end
766 -- is closed, 'hGetBuf' will behave as if EOF was reached.
768 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
770 | count == 0 = return 0
771 | count < 0 = illegalBufferSize h "hGetBuf" count
773 wantReadableHandle "hGetBuf" h $
774 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
775 bufRead fd ref is_stream ptr 0 count
777 -- small reads go through the buffer, large reads are satisfied by
778 -- taking data first from the buffer and then direct from the file
780 bufRead fd ref is_stream ptr so_far count =
781 seq fd $ seq so_far $ seq count $ do -- strictness hack
782 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
784 then if count > sz -- small read?
785 then do rest <- readChunk fd is_stream ptr count
786 return (so_far + rest)
787 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
789 Nothing -> return so_far -- got nothing, we're done
792 bufRead fd ref is_stream ptr so_far count
797 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
798 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
799 return (so_far + count)
803 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
804 writeIORef ref buf{ bufRPtr = r + count }
805 return (so_far + count)
808 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
809 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
810 let remaining = count - avail
811 so_far' = so_far + avail
812 ptr' = ptr `plusPtr` avail
815 then bufRead fd ref is_stream ptr' so_far' remaining
818 rest <- readChunk fd is_stream ptr' remaining
819 return (so_far' + rest)
821 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
822 readChunk fd is_stream ptr bytes = loop 0 bytes
824 loop :: Int -> Int -> IO Int
825 loop off bytes | bytes <= 0 = return off
827 r <- fromIntegral `liftM`
828 readRawBufferPtr "readChunk" fd is_stream
829 (castPtr ptr) off (fromIntegral bytes)
832 else loop (off + r) (bytes - r)
835 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
836 -- into the buffer @buf@ until either EOF is reached, or
837 -- @count@ 8-bit bytes have been read, or there is no more data available
838 -- to read immediately.
840 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
841 -- never block waiting for data to become available, instead it returns
842 -- only whatever data is available. To wait for data to arrive before
843 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
845 -- If the handle is a pipe or socket, and the writing end
846 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
848 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
849 hGetBufNonBlocking h ptr count
850 | count == 0 = return 0
851 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
853 wantReadableHandle "hGetBufNonBlocking" h $
854 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
855 bufReadNonBlocking fd ref is_stream ptr 0 count
857 bufReadNonBlocking fd ref is_stream ptr so_far count =
858 seq fd $ seq so_far $ seq count $ do -- strictness hack
859 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
861 then if count > sz -- large read?
862 then do rest <- readChunkNonBlocking fd is_stream ptr count
863 return (so_far + rest)
864 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
865 case buf' of { Buffer{ bufWPtr=w } ->
868 else do writeIORef ref buf'
869 bufReadNonBlocking fd ref is_stream ptr
871 -- NOTE: new count is 'min count w'
872 -- so we will just copy the contents of the
873 -- buffer in the recursive call, and not
880 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
881 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
882 return (so_far + count)
886 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
887 writeIORef ref buf{ bufRPtr = r + count }
888 return (so_far + count)
891 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
892 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
893 let remaining = count - avail
894 so_far' = so_far + avail
895 ptr' = ptr `plusPtr` avail
897 -- we haven't attempted to read anything yet if we get to here.
899 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
902 rest <- readChunkNonBlocking fd is_stream ptr' remaining
903 return (so_far' + rest)
906 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
907 readChunkNonBlocking fd is_stream ptr bytes = do
908 #ifndef mingw32_HOST_OS
909 ssize <- c_read fd (castPtr ptr) (fromIntegral bytes)
910 let r = fromIntegral ssize :: Int
912 then do errno <- getErrno
913 if (errno == eAGAIN || errno == eWOULDBLOCK)
915 else throwErrno "readChunk"
919 readRawBufferPtr "readChunkNonBlocking" fd is_stream
920 (castPtr ptr) 0 (fromIntegral bytes)
922 -- we don't have non-blocking read support on Windows, so just invoke
923 -- the ordinary low-level read which will block until data is available,
924 -- but won't wait for the whole buffer to fill.
927 slurpFile :: FilePath -> IO (Ptr (), Int)
929 handle <- openFile fname ReadMode
930 sz <- hFileSize handle
931 if sz > fromIntegral (maxBound::Int) then
932 ioError (userError "slurpFile: file too big")
934 let sz_i = fromIntegral sz
935 if sz_i == 0 then return (nullPtr, 0) else do
936 chunk <- mallocBytes sz_i
937 r <- hGetBuf handle chunk sz_i
941 -- ---------------------------------------------------------------------------
944 foreign import ccall unsafe "__hscore_memcpy_src_off"
945 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
946 foreign import ccall unsafe "__hscore_memcpy_src_off"
947 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
948 foreign import ccall unsafe "__hscore_memcpy_dst_off"
949 memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
950 foreign import ccall unsafe "__hscore_memcpy_dst_off"
951 memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())
953 -----------------------------------------------------------------------------
956 illegalBufferSize :: Handle -> String -> Int -> IO a
957 illegalBufferSize handle fn (sz :: Int) =
958 ioException (IOError (Just handle)
960 ("illegal buffer size " ++ showsPrec 9 sz [])