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 #ifdef mingw32_TARGET_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.
68 -- NOTE: in the current implementation, this is the only case that works
69 -- correctly (if @t@ is non-zero, then all other concurrent threads are
70 -- blocked until data is available).
72 -- This operation may fail with:
74 -- * 'isEOFError' if the end of file has been reached.
76 hWaitForInput :: Handle -> Int -> IO Bool
77 hWaitForInput h msecs = do
78 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
79 let ref = haBuffer handle_
82 if not (bufferEmpty buf)
87 then do buf' <- fillReadBuffer (haFD handle_) True
88 (haIsStream handle_) buf
91 else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
92 inputReady (fromIntegral (haFD handle_))
93 (fromIntegral msecs) (haIsStream handle_)
96 foreign import ccall unsafe "inputReady"
97 inputReady :: CInt -> CInt -> Bool -> IO CInt
99 -- ---------------------------------------------------------------------------
102 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
103 -- channel managed by @hdl@, blocking until a character is available.
105 -- This operation may fail with:
107 -- * 'isEOFError' if the end of file has been reached.
109 hGetChar :: Handle -> IO Char
111 wantReadableHandle "hGetChar" handle $ \handle_ -> do
113 let fd = haFD handle_
114 ref = haBuffer handle_
117 if not (bufferEmpty buf)
118 then hGetcBuffered fd ref buf
122 case haBufferMode handle_ of
124 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
125 hGetcBuffered fd ref new_buf
126 BlockBuffering _ -> do
127 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
129 -- don't wait for a completely full buffer.
130 hGetcBuffered fd ref new_buf
132 -- make use of the minimal buffer we already have
134 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
137 else do (c,_) <- readCharFromBuffer raw 0
140 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
141 = do (c,r) <- readCharFromBuffer b r
142 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
143 | otherwise = buf{ bufRPtr=r }
144 writeIORef ref new_buf
147 -- ---------------------------------------------------------------------------
150 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
153 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
154 -- channel managed by @hdl@.
156 -- This operation may fail with:
158 -- * 'isEOFError' if the end of file is encountered when reading
159 -- the /first/ character of the line.
161 -- If 'hGetLine' encounters end-of-file at any other point while reading
162 -- in a line, it is treated as a line terminator and the (partial)
165 hGetLine :: Handle -> IO String
167 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
168 case haBufferMode handle_ of
169 NoBuffering -> return Nothing
171 l <- hGetLineBuffered handle_
173 BlockBuffering _ -> do
174 l <- hGetLineBuffered handle_
177 Nothing -> hGetLineUnBuffered h
181 hGetLineBuffered handle_ = do
182 let ref = haBuffer handle_
184 hGetLineBufferedLoop handle_ ref buf []
187 hGetLineBufferedLoop handle_ ref
188 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
190 -- find the end-of-line character, if there is one
192 | r == w = return (False, w)
194 (c,r') <- readCharFromBuffer raw r
196 then return (True, r) -- NB. not r': don't include the '\n'
199 (eol, off) <- loop raw r
202 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
205 xs <- unpack raw r off
207 -- if eol == True, then off is the offset of the '\n'
208 -- otherwise off == w and the buffer is now empty.
210 then do if (w == off + 1)
211 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
212 else writeIORef ref buf{ bufRPtr = off + 1 }
213 return (concat (reverse (xs:xss)))
215 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
216 buf{ bufWPtr=0, bufRPtr=0 }
218 -- Nothing indicates we caught an EOF, and we may have a
219 -- partial line to return.
221 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
222 let str = concat (reverse (xs:xss))
227 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
230 maybeFillReadBuffer fd is_line is_stream buf
232 (do buf <- fillReadBuffer fd is_line is_stream buf
235 (\e -> do if isEOFError e
240 unpack :: RawBuffer -> Int -> Int -> IO [Char]
241 unpack buf r 0 = return ""
242 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
245 | i <# r = (# s, acc #)
247 case readCharArray# buf i s of
248 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
251 hGetLineUnBuffered :: Handle -> IO String
252 hGetLineUnBuffered h = do
265 if isEOFError err then
275 -- -----------------------------------------------------------------------------
278 -- hGetContents on a DuplexHandle only affects the read side: you can
279 -- carry on writing to it afterwards.
281 -- | Computation 'hGetContents' @hdl@ returns the list of characters
282 -- corresponding to the unread portion of the channel or file managed
283 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
284 -- In this state, @hdl@ is effectively closed,
285 -- but items are read from @hdl@ on demand and accumulated in a special
286 -- list returned by 'hGetContents' @hdl@.
288 -- Any operation that fails because a handle is closed,
289 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
290 -- A semi-closed handle becomes closed:
292 -- * if 'hClose' is applied to it;
294 -- * if an I\/O error occurs when reading an item from the handle;
296 -- * or once the entire contents of the handle has been read.
298 -- Once a semi-closed handle becomes closed, the contents of the
299 -- associated list becomes fixed. The contents of this final list is
300 -- only partially specified: it will contain at least all the items of
301 -- the stream that were evaluated prior to the handle becoming closed.
303 -- Any I\/O errors encountered while a handle is semi-closed are simply
306 -- This operation may fail with:
308 -- * 'isEOFError' if the end of file has been reached.
310 hGetContents :: Handle -> IO String
311 hGetContents handle =
312 withHandle "hGetContents" handle $ \handle_ ->
313 case haType handle_ of
314 ClosedHandle -> ioe_closedHandle
315 SemiClosedHandle -> ioe_closedHandle
316 AppendHandle -> ioe_notReadable
317 WriteHandle -> ioe_notReadable
318 _ -> do xs <- lazyRead handle
319 return (handle_{ haType=SemiClosedHandle}, xs )
321 -- Note that someone may close the semi-closed handle (or change its
322 -- buffering), so each time these lazy read functions are pulled on,
323 -- they have to check whether the handle has indeed been closed.
325 lazyRead :: Handle -> IO String
328 withHandle "lazyRead" handle $ \ handle_ -> do
329 case haType handle_ of
330 ClosedHandle -> return (handle_, "")
331 SemiClosedHandle -> lazyRead' handle handle_
333 (IOError (Just handle) IllegalOperation "lazyRead"
334 "illegal handle type" Nothing)
336 lazyRead' h handle_ = do
337 let ref = haBuffer handle_
340 -- even a NoBuffering handle can have a char in the buffer...
343 if not (bufferEmpty buf)
344 then lazyReadHaveBuffer h handle_ fd ref buf
347 case haBufferMode handle_ of
349 -- make use of the minimal buffer we already have
351 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
353 then do handle_ <- hClose_help handle_
355 else do (c,_) <- readCharFromBuffer raw 0
357 return (handle_, c : rest)
359 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
360 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
362 -- we never want to block during the read, so we call fillReadBuffer with
363 -- is_line==True, which tells it to "just read what there is".
364 lazyReadBuffered h handle_ fd ref buf = do
366 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
367 lazyReadHaveBuffer h handle_ fd ref buf
369 -- all I/O errors are discarded. Additionally, we close the handle.
370 (\e -> do handle_ <- hClose_help handle_
374 lazyReadHaveBuffer h handle_ fd ref buf = do
376 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
377 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
381 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
382 unpackAcc buf r 0 acc = return acc
383 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
386 | i <# r = (# s, acc #)
388 case readCharArray# buf i s of
389 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
391 -- ---------------------------------------------------------------------------
394 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
395 -- file or channel managed by @hdl@. Characters may be buffered if
396 -- buffering is enabled for @hdl@.
398 -- This operation may fail with:
400 -- * 'isFullError' if the device is full; or
402 -- * 'isPermissionError' if another system resource limit would be exceeded.
404 hPutChar :: Handle -> Char -> IO ()
406 c `seq` do -- must evaluate c before grabbing the handle lock
407 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
408 let fd = haFD handle_
409 case haBufferMode handle_ of
410 LineBuffering -> hPutcBuffered handle_ True c
411 BlockBuffering _ -> hPutcBuffered handle_ False c
413 withObject (castCharToCChar c) $ \buf -> do
414 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
417 hPutcBuffered handle_ is_line c = do
418 let ref = haBuffer handle_
421 w' <- writeCharIntoBuffer (bufBuf buf) w c
422 let new_buf = buf{ bufWPtr = w' }
423 if bufferFull new_buf || is_line && c == '\n'
425 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
426 writeIORef ref flushed_buf
428 writeIORef ref new_buf
431 hPutChars :: Handle -> [Char] -> IO ()
432 hPutChars handle [] = return ()
433 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
435 -- ---------------------------------------------------------------------------
438 -- We go to some trouble to avoid keeping the handle locked while we're
439 -- evaluating the string argument to hPutStr, in case doing so triggers another
440 -- I/O operation on the same handle which would lead to deadlock. The classic
443 -- putStr (trace "hello" "world")
445 -- so the basic scheme is this:
447 -- * copy the string into a fresh buffer,
448 -- * "commit" the buffer to the handle.
450 -- Committing may involve simply copying the contents of the new
451 -- buffer into the handle's buffer, flushing one or both buffers, or
452 -- maybe just swapping the buffers over (if the handle's buffer was
453 -- empty). See commitBuffer below.
455 -- | Computation 'hPutStr' @hdl s@ writes the string
456 -- @s@ to the file or channel managed by @hdl@.
458 -- This operation may fail with:
460 -- * 'isFullError' if the device is full; or
462 -- * 'isPermissionError' if another system resource limit would be exceeded.
464 hPutStr :: Handle -> String -> IO ()
465 hPutStr handle str = do
466 buffer_mode <- wantWritableHandle "hPutStr" handle
467 (\ handle_ -> do getSpareBuffer handle_)
469 (NoBuffering, _) -> do
470 hPutChars handle str -- v. slow, but we don't care
471 (LineBuffering, buf) -> do
472 writeLines handle buf str
473 (BlockBuffering _, buf) -> do
474 writeBlocks handle buf str
477 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
478 getSpareBuffer Handle__{haBuffer=ref,
483 NoBuffering -> return (mode, error "no buffer!")
485 bufs <- readIORef spare_ref
488 BufferListCons b rest -> do
489 writeIORef spare_ref rest
490 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
492 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
493 return (mode, new_buf)
496 writeLines :: Handle -> Buffer -> String -> IO ()
497 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
499 shoveString :: Int -> [Char] -> IO ()
500 -- check n == len first, to ensure that shoveString is strict in n.
501 shoveString n cs | n == len = do
502 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
503 writeLines hdl new_buf cs
504 shoveString n [] = do
505 commitBuffer hdl raw len n False{-no flush-} True{-release-}
507 shoveString n (c:cs) = do
508 n' <- writeCharIntoBuffer raw n c
511 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
512 writeLines hdl new_buf cs
518 writeBlocks :: Handle -> Buffer -> String -> IO ()
519 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
521 shoveString :: Int -> [Char] -> IO ()
522 -- check n == len first, to ensure that shoveString is strict in n.
523 shoveString n cs | n == len = do
524 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
525 writeBlocks hdl new_buf cs
526 shoveString n [] = do
527 commitBuffer hdl raw len n False{-no flush-} True{-release-}
529 shoveString n (c:cs) = do
530 n' <- writeCharIntoBuffer raw n c
535 -- -----------------------------------------------------------------------------
536 -- commitBuffer handle buf sz count flush release
538 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
539 -- 'count' bytes of data) to handle (handle must be block or line buffered).
543 -- for block/line buffering,
544 -- 1. If there isn't room in the handle buffer, flush the handle
547 -- 2. If the handle buffer is empty,
549 -- then write buf directly to the device.
550 -- else swap the handle buffer with buf.
552 -- 3. If the handle buffer is non-empty, copy buf into the
553 -- handle buffer. Then, if flush != 0, flush
557 :: Handle -- handle to commit to
558 -> RawBuffer -> Int -- address and size (in bytes) of buffer
559 -> Int -- number of bytes of data in buffer
560 -> Bool -- True <=> flush the handle afterward
561 -> Bool -- release the buffer?
564 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
565 wantWritableHandle "commitAndReleaseBuffer" hdl $
566 commitBuffer' hdl raw sz count flush release
568 -- Explicitly lambda-lift this function to subvert GHC's full laziness
569 -- optimisations, which otherwise tends to float out subexpressions
570 -- past the \handle, which is really a pessimisation in this case because
571 -- that lambda is a one-shot lambda.
573 -- Don't forget to export the function, to stop it being inlined too
574 -- (this appears to be better than NOINLINE, because the strictness
575 -- analyser still gets to worker-wrapper it).
577 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
579 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
580 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
583 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
584 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
587 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
591 -- enough room in handle buffer?
592 if (not flush && (size - w > count))
593 -- The > is to be sure that we never exactly fill
594 -- up the buffer, which would require a flush. So
595 -- if copying the new data into the buffer would
596 -- make the buffer full, we just flush the existing
597 -- buffer and the new data immediately, rather than
598 -- copying before flushing.
600 -- not flushing, and there's enough room in the buffer:
601 -- just copy the data in and update bufWPtr.
602 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
603 writeIORef ref old_buf{ bufWPtr = w + count }
604 return (newEmptyBuffer raw WriteBuffer sz)
606 -- else, we have to flush
607 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
610 Buffer{ bufBuf=raw, bufState=WriteBuffer,
611 bufRPtr=0, bufWPtr=count, bufSize=sz }
613 -- if: (a) we don't have to flush, and
614 -- (b) size(new buffer) == size(old buffer), and
615 -- (c) new buffer is not full,
616 -- we can just just swap them over...
617 if (not flush && sz == size && count /= sz)
619 writeIORef ref this_buf
622 -- otherwise, we have to flush the new data too,
623 -- and start with a fresh buffer
625 flushWriteBuffer fd (haIsStream handle_) this_buf
626 writeIORef ref flushed_buf
627 -- if the sizes were different, then allocate
628 -- a new buffer of the correct size.
630 then return (newEmptyBuffer raw WriteBuffer sz)
631 else allocateBuffer size WriteBuffer
633 -- release the buffer if necessary
635 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
636 if release && buf_ret_sz == size
638 spare_bufs <- readIORef spare_buf_ref
639 writeIORef spare_buf_ref
640 (BufferListCons buf_ret_raw spare_bufs)
645 -- ---------------------------------------------------------------------------
646 -- Reading/writing sequences of bytes.
648 -- ---------------------------------------------------------------------------
651 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
652 -- buffer @buf@ to the handle @hdl@. It returns ().
654 -- This operation may fail with:
656 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
657 -- reading end is closed. (If this is a POSIX system, and the program
658 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
659 -- instead, whose default action is to terminate the program).
661 hPutBuf :: Handle -- handle to write to
662 -> Ptr a -- address of buffer
663 -> Int -- number of bytes of data in buffer
665 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
668 :: Handle -- handle to write to
669 -> Ptr a -- address of buffer
670 -> Int -- number of bytes of data in buffer
671 -> IO Int -- returns: number of bytes written
672 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
674 hPutBuf':: Handle -- handle to write to
675 -> Ptr a -- address of buffer
676 -> Int -- number of bytes of data in buffer
677 -> Bool -- allow blocking?
679 hPutBuf' handle ptr count can_block
680 | count == 0 = return 0
681 | count < 0 = illegalBufferSize handle "hPutBuf" count
683 wantWritableHandle "hPutBuf" handle $
684 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
685 bufWrite fd ref is_stream ptr count can_block
687 bufWrite fd ref is_stream ptr count can_block =
688 seq count $ seq fd $ do -- strictness hack
689 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
692 -- enough room in handle buffer?
693 if (size - w > count)
694 -- There's enough room in the buffer:
695 -- just copy the data in and update bufWPtr.
696 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
697 writeIORef ref old_buf{ bufWPtr = w + count }
700 -- else, we have to flush
701 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
702 -- TODO: we should do a non-blocking flush here
703 writeIORef ref flushed_buf
704 -- if we can fit in the buffer, then just loop
706 then bufWrite fd ref is_stream ptr count can_block
708 then do writeChunk fd is_stream (castPtr ptr) count
710 else writeChunkNonBlocking fd is_stream ptr count
712 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
713 writeChunk fd is_stream ptr bytes = loop 0 bytes
715 loop :: Int -> Int -> IO ()
716 loop _ bytes | bytes <= 0 = return ()
718 r <- fromIntegral `liftM`
719 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
720 off (fromIntegral bytes)
721 -- write can't return 0
722 loop (off + r) (bytes - r)
724 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
725 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
727 loop :: Int -> Int -> IO Int
728 loop off bytes | bytes <= 0 = return off
730 #ifndef mingw32_TARGET_OS
731 ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
732 let r = fromIntegral ssize :: Int
734 then do errno <- getErrno
735 if (errno == eAGAIN || errno == eWOULDBLOCK)
737 else throwErrno "writeChunk"
738 else loop (off + r) (bytes - r)
740 (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
743 let r = fromIntegral ssize :: Int
745 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
746 else loop (off + r) (bytes - r)
749 -- ---------------------------------------------------------------------------
752 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
753 -- into the buffer @buf@ until either EOF is reached or
754 -- @count@ 8-bit bytes have been read.
755 -- It returns the number of bytes actually read. This may be zero if
756 -- EOF was reached before any data was read (or if @count@ is zero).
758 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
759 -- smaller than @count@.
761 -- If the handle is a pipe or socket, and the writing end
762 -- is closed, 'hGetBuf' will behave as if EOF was reached.
764 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
766 | count == 0 = return 0
767 | count < 0 = illegalBufferSize h "hGetBuf" count
769 wantReadableHandle "hGetBuf" h $
770 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
771 bufRead fd ref is_stream ptr 0 count
773 -- small reads go through the buffer, large reads are satisfied by
774 -- taking data first from the buffer and then direct from the file
776 bufRead fd ref is_stream ptr so_far count =
777 seq fd $ seq so_far $ seq count $ do -- strictness hack
778 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
780 then if count > sz -- small read?
781 then do rest <- readChunk fd is_stream ptr count
782 return (so_far + rest)
783 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
785 Nothing -> return so_far -- got nothing, we're done
788 bufRead fd ref is_stream ptr so_far count
793 memcpy_ptr_baoff ptr raw r (fromIntegral count)
794 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
795 return (so_far + count)
799 memcpy_ptr_baoff ptr raw r (fromIntegral count)
800 writeIORef ref buf{ bufRPtr = r + count }
801 return (so_far + count)
804 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
805 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
806 let remaining = count - avail
807 so_far' = so_far + avail
808 ptr' = ptr `plusPtr` avail
811 then bufRead fd ref is_stream ptr' so_far' remaining
814 rest <- readChunk fd is_stream ptr' remaining
815 return (so_far' + rest)
817 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
818 readChunk fd is_stream ptr bytes = loop 0 bytes
820 loop :: Int -> Int -> IO Int
821 loop off bytes | bytes <= 0 = return off
823 r <- fromIntegral `liftM`
824 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
825 (castPtr ptr) off (fromIntegral bytes)
828 else loop (off + r) (bytes - r)
831 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
832 -- into the buffer @buf@ until either EOF is reached, or
833 -- @count@ 8-bit bytes have been read, or there is no more data available
834 -- to read immediately.
836 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
837 -- never block waiting for data to become available, instead it returns
838 -- only whatever data is available. To wait for data to arrive before
839 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
841 -- If the handle is a pipe or socket, and the writing end
842 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
844 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
845 hGetBufNonBlocking h ptr count
846 | count == 0 = return 0
847 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
849 wantReadableHandle "hGetBufNonBlocking" h $
850 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
851 bufReadNonBlocking fd ref is_stream ptr 0 count
853 bufReadNonBlocking fd ref is_stream ptr so_far count =
854 seq fd $ seq so_far $ seq count $ do -- strictness hack
855 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
857 then if count > sz -- large read?
858 then do rest <- readChunkNonBlocking fd is_stream ptr count
859 return (so_far + rest)
860 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
861 case buf' of { Buffer{ bufWPtr=w } ->
864 else do writeIORef ref buf'
865 bufReadNonBlocking fd ref is_stream ptr
867 -- NOTE: new count is 'min count w'
868 -- so we will just copy the contents of the
869 -- buffer in the recursive call, and not
876 memcpy_ptr_baoff ptr raw r (fromIntegral count)
877 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
878 return (so_far + count)
882 memcpy_ptr_baoff ptr raw r (fromIntegral count)
883 writeIORef ref buf{ bufRPtr = r + count }
884 return (so_far + count)
887 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
888 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
889 let remaining = count - avail
890 so_far' = so_far + avail
891 ptr' = ptr `plusPtr` avail
893 -- we haven't attempted to read anything yet if we get to here.
895 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
898 rest <- readChunkNonBlocking fd is_stream ptr' remaining
899 return (so_far' + rest)
902 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
903 readChunkNonBlocking fd is_stream ptr bytes = do
904 #ifndef mingw32_TARGET_OS
905 ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
906 let r = fromIntegral ssize :: Int
908 then do errno <- getErrno
909 if (errno == eAGAIN || errno == eWOULDBLOCK)
911 else throwErrno "readChunk"
914 (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
915 (fromIntegral bytes) ptr
916 let r = fromIntegral ssize :: Int
918 then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
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 [])