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 -----------------------------------------------------------------------------
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,
33 import System.IO.Error
36 import System.Posix.Internals
41 import GHC.Handle -- much of the real stuff is in here
46 import GHC.Exception ( ioError, catch )
48 #ifdef mingw32_HOST_OS
52 -- ---------------------------------------------------------------------------
53 -- Simple input operations
55 -- If hWaitForInput finds anything in the Handle's buffer, it
56 -- immediately returns. If not, it tries to read from the underlying
57 -- OS handle. Notice that for buffered Handles connected to terminals
58 -- this means waiting until a complete line is available.
60 -- | Computation 'hWaitForInput' @hdl t@
61 -- waits until input is available on handle @hdl@.
62 -- It returns 'True' as soon as input is available on @hdl@,
63 -- or 'False' if no input is available within @t@ milliseconds.
65 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
66 -- NOTE: in the current implementation, this is the only case that works
67 -- correctly (if @t@ is non-zero, then all other concurrent threads are
68 -- blocked until data is available).
70 -- This operation may fail with:
72 -- * 'isEOFError' if the end of file has been reached.
74 hWaitForInput :: Handle -> Int -> IO Bool
75 hWaitForInput h msecs = do
76 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
77 let ref = haBuffer handle_
80 if not (bufferEmpty buf)
85 then do buf' <- fillReadBuffer (haFD handle_) True
86 (haIsStream handle_) buf
89 else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
90 inputReady (fromIntegral (haFD handle_))
91 (fromIntegral msecs) (haIsStream handle_)
94 foreign import ccall safe "inputReady"
95 inputReady :: CInt -> CInt -> Bool -> IO CInt
97 -- ---------------------------------------------------------------------------
100 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
101 -- channel managed by @hdl@, blocking until a character is available.
103 -- This operation may fail with:
105 -- * 'isEOFError' if the end of file has been reached.
107 hGetChar :: Handle -> IO Char
109 wantReadableHandle "hGetChar" handle $ \handle_ -> do
111 let fd = haFD handle_
112 ref = haBuffer handle_
115 if not (bufferEmpty buf)
116 then hGetcBuffered fd ref buf
120 case haBufferMode handle_ of
122 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
123 hGetcBuffered fd ref new_buf
124 BlockBuffering _ -> do
125 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
127 -- don't wait for a completely full buffer.
128 hGetcBuffered fd ref new_buf
130 -- make use of the minimal buffer we already have
132 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
135 else do (c,_) <- readCharFromBuffer raw 0
138 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
139 = do (c,r) <- readCharFromBuffer b r
140 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
141 | otherwise = buf{ bufRPtr=r }
142 writeIORef ref new_buf
145 -- ---------------------------------------------------------------------------
148 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
151 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
152 -- channel managed by @hdl@.
154 -- This operation may fail with:
156 -- * 'isEOFError' if the end of file is encountered when reading
157 -- the /first/ character of the line.
159 -- If 'hGetLine' encounters end-of-file at any other point while reading
160 -- in a line, it is treated as a line terminator and the (partial)
163 hGetLine :: Handle -> IO String
165 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
166 case haBufferMode handle_ of
167 NoBuffering -> return Nothing
169 l <- hGetLineBuffered handle_
171 BlockBuffering _ -> do
172 l <- hGetLineBuffered handle_
175 Nothing -> hGetLineUnBuffered h
179 hGetLineBuffered handle_ = do
180 let ref = haBuffer handle_
182 hGetLineBufferedLoop handle_ ref buf []
185 hGetLineBufferedLoop handle_ ref
186 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
188 -- find the end-of-line character, if there is one
190 | r == w = return (False, w)
192 (c,r') <- readCharFromBuffer raw r
194 then return (True, r) -- NB. not r': don't include the '\n'
197 (eol, off) <- loop raw r
200 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
203 xs <- unpack raw r off
205 -- if eol == True, then off is the offset of the '\n'
206 -- otherwise off == w and the buffer is now empty.
208 then do if (w == off + 1)
209 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
210 else writeIORef ref buf{ bufRPtr = off + 1 }
211 return (concat (reverse (xs:xss)))
213 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
214 buf{ bufWPtr=0, bufRPtr=0 }
216 -- Nothing indicates we caught an EOF, and we may have a
217 -- partial line to return.
219 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
220 let str = concat (reverse (xs:xss))
225 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
228 maybeFillReadBuffer fd is_line is_stream buf
230 (do buf <- fillReadBuffer fd is_line is_stream buf
233 (\e -> do if isEOFError e
238 unpack :: RawBuffer -> Int -> Int -> IO [Char]
239 unpack buf r 0 = return ""
240 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
243 | i <# r = (# s, acc #)
245 case readCharArray# buf i s of
246 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
249 hGetLineUnBuffered :: Handle -> IO String
250 hGetLineUnBuffered h = do
263 if isEOFError err then
273 -- -----------------------------------------------------------------------------
276 -- hGetContents on a DuplexHandle only affects the read side: you can
277 -- carry on writing to it afterwards.
279 -- | Computation 'hGetContents' @hdl@ returns the list of characters
280 -- corresponding to the unread portion of the channel or file managed
281 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
282 -- In this state, @hdl@ is effectively closed,
283 -- but items are read from @hdl@ on demand and accumulated in a special
284 -- list returned by 'hGetContents' @hdl@.
286 -- Any operation that fails because a handle is closed,
287 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
288 -- A semi-closed handle becomes closed:
290 -- * if 'hClose' is applied to it;
292 -- * if an I\/O error occurs when reading an item from the handle;
294 -- * or once the entire contents of the handle has been read.
296 -- Once a semi-closed handle becomes closed, the contents of the
297 -- associated list becomes fixed. The contents of this final list is
298 -- only partially specified: it will contain at least all the items of
299 -- the stream that were evaluated prior to the handle becoming closed.
301 -- Any I\/O errors encountered while a handle is semi-closed are simply
304 -- This operation may fail with:
306 -- * 'isEOFError' if the end of file has been reached.
308 hGetContents :: Handle -> IO String
309 hGetContents handle =
310 withHandle "hGetContents" handle $ \handle_ ->
311 case haType handle_ of
312 ClosedHandle -> ioe_closedHandle
313 SemiClosedHandle -> ioe_closedHandle
314 AppendHandle -> ioe_notReadable
315 WriteHandle -> ioe_notReadable
316 _ -> do xs <- lazyRead handle
317 return (handle_{ haType=SemiClosedHandle}, xs )
319 -- Note that someone may close the semi-closed handle (or change its
320 -- buffering), so each time these lazy read functions are pulled on,
321 -- they have to check whether the handle has indeed been closed.
323 lazyRead :: Handle -> IO String
326 withHandle "lazyRead" handle $ \ handle_ -> do
327 case haType handle_ of
328 ClosedHandle -> return (handle_, "")
329 SemiClosedHandle -> lazyRead' handle handle_
331 (IOError (Just handle) IllegalOperation "lazyRead"
332 "illegal handle type" Nothing)
334 lazyRead' h handle_ = do
335 let ref = haBuffer handle_
338 -- even a NoBuffering handle can have a char in the buffer...
341 if not (bufferEmpty buf)
342 then lazyReadHaveBuffer h handle_ fd ref buf
345 case haBufferMode handle_ of
347 -- make use of the minimal buffer we already have
349 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
351 then do handle_ <- hClose_help handle_
353 else do (c,_) <- readCharFromBuffer raw 0
355 return (handle_, c : rest)
357 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
358 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
360 -- we never want to block during the read, so we call fillReadBuffer with
361 -- is_line==True, which tells it to "just read what there is".
362 lazyReadBuffered h handle_ fd ref buf = do
364 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
365 lazyReadHaveBuffer h handle_ fd ref buf
367 -- all I/O errors are discarded. Additionally, we close the handle.
368 (\e -> do handle_ <- hClose_help handle_
372 lazyReadHaveBuffer h handle_ fd ref buf = do
374 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
375 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
379 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
380 unpackAcc buf r 0 acc = return acc
381 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
384 | i <# r = (# s, acc #)
386 case readCharArray# buf i s of
387 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
389 -- ---------------------------------------------------------------------------
392 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
393 -- file or channel managed by @hdl@. Characters may be buffered if
394 -- buffering is enabled for @hdl@.
396 -- This operation may fail with:
398 -- * 'isFullError' if the device is full; or
400 -- * 'isPermissionError' if another system resource limit would be exceeded.
402 hPutChar :: Handle -> Char -> IO ()
404 c `seq` do -- must evaluate c before grabbing the handle lock
405 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
406 let fd = haFD handle_
407 case haBufferMode handle_ of
408 LineBuffering -> hPutcBuffered handle_ True c
409 BlockBuffering _ -> hPutcBuffered handle_ False c
411 with (castCharToCChar c) $ \buf -> do
412 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
415 hPutcBuffered handle_ is_line c = do
416 let ref = haBuffer handle_
419 w' <- writeCharIntoBuffer (bufBuf buf) w c
420 let new_buf = buf{ bufWPtr = w' }
421 if bufferFull new_buf || is_line && c == '\n'
423 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
424 writeIORef ref flushed_buf
426 writeIORef ref new_buf
429 hPutChars :: Handle -> [Char] -> IO ()
430 hPutChars handle [] = return ()
431 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
433 -- ---------------------------------------------------------------------------
436 -- We go to some trouble to avoid keeping the handle locked while we're
437 -- evaluating the string argument to hPutStr, in case doing so triggers another
438 -- I/O operation on the same handle which would lead to deadlock. The classic
441 -- putStr (trace "hello" "world")
443 -- so the basic scheme is this:
445 -- * copy the string into a fresh buffer,
446 -- * "commit" the buffer to the handle.
448 -- Committing may involve simply copying the contents of the new
449 -- buffer into the handle's buffer, flushing one or both buffers, or
450 -- maybe just swapping the buffers over (if the handle's buffer was
451 -- empty). See commitBuffer below.
453 -- | Computation 'hPutStr' @hdl s@ writes the string
454 -- @s@ to the file or channel managed by @hdl@.
456 -- This operation may fail with:
458 -- * 'isFullError' if the device is full; or
460 -- * 'isPermissionError' if another system resource limit would be exceeded.
462 hPutStr :: Handle -> String -> IO ()
463 hPutStr handle str = do
464 buffer_mode <- wantWritableHandle "hPutStr" handle
465 (\ handle_ -> do getSpareBuffer handle_)
467 (NoBuffering, _) -> do
468 hPutChars handle str -- v. slow, but we don't care
469 (LineBuffering, buf) -> do
470 writeLines handle buf str
471 (BlockBuffering _, buf) -> do
472 writeBlocks handle buf str
475 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
476 getSpareBuffer Handle__{haBuffer=ref,
481 NoBuffering -> return (mode, error "no buffer!")
483 bufs <- readIORef spare_ref
486 BufferListCons b rest -> do
487 writeIORef spare_ref rest
488 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
490 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
491 return (mode, new_buf)
494 writeLines :: Handle -> Buffer -> String -> IO ()
495 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
497 shoveString :: Int -> [Char] -> IO ()
498 -- check n == len first, to ensure that shoveString is strict in n.
499 shoveString n cs | n == len = do
500 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
501 writeLines hdl new_buf cs
502 shoveString n [] = do
503 commitBuffer hdl raw len n False{-no flush-} True{-release-}
505 shoveString n (c:cs) = do
506 n' <- writeCharIntoBuffer raw n c
509 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
510 writeLines hdl new_buf cs
516 writeBlocks :: Handle -> Buffer -> String -> IO ()
517 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
519 shoveString :: Int -> [Char] -> IO ()
520 -- check n == len first, to ensure that shoveString is strict in n.
521 shoveString n cs | n == len = do
522 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
523 writeBlocks hdl new_buf cs
524 shoveString n [] = do
525 commitBuffer hdl raw len n False{-no flush-} True{-release-}
527 shoveString n (c:cs) = do
528 n' <- writeCharIntoBuffer raw n c
533 -- -----------------------------------------------------------------------------
534 -- commitBuffer handle buf sz count flush release
536 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
537 -- 'count' bytes of data) to handle (handle must be block or line buffered).
541 -- for block/line buffering,
542 -- 1. If there isn't room in the handle buffer, flush the handle
545 -- 2. If the handle buffer is empty,
547 -- then write buf directly to the device.
548 -- else swap the handle buffer with buf.
550 -- 3. If the handle buffer is non-empty, copy buf into the
551 -- handle buffer. Then, if flush != 0, flush
555 :: Handle -- handle to commit to
556 -> RawBuffer -> Int -- address and size (in bytes) of buffer
557 -> Int -- number of bytes of data in buffer
558 -> Bool -- True <=> flush the handle afterward
559 -> Bool -- release the buffer?
562 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
563 wantWritableHandle "commitAndReleaseBuffer" hdl $
564 commitBuffer' raw sz count flush release
566 -- Explicitly lambda-lift this function to subvert GHC's full laziness
567 -- optimisations, which otherwise tends to float out subexpressions
568 -- past the \handle, which is really a pessimisation in this case because
569 -- that lambda is a one-shot lambda.
571 -- Don't forget to export the function, to stop it being inlined too
572 -- (this appears to be better than NOINLINE, because the strictness
573 -- analyser still gets to worker-wrapper it).
575 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
577 commitBuffer' raw sz@(I# _) count@(I# _) flush release
578 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
581 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
582 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
585 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
589 -- enough room in handle buffer?
590 if (not flush && (size - w > count))
591 -- The > is to be sure that we never exactly fill
592 -- up the buffer, which would require a flush. So
593 -- if copying the new data into the buffer would
594 -- make the buffer full, we just flush the existing
595 -- buffer and the new data immediately, rather than
596 -- copying before flushing.
598 -- not flushing, and there's enough room in the buffer:
599 -- just copy the data in and update bufWPtr.
600 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
601 writeIORef ref old_buf{ bufWPtr = w + count }
602 return (newEmptyBuffer raw WriteBuffer sz)
604 -- else, we have to flush
605 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
608 Buffer{ bufBuf=raw, bufState=WriteBuffer,
609 bufRPtr=0, bufWPtr=count, bufSize=sz }
611 -- if: (a) we don't have to flush, and
612 -- (b) size(new buffer) == size(old buffer), and
613 -- (c) new buffer is not full,
614 -- we can just just swap them over...
615 if (not flush && sz == size && count /= sz)
617 writeIORef ref this_buf
620 -- otherwise, we have to flush the new data too,
621 -- and start with a fresh buffer
623 flushWriteBuffer fd (haIsStream handle_) this_buf
624 writeIORef ref flushed_buf
625 -- if the sizes were different, then allocate
626 -- a new buffer of the correct size.
628 then return (newEmptyBuffer raw WriteBuffer sz)
629 else allocateBuffer size WriteBuffer
631 -- release the buffer if necessary
633 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
634 if release && buf_ret_sz == size
636 spare_bufs <- readIORef spare_buf_ref
637 writeIORef spare_buf_ref
638 (BufferListCons buf_ret_raw spare_bufs)
643 -- ---------------------------------------------------------------------------
644 -- Reading/writing sequences of bytes.
646 -- ---------------------------------------------------------------------------
649 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
650 -- buffer @buf@ to the handle @hdl@. It returns ().
652 -- This operation may fail with:
654 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
655 -- reading end is closed. (If this is a POSIX system, and the program
656 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
657 -- instead, whose default action is to terminate the program).
659 hPutBuf :: Handle -- handle to write to
660 -> Ptr a -- address of buffer
661 -> Int -- number of bytes of data in buffer
663 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
666 :: Handle -- handle to write to
667 -> Ptr a -- address of buffer
668 -> Int -- number of bytes of data in buffer
669 -> IO Int -- returns: number of bytes written
670 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
672 hPutBuf':: Handle -- handle to write to
673 -> Ptr a -- address of buffer
674 -> Int -- number of bytes of data in buffer
675 -> Bool -- allow blocking?
677 hPutBuf' handle ptr count can_block
678 | count == 0 = return 0
679 | count < 0 = illegalBufferSize handle "hPutBuf" count
681 wantWritableHandle "hPutBuf" handle $
682 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
683 bufWrite fd ref is_stream ptr count can_block
685 bufWrite fd ref is_stream ptr count can_block =
686 seq count $ seq fd $ do -- strictness hack
687 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
690 -- enough room in handle buffer?
691 if (size - w > count)
692 -- There's enough room in the buffer:
693 -- just copy the data in and update bufWPtr.
694 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
695 writeIORef ref old_buf{ bufWPtr = w + count }
698 -- else, we have to flush
699 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
700 -- TODO: we should do a non-blocking flush here
701 writeIORef ref flushed_buf
702 -- if we can fit in the buffer, then just loop
704 then bufWrite fd ref is_stream ptr count can_block
706 then do writeChunk fd is_stream (castPtr ptr) count
708 else writeChunkNonBlocking fd is_stream ptr count
710 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
711 writeChunk fd is_stream ptr bytes = loop 0 bytes
713 loop :: Int -> Int -> IO ()
714 loop _ bytes | bytes <= 0 = return ()
716 r <- fromIntegral `liftM`
717 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
718 off (fromIntegral bytes)
719 -- write can't return 0
720 loop (off + r) (bytes - r)
722 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
723 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
725 loop :: Int -> Int -> IO Int
726 loop off bytes | bytes <= 0 = return off
728 #ifndef mingw32_HOST_OS
729 ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
730 let r = fromIntegral ssize :: Int
732 then do errno <- getErrno
733 if (errno == eAGAIN || errno == eWOULDBLOCK)
735 else throwErrno "writeChunk"
736 else loop (off + r) (bytes - r)
738 (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
741 let r = fromIntegral ssize :: Int
743 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
744 else loop (off + r) (bytes - r)
747 -- ---------------------------------------------------------------------------
750 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
751 -- into the buffer @buf@ until either EOF is reached or
752 -- @count@ 8-bit bytes have been read.
753 -- It returns the number of bytes actually read. This may be zero if
754 -- EOF was reached before any data was read (or if @count@ is zero).
756 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
757 -- smaller than @count@.
759 -- If the handle is a pipe or socket, and the writing end
760 -- is closed, 'hGetBuf' will behave as if EOF was reached.
762 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
764 | count == 0 = return 0
765 | count < 0 = illegalBufferSize h "hGetBuf" count
767 wantReadableHandle "hGetBuf" h $
768 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
769 bufRead fd ref is_stream ptr 0 count
771 -- small reads go through the buffer, large reads are satisfied by
772 -- taking data first from the buffer and then direct from the file
774 bufRead fd ref is_stream ptr so_far count =
775 seq fd $ seq so_far $ seq count $ do -- strictness hack
776 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
778 then if count > sz -- small read?
779 then do rest <- readChunk fd is_stream ptr count
780 return (so_far + rest)
781 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
783 Nothing -> return so_far -- got nothing, we're done
786 bufRead fd ref is_stream ptr so_far count
791 memcpy_ptr_baoff ptr raw r (fromIntegral count)
792 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
793 return (so_far + count)
797 memcpy_ptr_baoff ptr raw r (fromIntegral count)
798 writeIORef ref buf{ bufRPtr = r + count }
799 return (so_far + count)
802 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
803 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
804 let remaining = count - avail
805 so_far' = so_far + avail
806 ptr' = ptr `plusPtr` avail
809 then bufRead fd ref is_stream ptr' so_far' remaining
812 rest <- readChunk fd is_stream ptr' remaining
813 return (so_far' + rest)
815 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
816 readChunk fd is_stream ptr bytes = loop 0 bytes
818 loop :: Int -> Int -> IO Int
819 loop off bytes | bytes <= 0 = return off
821 r <- fromIntegral `liftM`
822 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
823 (castPtr ptr) off (fromIntegral bytes)
826 else loop (off + r) (bytes - r)
829 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
830 -- into the buffer @buf@ until either EOF is reached, or
831 -- @count@ 8-bit bytes have been read, or there is no more data available
832 -- to read immediately.
834 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
835 -- never block waiting for data to become available, instead it returns
836 -- only whatever data is available. To wait for data to arrive before
837 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
839 -- If the handle is a pipe or socket, and the writing end
840 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
842 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
843 hGetBufNonBlocking h ptr count
844 | count == 0 = return 0
845 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
847 wantReadableHandle "hGetBufNonBlocking" h $
848 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
849 bufReadNonBlocking fd ref is_stream ptr 0 count
851 bufReadNonBlocking fd ref is_stream ptr so_far count =
852 seq fd $ seq so_far $ seq count $ do -- strictness hack
853 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
855 then if count > sz -- large read?
856 then do rest <- readChunkNonBlocking fd is_stream ptr count
857 return (so_far + rest)
858 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
859 case buf' of { Buffer{ bufWPtr=w } ->
862 else do writeIORef ref buf'
863 bufReadNonBlocking fd ref is_stream ptr
865 -- NOTE: new count is 'min count w'
866 -- so we will just copy the contents of the
867 -- buffer in the recursive call, and not
874 memcpy_ptr_baoff ptr raw r (fromIntegral count)
875 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
876 return (so_far + count)
880 memcpy_ptr_baoff ptr raw r (fromIntegral count)
881 writeIORef ref buf{ bufRPtr = r + count }
882 return (so_far + count)
885 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
886 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
887 let remaining = count - avail
888 so_far' = so_far + avail
889 ptr' = ptr `plusPtr` avail
891 -- we haven't attempted to read anything yet if we get to here.
893 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
896 rest <- readChunkNonBlocking fd is_stream ptr' remaining
897 return (so_far' + rest)
900 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
901 readChunkNonBlocking fd is_stream ptr bytes = do
902 #ifndef mingw32_HOST_OS
903 ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
904 let r = fromIntegral ssize :: Int
906 then do errno <- getErrno
907 if (errno == eAGAIN || errno == eWOULDBLOCK)
909 else throwErrno "readChunk"
912 (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
913 (fromIntegral bytes) ptr
914 let r = fromIntegral ssize :: Int
916 then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
920 slurpFile :: FilePath -> IO (Ptr (), Int)
922 handle <- openFile fname ReadMode
923 sz <- hFileSize handle
924 if sz > fromIntegral (maxBound::Int) then
925 ioError (userError "slurpFile: file too big")
927 let sz_i = fromIntegral sz
928 if sz_i == 0 then return (nullPtr, 0) else do
929 chunk <- mallocBytes sz_i
930 r <- hGetBuf handle chunk sz_i
934 -- ---------------------------------------------------------------------------
937 foreign import ccall unsafe "__hscore_memcpy_src_off"
938 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
939 foreign import ccall unsafe "__hscore_memcpy_src_off"
940 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
941 foreign import ccall unsafe "__hscore_memcpy_dst_off"
942 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
943 foreign import ccall unsafe "__hscore_memcpy_dst_off"
944 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
946 -----------------------------------------------------------------------------
949 illegalBufferSize :: Handle -> String -> Int -> IO a
950 illegalBufferSize handle fn (sz :: Int) =
951 ioException (IOError (Just handle)
953 ("illegal buffer size " ++ showsPrec 9 sz [])