1 {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
2 {-# OPTIONS_HADDOCK hide #-}
6 -----------------------------------------------------------------------------
9 -- Copyright : (c) The University of Glasgow, 1992-2001
10 -- License : see libraries/base/LICENSE
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
16 -- String I\/O functions
18 -----------------------------------------------------------------------------
22 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
23 commitBuffer', -- hack, see below
24 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
25 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 #ifdef mingw32_HOST_OS
54 -- ---------------------------------------------------------------------------
55 -- Simple input operations
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.
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.
67 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
69 -- This operation may fail with:
71 -- * 'isEOFError' if the end of file has been reached.
73 -- NOTE for GHC users: unless you use the @-threaded@ flag,
74 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
75 -- threads for the duration of the call. It behaves like a
76 -- @safe@ foreign call in this respect.
78 hWaitForInput :: Handle -> Int -> IO Bool
79 hWaitForInput h msecs = do
80 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
81 let ref = haBuffer handle_
84 if not (bufferEmpty buf)
89 then do buf' <- fillReadBuffer (haFD handle_) True
90 (haIsStream handle_) buf
93 else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
94 fdReady (haFD handle_) 0 {- read -}
96 (fromIntegral $ fromEnum $ haIsStream handle_)
99 foreign import ccall safe "fdReady"
100 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
102 -- ---------------------------------------------------------------------------
105 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
106 -- channel managed by @hdl@, blocking until a character is available.
108 -- This operation may fail with:
110 -- * 'isEOFError' if the end of file has been reached.
112 hGetChar :: Handle -> IO Char
114 wantReadableHandle "hGetChar" handle $ \handle_ -> do
116 let fd = haFD handle_
117 ref = haBuffer handle_
120 if not (bufferEmpty buf)
121 then hGetcBuffered fd ref buf
125 case haBufferMode handle_ of
127 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
128 hGetcBuffered fd ref new_buf
129 BlockBuffering _ -> do
130 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
132 -- don't wait for a completely full buffer.
133 hGetcBuffered fd ref new_buf
135 -- make use of the minimal buffer we already have
137 r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1
140 else do (c,_) <- readCharFromBuffer raw 0
143 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
144 = do (c,r) <- readCharFromBuffer b r
145 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
146 | otherwise = buf{ bufRPtr=r }
147 writeIORef ref new_buf
150 -- ---------------------------------------------------------------------------
153 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
156 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
157 -- channel managed by @hdl@.
159 -- This operation may fail with:
161 -- * 'isEOFError' if the end of file is encountered when reading
162 -- the /first/ character of the line.
164 -- If 'hGetLine' encounters end-of-file at any other point while reading
165 -- in a line, it is treated as a line terminator and the (partial)
168 hGetLine :: Handle -> IO String
170 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
171 case haBufferMode handle_ of
172 NoBuffering -> return Nothing
174 l <- hGetLineBuffered handle_
176 BlockBuffering _ -> do
177 l <- hGetLineBuffered handle_
180 Nothing -> hGetLineUnBuffered h
183 hGetLineBuffered :: Handle__ -> IO String
184 hGetLineBuffered handle_ = do
185 let ref = haBuffer handle_
187 hGetLineBufferedLoop handle_ ref buf []
189 hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
191 hGetLineBufferedLoop handle_ ref
192 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
194 -- find the end-of-line character, if there is one
196 | r == w = return (False, w)
198 (c,r') <- readCharFromBuffer raw r
200 then return (True, r) -- NB. not r': don't include the '\n'
203 (eol, off) <- loop raw r
206 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
209 xs <- unpack raw r off
211 -- if eol == True, then off is the offset of the '\n'
212 -- otherwise off == w and the buffer is now empty.
214 then do if (w == off + 1)
215 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
216 else writeIORef ref buf{ bufRPtr = off + 1 }
217 return (concat (reverse (xs:xss)))
219 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
220 buf{ bufWPtr=0, bufRPtr=0 }
222 -- Nothing indicates we caught an EOF, and we may have a
223 -- partial line to return.
225 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
226 let str = concat (reverse (xs:xss))
231 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
234 maybeFillReadBuffer fd is_line is_stream buf
236 (do buf <- fillReadBuffer fd is_line is_stream buf
239 (\e -> do if isEOFError e
244 unpack :: RawBuffer -> Int -> Int -> IO [Char]
245 unpack buf r 0 = return ""
246 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
249 | i <# r = (# s, acc #)
251 case readCharArray# buf i s of
252 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
255 hGetLineUnBuffered :: Handle -> IO String
256 hGetLineUnBuffered h = do
269 if isEOFError err then
279 -- -----------------------------------------------------------------------------
282 -- hGetContents on a DuplexHandle only affects the read side: you can
283 -- carry on writing to it afterwards.
285 -- | Computation 'hGetContents' @hdl@ returns the list of characters
286 -- corresponding to the unread portion of the channel or file managed
287 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
288 -- In this state, @hdl@ is effectively closed,
289 -- but items are read from @hdl@ on demand and accumulated in a special
290 -- list returned by 'hGetContents' @hdl@.
292 -- Any operation that fails because a handle is closed,
293 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
294 -- A semi-closed handle becomes closed:
296 -- * if 'hClose' is applied to it;
298 -- * if an I\/O error occurs when reading an item from the handle;
300 -- * or once the entire contents of the handle has been read.
302 -- Once a semi-closed handle becomes closed, the contents of the
303 -- associated list becomes fixed. The contents of this final list is
304 -- only partially specified: it will contain at least all the items of
305 -- the stream that were evaluated prior to the handle becoming closed.
307 -- Any I\/O errors encountered while a handle is semi-closed are simply
310 -- This operation may fail with:
312 -- * 'isEOFError' if the end of file has been reached.
314 hGetContents :: Handle -> IO String
315 hGetContents handle =
316 withHandle "hGetContents" handle $ \handle_ ->
317 case haType handle_ of
318 ClosedHandle -> ioe_closedHandle
319 SemiClosedHandle -> ioe_closedHandle
320 AppendHandle -> ioe_notReadable
321 WriteHandle -> ioe_notReadable
322 _ -> do xs <- lazyRead handle
323 return (handle_{ haType=SemiClosedHandle}, xs )
325 -- Note that someone may close the semi-closed handle (or change its
326 -- buffering), so each time these lazy read functions are pulled on,
327 -- they have to check whether the handle has indeed been closed.
329 lazyRead :: Handle -> IO String
332 withHandle "lazyRead" handle $ \ handle_ -> do
333 case haType handle_ of
334 ClosedHandle -> return (handle_, "")
335 SemiClosedHandle -> lazyRead' handle handle_
337 (IOError (Just handle) IllegalOperation "lazyRead"
338 "illegal handle type" Nothing)
340 lazyRead' h handle_ = do
341 let ref = haBuffer handle_
344 -- even a NoBuffering handle can have a char in the buffer...
347 if not (bufferEmpty buf)
348 then lazyReadHaveBuffer h handle_ fd ref buf
351 case haBufferMode handle_ of
353 -- make use of the minimal buffer we already have
355 r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
357 then do (handle_,_) <- hClose_help handle_
359 else do (c,_) <- readCharFromBuffer raw 0
361 return (handle_, c : rest)
363 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
364 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
366 -- we never want to block during the read, so we call fillReadBuffer with
367 -- is_line==True, which tells it to "just read what there is".
368 lazyReadBuffered h handle_ fd ref buf = do
370 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
371 lazyReadHaveBuffer h handle_ fd ref buf
373 -- all I/O errors are discarded. Additionally, we close the handle.
374 (\e -> do (handle_,_) <- hClose_help handle_
378 lazyReadHaveBuffer h handle_ fd ref buf = do
380 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
381 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
385 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
386 unpackAcc buf r 0 acc = return acc
387 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
390 | i <# r = (# s, acc #)
392 case readCharArray# buf i s of
393 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
395 -- ---------------------------------------------------------------------------
398 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
399 -- file or channel managed by @hdl@. Characters may be buffered if
400 -- buffering is enabled for @hdl@.
402 -- This operation may fail with:
404 -- * 'isFullError' if the device is full; or
406 -- * 'isPermissionError' if another system resource limit would be exceeded.
408 hPutChar :: Handle -> Char -> IO ()
409 hPutChar handle c = do
411 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
412 let fd = haFD handle_
413 case haBufferMode handle_ of
414 LineBuffering -> hPutcBuffered handle_ True c
415 BlockBuffering _ -> hPutcBuffered handle_ False c
417 with (castCharToCChar c) $ \buf -> do
418 writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
421 hPutcBuffered handle_ is_line c = do
422 let ref = haBuffer handle_
425 w' <- writeCharIntoBuffer (bufBuf buf) w c
426 let new_buf = buf{ bufWPtr = w' }
427 if bufferFull new_buf || is_line && c == '\n'
429 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
430 writeIORef ref flushed_buf
432 writeIORef ref new_buf
435 hPutChars :: Handle -> [Char] -> IO ()
436 hPutChars handle [] = return ()
437 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
439 -- ---------------------------------------------------------------------------
442 -- We go to some trouble to avoid keeping the handle locked while we're
443 -- evaluating the string argument to hPutStr, in case doing so triggers another
444 -- I/O operation on the same handle which would lead to deadlock. The classic
447 -- putStr (trace "hello" "world")
449 -- so the basic scheme is this:
451 -- * copy the string into a fresh buffer,
452 -- * "commit" the buffer to the handle.
454 -- Committing may involve simply copying the contents of the new
455 -- buffer into the handle's buffer, flushing one or both buffers, or
456 -- maybe just swapping the buffers over (if the handle's buffer was
457 -- empty). See commitBuffer below.
459 -- | Computation 'hPutStr' @hdl s@ writes the string
460 -- @s@ to the file or channel managed by @hdl@.
462 -- This operation may fail with:
464 -- * 'isFullError' if the device is full; or
466 -- * 'isPermissionError' if another system resource limit would be exceeded.
468 hPutStr :: Handle -> String -> IO ()
469 hPutStr handle str = do
470 buffer_mode <- wantWritableHandle "hPutStr" handle
471 (\ handle_ -> do getSpareBuffer handle_)
473 (NoBuffering, _) -> do
474 hPutChars handle str -- v. slow, but we don't care
475 (LineBuffering, buf) -> do
476 writeLines handle buf str
477 (BlockBuffering _, buf) -> do
478 writeBlocks handle buf str
481 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
482 getSpareBuffer Handle__{haBuffer=ref,
487 NoBuffering -> return (mode, error "no buffer!")
489 bufs <- readIORef spare_ref
492 BufferListCons b rest -> do
493 writeIORef spare_ref rest
494 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
496 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
497 return (mode, new_buf)
500 writeLines :: Handle -> Buffer -> String -> IO ()
501 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
503 shoveString :: Int -> [Char] -> IO ()
504 -- check n == len first, to ensure that shoveString is strict in n.
505 shoveString n cs | n == len = do
506 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
507 writeLines hdl new_buf cs
508 shoveString n [] = do
509 commitBuffer hdl raw len n False{-no flush-} True{-release-}
511 shoveString n (c:cs) = do
512 n' <- writeCharIntoBuffer raw n c
515 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
516 writeLines hdl new_buf cs
522 writeBlocks :: Handle -> Buffer -> String -> IO ()
523 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
525 shoveString :: Int -> [Char] -> IO ()
526 -- check n == len first, to ensure that shoveString is strict in n.
527 shoveString n cs | n == len = do
528 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
529 writeBlocks hdl new_buf cs
530 shoveString n [] = do
531 commitBuffer hdl raw len n False{-no flush-} True{-release-}
533 shoveString n (c:cs) = do
534 n' <- writeCharIntoBuffer raw n c
539 -- -----------------------------------------------------------------------------
540 -- commitBuffer handle buf sz count flush release
542 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
543 -- 'count' bytes of data) to handle (handle must be block or line buffered).
547 -- for block/line buffering,
548 -- 1. If there isn't room in the handle buffer, flush the handle
551 -- 2. If the handle buffer is empty,
553 -- then write buf directly to the device.
554 -- else swap the handle buffer with buf.
556 -- 3. If the handle buffer is non-empty, copy buf into the
557 -- handle buffer. Then, if flush != 0, flush
561 :: Handle -- handle to commit to
562 -> RawBuffer -> Int -- address and size (in bytes) of buffer
563 -> Int -- number of bytes of data in buffer
564 -> Bool -- True <=> flush the handle afterward
565 -> Bool -- release the buffer?
568 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
569 wantWritableHandle "commitAndReleaseBuffer" hdl $
570 commitBuffer' raw sz count flush release
572 -- Explicitly lambda-lift this function to subvert GHC's full laziness
573 -- optimisations, which otherwise tends to float out subexpressions
574 -- past the \handle, which is really a pessimisation in this case because
575 -- that lambda is a one-shot lambda.
577 -- Don't forget to export the function, to stop it being inlined too
578 -- (this appears to be better than NOINLINE, because the strictness
579 -- analyser still gets to worker-wrapper it).
581 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
583 commitBuffer' raw sz@(I# _) count@(I# _) flush release
584 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
587 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
588 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
591 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
595 -- enough room in handle buffer?
596 if (not flush && (size - w > count))
597 -- The > is to be sure that we never exactly fill
598 -- up the buffer, which would require a flush. So
599 -- if copying the new data into the buffer would
600 -- make the buffer full, we just flush the existing
601 -- buffer and the new data immediately, rather than
602 -- copying before flushing.
604 -- not flushing, and there's enough room in the buffer:
605 -- just copy the data in and update bufWPtr.
606 then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
607 writeIORef ref old_buf{ bufWPtr = w + count }
608 return (newEmptyBuffer raw WriteBuffer sz)
610 -- else, we have to flush
611 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
614 Buffer{ bufBuf=raw, bufState=WriteBuffer,
615 bufRPtr=0, bufWPtr=count, bufSize=sz }
617 -- if: (a) we don't have to flush, and
618 -- (b) size(new buffer) == size(old buffer), and
619 -- (c) new buffer is not full,
620 -- we can just just swap them over...
621 if (not flush && sz == size && count /= sz)
623 writeIORef ref this_buf
626 -- otherwise, we have to flush the new data too,
627 -- and start with a fresh buffer
629 flushWriteBuffer fd (haIsStream handle_) this_buf
630 writeIORef ref flushed_buf
631 -- if the sizes were different, then allocate
632 -- a new buffer of the correct size.
634 then return (newEmptyBuffer raw WriteBuffer sz)
635 else allocateBuffer size WriteBuffer
637 -- release the buffer if necessary
639 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
640 if release && buf_ret_sz == size
642 spare_bufs <- readIORef spare_buf_ref
643 writeIORef spare_buf_ref
644 (BufferListCons buf_ret_raw spare_bufs)
649 -- ---------------------------------------------------------------------------
650 -- Reading/writing sequences of bytes.
652 -- ---------------------------------------------------------------------------
655 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
656 -- buffer @buf@ to the handle @hdl@. It returns ().
658 -- This operation may fail with:
660 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
661 -- reading end is closed. (If this is a POSIX system, and the program
662 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
663 -- instead, whose default action is to terminate the program).
665 hPutBuf :: Handle -- handle to write to
666 -> Ptr a -- address of buffer
667 -> Int -- number of bytes of data in buffer
669 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
672 :: Handle -- handle to write to
673 -> Ptr a -- address of buffer
674 -> Int -- number of bytes of data in buffer
675 -> IO Int -- returns: number of bytes written
676 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
678 hPutBuf':: Handle -- handle to write to
679 -> Ptr a -- address of buffer
680 -> Int -- number of bytes of data in buffer
681 -> Bool -- allow blocking?
683 hPutBuf' handle ptr count can_block
684 | count == 0 = return 0
685 | count < 0 = illegalBufferSize handle "hPutBuf" count
687 wantWritableHandle "hPutBuf" handle $
688 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
689 bufWrite fd ref is_stream ptr count can_block
691 bufWrite fd ref is_stream ptr count can_block =
692 seq count $ seq fd $ do -- strictness hack
693 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
696 -- enough room in handle buffer?
697 if (size - w > count)
698 -- There's enough room in the buffer:
699 -- just copy the data in and update bufWPtr.
700 then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)
701 writeIORef ref old_buf{ bufWPtr = w + count }
704 -- else, we have to flush
705 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
706 -- TODO: we should do a non-blocking flush here
707 writeIORef ref flushed_buf
708 -- if we can fit in the buffer, then just loop
710 then bufWrite fd ref is_stream ptr count can_block
712 then do writeChunk fd is_stream (castPtr ptr) count
714 else writeChunkNonBlocking fd is_stream ptr count
716 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
717 writeChunk fd is_stream ptr bytes = loop 0 bytes
719 loop :: Int -> Int -> IO ()
720 loop _ bytes | bytes <= 0 = return ()
722 r <- fromIntegral `liftM`
723 writeRawBufferPtr "writeChunk" fd is_stream ptr
724 off (fromIntegral bytes)
725 -- write can't return 0
726 loop (off + r) (bytes - r)
728 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
729 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
731 loop :: Int -> Int -> IO Int
732 loop off bytes | bytes <= 0 = return off
734 #ifndef mingw32_HOST_OS
735 ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)
736 let r = fromIntegral ssize :: Int
738 then do errno <- getErrno
739 if (errno == eAGAIN || errno == eWOULDBLOCK)
741 else throwErrno "writeChunk"
742 else loop (off + r) (bytes - r)
744 (ssize, rc) <- asyncWrite (fromIntegral fd)
745 (fromIntegral $ fromEnum is_stream)
748 let r = fromIntegral ssize :: Int
750 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
751 else loop (off + r) (bytes - r)
754 -- ---------------------------------------------------------------------------
757 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
758 -- into the buffer @buf@ until either EOF is reached or
759 -- @count@ 8-bit bytes have been read.
760 -- It returns the number of bytes actually read. This may be zero if
761 -- EOF was reached before any data was read (or if @count@ is zero).
763 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
764 -- smaller than @count@.
766 -- If the handle is a pipe or socket, and the writing end
767 -- is closed, 'hGetBuf' will behave as if EOF was reached.
769 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
771 | count == 0 = return 0
772 | count < 0 = illegalBufferSize h "hGetBuf" count
774 wantReadableHandle "hGetBuf" h $
775 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
776 bufRead fd ref is_stream ptr 0 count
778 -- small reads go through the buffer, large reads are satisfied by
779 -- taking data first from the buffer and then direct from the file
781 bufRead fd ref is_stream ptr so_far count =
782 seq fd $ seq so_far $ seq count $ do -- strictness hack
783 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
785 then if count > sz -- small read?
786 then do rest <- readChunk fd is_stream ptr count
787 return (so_far + rest)
788 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
790 Nothing -> return so_far -- got nothing, we're done
793 bufRead fd ref is_stream ptr so_far count
798 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
799 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
800 return (so_far + count)
804 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
805 writeIORef ref buf{ bufRPtr = r + count }
806 return (so_far + count)
809 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
810 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
811 let remaining = count - avail
812 so_far' = so_far + avail
813 ptr' = ptr `plusPtr` avail
816 then bufRead fd ref is_stream ptr' so_far' remaining
819 rest <- readChunk fd is_stream ptr' remaining
820 return (so_far' + rest)
822 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
823 readChunk fd is_stream ptr bytes = loop 0 bytes
825 loop :: Int -> Int -> IO Int
826 loop off bytes | bytes <= 0 = return off
828 r <- fromIntegral `liftM`
829 readRawBufferPtr "readChunk" fd is_stream
830 (castPtr ptr) off (fromIntegral bytes)
833 else loop (off + r) (bytes - r)
836 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
837 -- into the buffer @buf@ until either EOF is reached, or
838 -- @count@ 8-bit bytes have been read, or there is no more data available
839 -- to read immediately.
841 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
842 -- never block waiting for data to become available, instead it returns
843 -- only whatever data is available. To wait for data to arrive before
844 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
846 -- If the handle is a pipe or socket, and the writing end
847 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
849 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
850 hGetBufNonBlocking h ptr count
851 | count == 0 = return 0
852 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
854 wantReadableHandle "hGetBufNonBlocking" h $
855 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
856 bufReadNonBlocking fd ref is_stream ptr 0 count
858 bufReadNonBlocking fd ref is_stream ptr so_far count =
859 seq fd $ seq so_far $ seq count $ do -- strictness hack
860 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
862 then if count > sz -- large read?
863 then do rest <- readChunkNonBlocking fd is_stream ptr count
864 return (so_far + rest)
865 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
866 case buf' of { Buffer{ bufWPtr=w } ->
869 else do writeIORef ref buf'
870 bufReadNonBlocking fd ref is_stream ptr
872 -- NOTE: new count is 'min count w'
873 -- so we will just copy the contents of the
874 -- buffer in the recursive call, and not
881 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
882 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
883 return (so_far + count)
887 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
888 writeIORef ref buf{ bufRPtr = r + count }
889 return (so_far + count)
892 memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
893 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
894 let remaining = count - avail
895 so_far' = so_far + avail
896 ptr' = ptr `plusPtr` avail
898 -- we haven't attempted to read anything yet if we get to here.
900 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
903 rest <- readChunkNonBlocking fd is_stream ptr' remaining
904 return (so_far' + rest)
907 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
908 readChunkNonBlocking fd is_stream ptr bytes = do
910 readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream
911 (castPtr ptr) 0 (fromIntegral bytes)
913 -- we don't have non-blocking read support on Windows, so just invoke
914 -- the ordinary low-level read which will block until data is available,
915 -- but won't wait for the whole buffer to fill.
917 slurpFile :: FilePath -> IO (Ptr (), Int)
919 handle <- openFile fname ReadMode
920 sz <- hFileSize handle
921 if sz > fromIntegral (maxBound::Int) then
922 ioError (userError "slurpFile: file too big")
924 let sz_i = fromIntegral sz
925 if sz_i == 0 then return (nullPtr, 0) else do
926 chunk <- mallocBytes sz_i
927 r <- hGetBuf handle chunk sz_i
931 -- ---------------------------------------------------------------------------
934 foreign import ccall unsafe "__hscore_memcpy_src_off"
935 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
936 foreign import ccall unsafe "__hscore_memcpy_src_off"
937 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
938 foreign import ccall unsafe "__hscore_memcpy_dst_off"
939 memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
940 foreign import ccall unsafe "__hscore_memcpy_dst_off"
941 memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())
943 -----------------------------------------------------------------------------
946 illegalBufferSize :: Handle -> String -> Int -> IO a
947 illegalBufferSize handle fn sz =
948 ioException (IOError (Just handle)
950 ("illegal buffer size " ++ showsPrec 9 sz [])