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.
67 -- NOTE: in the current implementation, this is the only case that works
68 -- correctly (if @t@ is non-zero, then all other concurrent threads are
69 -- blocked until data is available).
71 -- This operation may fail with:
73 -- * 'isEOFError' if the end of file has been reached.
75 hWaitForInput :: Handle -> Int -> IO Bool
76 hWaitForInput h msecs = do
77 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
78 let ref = haBuffer handle_
81 if not (bufferEmpty buf)
86 then do buf' <- fillReadBuffer (haFD handle_) True
87 (haIsStream handle_) buf
90 else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
91 inputReady (fromIntegral (haFD handle_))
92 (fromIntegral msecs) (haIsStream handle_)
95 foreign import ccall safe "inputReady"
96 inputReady :: CInt -> CInt -> Bool -> IO CInt
98 -- ---------------------------------------------------------------------------
101 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
102 -- channel managed by @hdl@, blocking until a character is available.
104 -- This operation may fail with:
106 -- * 'isEOFError' if the end of file has been reached.
108 hGetChar :: Handle -> IO Char
110 wantReadableHandle "hGetChar" handle $ \handle_ -> do
112 let fd = haFD handle_
113 ref = haBuffer handle_
116 if not (bufferEmpty buf)
117 then hGetcBuffered fd ref buf
121 case haBufferMode handle_ of
123 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
124 hGetcBuffered fd ref new_buf
125 BlockBuffering _ -> do
126 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
128 -- don't wait for a completely full buffer.
129 hGetcBuffered fd ref new_buf
131 -- make use of the minimal buffer we already have
133 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
136 else do (c,_) <- readCharFromBuffer raw 0
139 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
140 = do (c,r) <- readCharFromBuffer b r
141 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
142 | otherwise = buf{ bufRPtr=r }
143 writeIORef ref new_buf
146 -- ---------------------------------------------------------------------------
149 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
152 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
153 -- channel managed by @hdl@.
155 -- This operation may fail with:
157 -- * 'isEOFError' if the end of file is encountered when reading
158 -- the /first/ character of the line.
160 -- If 'hGetLine' encounters end-of-file at any other point while reading
161 -- in a line, it is treated as a line terminator and the (partial)
164 hGetLine :: Handle -> IO String
166 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
167 case haBufferMode handle_ of
168 NoBuffering -> return Nothing
170 l <- hGetLineBuffered handle_
172 BlockBuffering _ -> do
173 l <- hGetLineBuffered handle_
176 Nothing -> hGetLineUnBuffered h
180 hGetLineBuffered handle_ = do
181 let ref = haBuffer handle_
183 hGetLineBufferedLoop handle_ ref buf []
186 hGetLineBufferedLoop handle_ ref
187 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
189 -- find the end-of-line character, if there is one
191 | r == w = return (False, w)
193 (c,r') <- readCharFromBuffer raw r
195 then return (True, r) -- NB. not r': don't include the '\n'
198 (eol, off) <- loop raw r
201 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
204 xs <- unpack raw r off
206 -- if eol == True, then off is the offset of the '\n'
207 -- otherwise off == w and the buffer is now empty.
209 then do if (w == off + 1)
210 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
211 else writeIORef ref buf{ bufRPtr = off + 1 }
212 return (concat (reverse (xs:xss)))
214 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
215 buf{ bufWPtr=0, bufRPtr=0 }
217 -- Nothing indicates we caught an EOF, and we may have a
218 -- partial line to return.
220 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
221 let str = concat (reverse (xs:xss))
226 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
229 maybeFillReadBuffer fd is_line is_stream buf
231 (do buf <- fillReadBuffer fd is_line is_stream buf
234 (\e -> do if isEOFError e
239 unpack :: RawBuffer -> Int -> Int -> IO [Char]
240 unpack buf r 0 = return ""
241 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
244 | i <# r = (# s, acc #)
246 case readCharArray# buf i s of
247 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
250 hGetLineUnBuffered :: Handle -> IO String
251 hGetLineUnBuffered h = do
264 if isEOFError err then
274 -- -----------------------------------------------------------------------------
277 -- hGetContents on a DuplexHandle only affects the read side: you can
278 -- carry on writing to it afterwards.
280 -- | Computation 'hGetContents' @hdl@ returns the list of characters
281 -- corresponding to the unread portion of the channel or file managed
282 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
283 -- In this state, @hdl@ is effectively closed,
284 -- but items are read from @hdl@ on demand and accumulated in a special
285 -- list returned by 'hGetContents' @hdl@.
287 -- Any operation that fails because a handle is closed,
288 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
289 -- A semi-closed handle becomes closed:
291 -- * if 'hClose' is applied to it;
293 -- * if an I\/O error occurs when reading an item from the handle;
295 -- * or once the entire contents of the handle has been read.
297 -- Once a semi-closed handle becomes closed, the contents of the
298 -- associated list becomes fixed. The contents of this final list is
299 -- only partially specified: it will contain at least all the items of
300 -- the stream that were evaluated prior to the handle becoming closed.
302 -- Any I\/O errors encountered while a handle is semi-closed are simply
305 -- This operation may fail with:
307 -- * 'isEOFError' if the end of file has been reached.
309 hGetContents :: Handle -> IO String
310 hGetContents handle =
311 withHandle "hGetContents" handle $ \handle_ ->
312 case haType handle_ of
313 ClosedHandle -> ioe_closedHandle
314 SemiClosedHandle -> ioe_closedHandle
315 AppendHandle -> ioe_notReadable
316 WriteHandle -> ioe_notReadable
317 _ -> do xs <- lazyRead handle
318 return (handle_{ haType=SemiClosedHandle}, xs )
320 -- Note that someone may close the semi-closed handle (or change its
321 -- buffering), so each time these lazy read functions are pulled on,
322 -- they have to check whether the handle has indeed been closed.
324 lazyRead :: Handle -> IO String
327 withHandle "lazyRead" handle $ \ handle_ -> do
328 case haType handle_ of
329 ClosedHandle -> return (handle_, "")
330 SemiClosedHandle -> lazyRead' handle handle_
332 (IOError (Just handle) IllegalOperation "lazyRead"
333 "illegal handle type" Nothing)
335 lazyRead' h handle_ = do
336 let ref = haBuffer handle_
339 -- even a NoBuffering handle can have a char in the buffer...
342 if not (bufferEmpty buf)
343 then lazyReadHaveBuffer h handle_ fd ref buf
346 case haBufferMode handle_ of
348 -- make use of the minimal buffer we already have
350 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
352 then do handle_ <- hClose_help handle_
354 else do (c,_) <- readCharFromBuffer raw 0
356 return (handle_, c : rest)
358 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
359 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
361 -- we never want to block during the read, so we call fillReadBuffer with
362 -- is_line==True, which tells it to "just read what there is".
363 lazyReadBuffered h handle_ fd ref buf = do
365 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
366 lazyReadHaveBuffer h handle_ fd ref buf
368 -- all I/O errors are discarded. Additionally, we close the handle.
369 (\e -> do handle_ <- hClose_help handle_
373 lazyReadHaveBuffer h handle_ fd ref buf = do
375 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
376 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
380 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
381 unpackAcc buf r 0 acc = return acc
382 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
385 | i <# r = (# s, acc #)
387 case readCharArray# buf i s of
388 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
390 -- ---------------------------------------------------------------------------
393 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
394 -- file or channel managed by @hdl@. Characters may be buffered if
395 -- buffering is enabled for @hdl@.
397 -- This operation may fail with:
399 -- * 'isFullError' if the device is full; or
401 -- * 'isPermissionError' if another system resource limit would be exceeded.
403 hPutChar :: Handle -> Char -> IO ()
404 hPutChar handle c = do
406 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
407 let fd = haFD handle_
408 case haBufferMode handle_ of
409 LineBuffering -> hPutcBuffered handle_ True c
410 BlockBuffering _ -> hPutcBuffered handle_ False c
412 with (castCharToCChar c) $ \buf -> do
413 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
416 hPutcBuffered handle_ is_line c = do
417 let ref = haBuffer handle_
420 w' <- writeCharIntoBuffer (bufBuf buf) w c
421 let new_buf = buf{ bufWPtr = w' }
422 if bufferFull new_buf || is_line && c == '\n'
424 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
425 writeIORef ref flushed_buf
427 writeIORef ref new_buf
430 hPutChars :: Handle -> [Char] -> IO ()
431 hPutChars handle [] = return ()
432 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
434 -- ---------------------------------------------------------------------------
437 -- We go to some trouble to avoid keeping the handle locked while we're
438 -- evaluating the string argument to hPutStr, in case doing so triggers another
439 -- I/O operation on the same handle which would lead to deadlock. The classic
442 -- putStr (trace "hello" "world")
444 -- so the basic scheme is this:
446 -- * copy the string into a fresh buffer,
447 -- * "commit" the buffer to the handle.
449 -- Committing may involve simply copying the contents of the new
450 -- buffer into the handle's buffer, flushing one or both buffers, or
451 -- maybe just swapping the buffers over (if the handle's buffer was
452 -- empty). See commitBuffer below.
454 -- | Computation 'hPutStr' @hdl s@ writes the string
455 -- @s@ to the file or channel managed by @hdl@.
457 -- This operation may fail with:
459 -- * 'isFullError' if the device is full; or
461 -- * 'isPermissionError' if another system resource limit would be exceeded.
463 hPutStr :: Handle -> String -> IO ()
464 hPutStr handle str = do
465 buffer_mode <- wantWritableHandle "hPutStr" handle
466 (\ handle_ -> do getSpareBuffer handle_)
468 (NoBuffering, _) -> do
469 hPutChars handle str -- v. slow, but we don't care
470 (LineBuffering, buf) -> do
471 writeLines handle buf str
472 (BlockBuffering _, buf) -> do
473 writeBlocks handle buf str
476 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
477 getSpareBuffer Handle__{haBuffer=ref,
482 NoBuffering -> return (mode, error "no buffer!")
484 bufs <- readIORef spare_ref
487 BufferListCons b rest -> do
488 writeIORef spare_ref rest
489 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
491 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
492 return (mode, new_buf)
495 writeLines :: Handle -> Buffer -> String -> IO ()
496 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
498 shoveString :: Int -> [Char] -> IO ()
499 -- check n == len first, to ensure that shoveString is strict in n.
500 shoveString n cs | n == len = do
501 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
502 writeLines hdl new_buf cs
503 shoveString n [] = do
504 commitBuffer hdl raw len n False{-no flush-} True{-release-}
506 shoveString n (c:cs) = do
507 n' <- writeCharIntoBuffer raw n c
510 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
511 writeLines hdl new_buf cs
517 writeBlocks :: Handle -> Buffer -> String -> IO ()
518 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
520 shoveString :: Int -> [Char] -> IO ()
521 -- check n == len first, to ensure that shoveString is strict in n.
522 shoveString n cs | n == len = do
523 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
524 writeBlocks hdl new_buf cs
525 shoveString n [] = do
526 commitBuffer hdl raw len n False{-no flush-} True{-release-}
528 shoveString n (c:cs) = do
529 n' <- writeCharIntoBuffer raw n c
534 -- -----------------------------------------------------------------------------
535 -- commitBuffer handle buf sz count flush release
537 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
538 -- 'count' bytes of data) to handle (handle must be block or line buffered).
542 -- for block/line buffering,
543 -- 1. If there isn't room in the handle buffer, flush the handle
546 -- 2. If the handle buffer is empty,
548 -- then write buf directly to the device.
549 -- else swap the handle buffer with buf.
551 -- 3. If the handle buffer is non-empty, copy buf into the
552 -- handle buffer. Then, if flush != 0, flush
556 :: Handle -- handle to commit to
557 -> RawBuffer -> Int -- address and size (in bytes) of buffer
558 -> Int -- number of bytes of data in buffer
559 -> Bool -- True <=> flush the handle afterward
560 -> Bool -- release the buffer?
563 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
564 wantWritableHandle "commitAndReleaseBuffer" hdl $
565 commitBuffer' raw sz count flush release
567 -- Explicitly lambda-lift this function to subvert GHC's full laziness
568 -- optimisations, which otherwise tends to float out subexpressions
569 -- past the \handle, which is really a pessimisation in this case because
570 -- that lambda is a one-shot lambda.
572 -- Don't forget to export the function, to stop it being inlined too
573 -- (this appears to be better than NOINLINE, because the strictness
574 -- analyser still gets to worker-wrapper it).
576 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
578 commitBuffer' raw sz@(I# _) count@(I# _) flush release
579 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
582 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
583 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
586 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
590 -- enough room in handle buffer?
591 if (not flush && (size - w > count))
592 -- The > is to be sure that we never exactly fill
593 -- up the buffer, which would require a flush. So
594 -- if copying the new data into the buffer would
595 -- make the buffer full, we just flush the existing
596 -- buffer and the new data immediately, rather than
597 -- copying before flushing.
599 -- not flushing, and there's enough room in the buffer:
600 -- just copy the data in and update bufWPtr.
601 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
602 writeIORef ref old_buf{ bufWPtr = w + count }
603 return (newEmptyBuffer raw WriteBuffer sz)
605 -- else, we have to flush
606 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
609 Buffer{ bufBuf=raw, bufState=WriteBuffer,
610 bufRPtr=0, bufWPtr=count, bufSize=sz }
612 -- if: (a) we don't have to flush, and
613 -- (b) size(new buffer) == size(old buffer), and
614 -- (c) new buffer is not full,
615 -- we can just just swap them over...
616 if (not flush && sz == size && count /= sz)
618 writeIORef ref this_buf
621 -- otherwise, we have to flush the new data too,
622 -- and start with a fresh buffer
624 flushWriteBuffer fd (haIsStream handle_) this_buf
625 writeIORef ref flushed_buf
626 -- if the sizes were different, then allocate
627 -- a new buffer of the correct size.
629 then return (newEmptyBuffer raw WriteBuffer sz)
630 else allocateBuffer size WriteBuffer
632 -- release the buffer if necessary
634 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
635 if release && buf_ret_sz == size
637 spare_bufs <- readIORef spare_buf_ref
638 writeIORef spare_buf_ref
639 (BufferListCons buf_ret_raw spare_bufs)
644 -- ---------------------------------------------------------------------------
645 -- Reading/writing sequences of bytes.
647 -- ---------------------------------------------------------------------------
650 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
651 -- buffer @buf@ to the handle @hdl@. It returns ().
653 -- This operation may fail with:
655 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
656 -- reading end is closed. (If this is a POSIX system, and the program
657 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
658 -- instead, whose default action is to terminate the program).
660 hPutBuf :: Handle -- handle to write to
661 -> Ptr a -- address of buffer
662 -> Int -- number of bytes of data in buffer
664 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
667 :: Handle -- handle to write to
668 -> Ptr a -- address of buffer
669 -> Int -- number of bytes of data in buffer
670 -> IO Int -- returns: number of bytes written
671 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
673 hPutBuf':: Handle -- handle to write to
674 -> Ptr a -- address of buffer
675 -> Int -- number of bytes of data in buffer
676 -> Bool -- allow blocking?
678 hPutBuf' handle ptr count can_block
679 | count == 0 = return 0
680 | count < 0 = illegalBufferSize handle "hPutBuf" count
682 wantWritableHandle "hPutBuf" handle $
683 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
684 bufWrite fd ref is_stream ptr count can_block
686 bufWrite fd ref is_stream ptr count can_block =
687 seq count $ seq fd $ do -- strictness hack
688 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
691 -- enough room in handle buffer?
692 if (size - w > count)
693 -- There's enough room in the buffer:
694 -- just copy the data in and update bufWPtr.
695 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
696 writeIORef ref old_buf{ bufWPtr = w + count }
699 -- else, we have to flush
700 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
701 -- TODO: we should do a non-blocking flush here
702 writeIORef ref flushed_buf
703 -- if we can fit in the buffer, then just loop
705 then bufWrite fd ref is_stream ptr count can_block
707 then do writeChunk fd is_stream (castPtr ptr) count
709 else writeChunkNonBlocking fd is_stream ptr count
711 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
712 writeChunk fd is_stream ptr bytes = loop 0 bytes
714 loop :: Int -> Int -> IO ()
715 loop _ bytes | bytes <= 0 = return ()
717 r <- fromIntegral `liftM`
718 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
719 off (fromIntegral bytes)
720 -- write can't return 0
721 loop (off + r) (bytes - r)
723 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
724 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
726 loop :: Int -> Int -> IO Int
727 loop off bytes | bytes <= 0 = return off
729 #ifndef mingw32_HOST_OS
730 ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
731 let r = fromIntegral ssize :: Int
733 then do errno <- getErrno
734 if (errno == eAGAIN || errno == eWOULDBLOCK)
736 else throwErrno "writeChunk"
737 else loop (off + r) (bytes - r)
739 (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
742 let r = fromIntegral ssize :: Int
744 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
745 else loop (off + r) (bytes - r)
748 -- ---------------------------------------------------------------------------
751 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
752 -- into the buffer @buf@ until either EOF is reached or
753 -- @count@ 8-bit bytes have been read.
754 -- It returns the number of bytes actually read. This may be zero if
755 -- EOF was reached before any data was read (or if @count@ is zero).
757 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
758 -- smaller than @count@.
760 -- If the handle is a pipe or socket, and the writing end
761 -- is closed, 'hGetBuf' will behave as if EOF was reached.
763 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
765 | count == 0 = return 0
766 | count < 0 = illegalBufferSize h "hGetBuf" count
768 wantReadableHandle "hGetBuf" h $
769 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
770 bufRead fd ref is_stream ptr 0 count
772 -- small reads go through the buffer, large reads are satisfied by
773 -- taking data first from the buffer and then direct from the file
775 bufRead fd ref is_stream ptr so_far count =
776 seq fd $ seq so_far $ seq count $ do -- strictness hack
777 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
779 then if count > sz -- small read?
780 then do rest <- readChunk fd is_stream ptr count
781 return (so_far + rest)
782 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
784 Nothing -> return so_far -- got nothing, we're done
787 bufRead fd ref is_stream ptr so_far count
792 memcpy_ptr_baoff ptr raw r (fromIntegral count)
793 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
794 return (so_far + count)
798 memcpy_ptr_baoff ptr raw r (fromIntegral count)
799 writeIORef ref buf{ bufRPtr = r + count }
800 return (so_far + count)
803 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
804 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
805 let remaining = count - avail
806 so_far' = so_far + avail
807 ptr' = ptr `plusPtr` avail
810 then bufRead fd ref is_stream ptr' so_far' remaining
813 rest <- readChunk fd is_stream ptr' remaining
814 return (so_far' + rest)
816 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
817 readChunk fd is_stream ptr bytes = loop 0 bytes
819 loop :: Int -> Int -> IO Int
820 loop off bytes | bytes <= 0 = return off
822 r <- fromIntegral `liftM`
823 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
824 (castPtr ptr) off (fromIntegral bytes)
827 else loop (off + r) (bytes - r)
830 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
831 -- into the buffer @buf@ until either EOF is reached, or
832 -- @count@ 8-bit bytes have been read, or there is no more data available
833 -- to read immediately.
835 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
836 -- never block waiting for data to become available, instead it returns
837 -- only whatever data is available. To wait for data to arrive before
838 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
840 -- If the handle is a pipe or socket, and the writing end
841 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
843 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
844 hGetBufNonBlocking h ptr count
845 | count == 0 = return 0
846 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
848 wantReadableHandle "hGetBufNonBlocking" h $
849 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
850 bufReadNonBlocking fd ref is_stream ptr 0 count
852 bufReadNonBlocking fd ref is_stream ptr so_far count =
853 seq fd $ seq so_far $ seq count $ do -- strictness hack
854 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
856 then if count > sz -- large read?
857 then do rest <- readChunkNonBlocking fd is_stream ptr count
858 return (so_far + rest)
859 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
860 case buf' of { Buffer{ bufWPtr=w } ->
863 else do writeIORef ref buf'
864 bufReadNonBlocking fd ref is_stream ptr
866 -- NOTE: new count is 'min count w'
867 -- so we will just copy the contents of the
868 -- buffer in the recursive call, and not
875 memcpy_ptr_baoff ptr raw r (fromIntegral count)
876 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
877 return (so_far + count)
881 memcpy_ptr_baoff ptr raw r (fromIntegral count)
882 writeIORef ref buf{ bufRPtr = r + count }
883 return (so_far + count)
886 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
887 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
888 let remaining = count - avail
889 so_far' = so_far + avail
890 ptr' = ptr `plusPtr` avail
892 -- we haven't attempted to read anything yet if we get to here.
894 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
897 rest <- readChunkNonBlocking fd is_stream ptr' remaining
898 return (so_far' + rest)
901 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
902 readChunkNonBlocking fd is_stream ptr bytes = do
903 #ifndef mingw32_HOST_OS
904 ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
905 let r = fromIntegral ssize :: Int
907 then do errno <- getErrno
908 if (errno == eAGAIN || errno == eWOULDBLOCK)
910 else throwErrno "readChunk"
914 readRawBufferPtr "readChunkNonBlocking" (fromIntegral fd) is_stream
915 (castPtr ptr) 0 (fromIntegral bytes)
917 -- we don't have non-blocking read support on Windows, so just invoke
918 -- the ordinary low-level read which will block until data is available,
919 -- but won't wait for the whole buffer to fill.
922 slurpFile :: FilePath -> IO (Ptr (), Int)
924 handle <- openFile fname ReadMode
925 sz <- hFileSize handle
926 if sz > fromIntegral (maxBound::Int) then
927 ioError (userError "slurpFile: file too big")
929 let sz_i = fromIntegral sz
930 if sz_i == 0 then return (nullPtr, 0) else do
931 chunk <- mallocBytes sz_i
932 r <- hGetBuf handle chunk sz_i
936 -- ---------------------------------------------------------------------------
939 foreign import ccall unsafe "__hscore_memcpy_src_off"
940 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
941 foreign import ccall unsafe "__hscore_memcpy_src_off"
942 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
943 foreign import ccall unsafe "__hscore_memcpy_dst_off"
944 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
945 foreign import ccall unsafe "__hscore_memcpy_dst_off"
946 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
948 -----------------------------------------------------------------------------
951 illegalBufferSize :: Handle -> String -> Int -> IO a
952 illegalBufferSize handle fn (sz :: Int) =
953 ioException (IOError (Just handle)
955 ("illegal buffer size " ++ showsPrec 9 sz [])