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,
24 {- NOTE: As far as I can tell, not defined.
25 createPipe, createPipeEx,
38 import System.IO.Error
41 import System.Posix.Internals
46 import GHC.Handle -- much of the real stuff is in here
51 import GHC.Exception ( ioError, catch )
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 -- This operation may fail with:
69 -- * 'isEOFError' if the end of file has been reached.
71 hWaitForInput :: Handle -> Int -> IO Bool
72 hWaitForInput h msecs = do
73 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
74 let ref = haBuffer handle_
77 if not (bufferEmpty buf)
81 r <- throwErrnoIfMinus1Retry "hWaitForInput"
82 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
85 foreign import ccall unsafe "inputReady"
86 inputReady :: CInt -> CInt -> Bool -> IO CInt
88 -- ---------------------------------------------------------------------------
91 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
92 -- channel managed by @hdl@, blocking until a character is available.
94 -- This operation may fail with:
96 -- * 'isEOFError' if the end of file has been reached.
98 hGetChar :: Handle -> IO Char
100 wantReadableHandle "hGetChar" handle $ \handle_ -> do
102 let fd = haFD handle_
103 ref = haBuffer handle_
106 if not (bufferEmpty buf)
107 then hGetcBuffered fd ref buf
111 case haBufferMode handle_ of
113 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
114 hGetcBuffered fd ref new_buf
115 BlockBuffering _ -> do
116 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
118 -- don't wait for a completely full buffer.
119 hGetcBuffered fd ref new_buf
121 -- make use of the minimal buffer we already have
123 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
126 else do (c,_) <- readCharFromBuffer raw 0
129 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
130 = do (c,r) <- readCharFromBuffer b r
131 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
132 | otherwise = buf{ bufRPtr=r }
133 writeIORef ref new_buf
136 -- ---------------------------------------------------------------------------
139 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
142 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
143 -- channel managed by @hdl@.
145 -- This operation may fail with:
147 -- * 'isEOFError' if the end of file is encountered when reading
148 -- the /first/ character of the line.
150 -- If 'hGetLine' encounters end-of-file at any other point while reading
151 -- in a line, it is treated as a line terminator and the (partial)
154 hGetLine :: Handle -> IO String
156 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
157 case haBufferMode handle_ of
158 NoBuffering -> return Nothing
160 l <- hGetLineBuffered handle_
162 BlockBuffering _ -> do
163 l <- hGetLineBuffered handle_
166 Nothing -> hGetLineUnBuffered h
170 hGetLineBuffered handle_ = do
171 let ref = haBuffer handle_
173 hGetLineBufferedLoop handle_ ref buf []
176 hGetLineBufferedLoop handle_ ref
177 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
179 -- find the end-of-line character, if there is one
181 | r == w = return (False, w)
183 (c,r') <- readCharFromBuffer raw r
185 then return (True, r) -- NB. not r': don't include the '\n'
188 (eol, off) <- loop raw r
191 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
194 xs <- unpack raw r off
196 -- if eol == True, then off is the offset of the '\n'
197 -- otherwise off == w and the buffer is now empty.
199 then do if (w == off + 1)
200 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
201 else writeIORef ref buf{ bufRPtr = off + 1 }
202 return (concat (reverse (xs:xss)))
204 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
205 buf{ bufWPtr=0, bufRPtr=0 }
207 -- Nothing indicates we caught an EOF, and we may have a
208 -- partial line to return.
210 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
211 let str = concat (reverse (xs:xss))
216 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
219 maybeFillReadBuffer fd is_line is_stream buf
221 (do buf <- fillReadBuffer fd is_line is_stream buf
224 (\e -> do if isEOFError e
229 unpack :: RawBuffer -> Int -> Int -> IO [Char]
230 unpack buf r 0 = return ""
231 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
234 | i <# r = (# s, acc #)
236 case readCharArray# buf i s of
237 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
240 hGetLineUnBuffered :: Handle -> IO String
241 hGetLineUnBuffered h = do
254 if isEOFError err then
264 -- -----------------------------------------------------------------------------
267 -- hGetContents on a DuplexHandle only affects the read side: you can
268 -- carry on writing to it afterwards.
270 -- | Computation 'hGetContents' @hdl@ returns the list of characters
271 -- corresponding to the unread portion of the channel or file managed
272 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
273 -- In this state, @hdl@ is effectively closed,
274 -- but items are read from @hdl@ on demand and accumulated in a special
275 -- list returned by 'hGetContents' @hdl@.
277 -- Any operation that fails because a handle is closed,
278 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
279 -- A semi-closed handle becomes closed:
281 -- * if 'hClose' is applied to it;
283 -- * if an I\/O error occurs when reading an item from the handle;
285 -- * or once the entire contents of the handle has been read.
287 -- Once a semi-closed handle becomes closed, the contents of the
288 -- associated list becomes fixed. The contents of this final list is
289 -- only partially specified: it will contain at least all the items of
290 -- the stream that were evaluated prior to the handle becoming closed.
292 -- Any I\/O errors encountered while a handle is semi-closed are simply
295 -- This operation may fail with:
297 -- * 'isEOFError' if the end of file has been reached.
299 hGetContents :: Handle -> IO String
300 hGetContents handle =
301 withHandle "hGetContents" handle $ \handle_ ->
302 case haType handle_ of
303 ClosedHandle -> ioe_closedHandle
304 SemiClosedHandle -> ioe_closedHandle
305 AppendHandle -> ioe_notReadable
306 WriteHandle -> ioe_notReadable
307 _ -> do xs <- lazyRead handle
308 return (handle_{ haType=SemiClosedHandle}, xs )
310 -- Note that someone may close the semi-closed handle (or change its
311 -- buffering), so each time these lazy read functions are pulled on,
312 -- they have to check whether the handle has indeed been closed.
314 lazyRead :: Handle -> IO String
317 withHandle "lazyRead" handle $ \ handle_ -> do
318 case haType handle_ of
319 ClosedHandle -> return (handle_, "")
320 SemiClosedHandle -> lazyRead' handle handle_
322 (IOError (Just handle) IllegalOperation "lazyRead"
323 "illegal handle type" Nothing)
325 lazyRead' h handle_ = do
326 let ref = haBuffer handle_
329 -- even a NoBuffering handle can have a char in the buffer...
332 if not (bufferEmpty buf)
333 then lazyReadHaveBuffer h handle_ fd ref buf
336 case haBufferMode handle_ of
338 -- make use of the minimal buffer we already have
340 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
342 then do handle_ <- hClose_help handle_
344 else do (c,_) <- readCharFromBuffer raw 0
346 return (handle_, c : rest)
348 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
349 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
351 -- we never want to block during the read, so we call fillReadBuffer with
352 -- is_line==True, which tells it to "just read what there is".
353 lazyReadBuffered h handle_ fd ref buf = do
355 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
356 lazyReadHaveBuffer h handle_ fd ref buf
358 -- all I/O errors are discarded. Additionally, we close the handle.
359 (\e -> do handle_ <- hClose_help handle_
363 lazyReadHaveBuffer h handle_ fd ref buf = do
365 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
366 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
370 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
371 unpackAcc buf r 0 acc = return acc
372 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
375 | i <# r = (# s, acc #)
377 case readCharArray# buf i s of
378 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
380 -- ---------------------------------------------------------------------------
383 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
384 -- file or channel managed by @hdl@. Characters may be buffered if
385 -- buffering is enabled for @hdl@.
387 -- This operation may fail with:
389 -- * 'isFullError' if the device is full; or
391 -- * 'isPermissionError' if another system resource limit would be exceeded.
393 hPutChar :: Handle -> Char -> IO ()
395 c `seq` do -- must evaluate c before grabbing the handle lock
396 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
397 let fd = haFD handle_
398 case haBufferMode handle_ of
399 LineBuffering -> hPutcBuffered handle_ True c
400 BlockBuffering _ -> hPutcBuffered handle_ False c
402 withObject (castCharToCChar c) $ \buf -> do
403 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
406 hPutcBuffered handle_ is_line c = do
407 let ref = haBuffer handle_
410 w' <- writeCharIntoBuffer (bufBuf buf) w c
411 let new_buf = buf{ bufWPtr = w' }
412 if bufferFull new_buf || is_line && c == '\n'
414 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
415 writeIORef ref flushed_buf
417 writeIORef ref new_buf
420 hPutChars :: Handle -> [Char] -> IO ()
421 hPutChars handle [] = return ()
422 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
424 -- ---------------------------------------------------------------------------
427 -- We go to some trouble to avoid keeping the handle locked while we're
428 -- evaluating the string argument to hPutStr, in case doing so triggers another
429 -- I/O operation on the same handle which would lead to deadlock. The classic
432 -- putStr (trace "hello" "world")
434 -- so the basic scheme is this:
436 -- * copy the string into a fresh buffer,
437 -- * "commit" the buffer to the handle.
439 -- Committing may involve simply copying the contents of the new
440 -- buffer into the handle's buffer, flushing one or both buffers, or
441 -- maybe just swapping the buffers over (if the handle's buffer was
442 -- empty). See commitBuffer below.
444 -- | Computation 'hPutStr' @hdl s@ writes the string
445 -- @s@ to the file or channel managed by @hdl@.
447 -- This operation may fail with:
449 -- * 'isFullError' if the device is full; or
451 -- * 'isPermissionError' if another system resource limit would be exceeded.
453 hPutStr :: Handle -> String -> IO ()
454 hPutStr handle str = do
455 buffer_mode <- wantWritableHandle "hPutStr" handle
456 (\ handle_ -> do getSpareBuffer handle_)
458 (NoBuffering, _) -> do
459 hPutChars handle str -- v. slow, but we don't care
460 (LineBuffering, buf) -> do
461 writeLines handle buf str
462 (BlockBuffering _, buf) -> do
463 writeBlocks handle buf str
466 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
467 getSpareBuffer Handle__{haBuffer=ref,
472 NoBuffering -> return (mode, error "no buffer!")
474 bufs <- readIORef spare_ref
477 BufferListCons b rest -> do
478 writeIORef spare_ref rest
479 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
481 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
482 return (mode, new_buf)
485 writeLines :: Handle -> Buffer -> String -> IO ()
486 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
488 shoveString :: Int -> [Char] -> IO ()
489 -- check n == len first, to ensure that shoveString is strict in n.
490 shoveString n cs | n == len = do
491 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
492 writeLines hdl new_buf cs
493 shoveString n [] = do
494 commitBuffer hdl raw len n False{-no flush-} True{-release-}
496 shoveString n (c:cs) = do
497 n' <- writeCharIntoBuffer raw n c
500 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
501 writeLines hdl new_buf cs
507 writeBlocks :: Handle -> Buffer -> String -> IO ()
508 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
510 shoveString :: Int -> [Char] -> IO ()
511 -- check n == len first, to ensure that shoveString is strict in n.
512 shoveString n cs | n == len = do
513 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
514 writeBlocks hdl new_buf cs
515 shoveString n [] = do
516 commitBuffer hdl raw len n False{-no flush-} True{-release-}
518 shoveString n (c:cs) = do
519 n' <- writeCharIntoBuffer raw n c
524 -- -----------------------------------------------------------------------------
525 -- commitBuffer handle buf sz count flush release
527 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
528 -- 'count' bytes of data) to handle (handle must be block or line buffered).
532 -- for block/line buffering,
533 -- 1. If there isn't room in the handle buffer, flush the handle
536 -- 2. If the handle buffer is empty,
538 -- then write buf directly to the device.
539 -- else swap the handle buffer with buf.
541 -- 3. If the handle buffer is non-empty, copy buf into the
542 -- handle buffer. Then, if flush != 0, flush
546 :: Handle -- handle to commit to
547 -> RawBuffer -> Int -- address and size (in bytes) of buffer
548 -> Int -- number of bytes of data in buffer
549 -> Bool -- True <=> flush the handle afterward
550 -> Bool -- release the buffer?
553 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
554 wantWritableHandle "commitAndReleaseBuffer" hdl $
555 commitBuffer' hdl raw sz count flush release
557 -- Explicitly lambda-lift this function to subvert GHC's full laziness
558 -- optimisations, which otherwise tends to float out subexpressions
559 -- past the \handle, which is really a pessimisation in this case because
560 -- that lambda is a one-shot lambda.
562 -- Don't forget to export the function, to stop it being inlined too
563 -- (this appears to be better than NOINLINE, because the strictness
564 -- analyser still gets to worker-wrapper it).
566 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
568 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
569 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
572 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
573 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
576 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
580 -- enough room in handle buffer?
581 if (not flush && (size - w > count))
582 -- The > is to be sure that we never exactly fill
583 -- up the buffer, which would require a flush. So
584 -- if copying the new data into the buffer would
585 -- make the buffer full, we just flush the existing
586 -- buffer and the new data immediately, rather than
587 -- copying before flushing.
589 -- not flushing, and there's enough room in the buffer:
590 -- just copy the data in and update bufWPtr.
591 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
592 writeIORef ref old_buf{ bufWPtr = w + count }
593 return (newEmptyBuffer raw WriteBuffer sz)
595 -- else, we have to flush
596 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
599 Buffer{ bufBuf=raw, bufState=WriteBuffer,
600 bufRPtr=0, bufWPtr=count, bufSize=sz }
602 -- if: (a) we don't have to flush, and
603 -- (b) size(new buffer) == size(old buffer), and
604 -- (c) new buffer is not full,
605 -- we can just just swap them over...
606 if (not flush && sz == size && count /= sz)
608 writeIORef ref this_buf
611 -- otherwise, we have to flush the new data too,
612 -- and start with a fresh buffer
614 flushWriteBuffer fd (haIsStream handle_) this_buf
615 writeIORef ref flushed_buf
616 -- if the sizes were different, then allocate
617 -- a new buffer of the correct size.
619 then return (newEmptyBuffer raw WriteBuffer sz)
620 else allocateBuffer size WriteBuffer
622 -- release the buffer if necessary
624 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
625 if release && buf_ret_sz == size
627 spare_bufs <- readIORef spare_buf_ref
628 writeIORef spare_buf_ref
629 (BufferListCons buf_ret_raw spare_bufs)
634 -- ---------------------------------------------------------------------------
635 -- Reading/writing sequences of bytes.
637 -- ---------------------------------------------------------------------------
640 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
641 -- buffer @buf@ to the handle @hdl@. It returns ().
643 -- This operation may fail with:
645 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
646 -- reading end is closed. (If this is a POSIX system, and the program
647 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
648 -- instead, whose default action is to terminate the program).
650 hPutBuf :: Handle -- handle to write to
651 -> Ptr a -- address of buffer
652 -> Int -- number of bytes of data in buffer
654 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
657 :: Handle -- handle to write to
658 -> Ptr a -- address of buffer
659 -> Int -- number of bytes of data in buffer
660 -> IO Int -- returns: number of bytes written
661 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
663 hPutBuf':: Handle -- handle to write to
664 -> Ptr a -- address of buffer
665 -> Int -- number of bytes of data in buffer
666 -> Bool -- allow blocking?
668 hPutBuf' handle ptr count can_block
669 | count == 0 = return 0
670 | count < 0 = illegalBufferSize handle "hPutBuf" count
672 wantWritableHandle "hPutBuf" handle $
673 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
674 bufWrite fd ref is_stream ptr count can_block
676 bufWrite fd ref is_stream ptr count can_block =
677 seq count $ seq fd $ do -- strictness hack
678 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
681 -- enough room in handle buffer?
682 if (size - w > count)
683 -- There's enough room in the buffer:
684 -- just copy the data in and update bufWPtr.
685 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
686 writeIORef ref old_buf{ bufWPtr = w + count }
689 -- else, we have to flush
690 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
691 -- TODO: we should do a non-blocking flush here
692 writeIORef ref flushed_buf
693 -- if we can fit in the buffer, then just loop
695 then bufWrite fd ref is_stream ptr count can_block
697 then do writeChunk fd is_stream (castPtr ptr) count
699 else writeChunkNonBlocking fd is_stream ptr count
701 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
702 writeChunk fd is_stream ptr bytes = loop 0 bytes
704 loop :: Int -> Int -> IO ()
705 loop _ bytes | bytes <= 0 = return ()
707 r <- fromIntegral `liftM`
708 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
709 off (fromIntegral bytes)
710 -- write can't return 0
711 loop (off + r) (bytes - r)
713 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
714 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
716 loop :: Int -> Int -> IO Int
717 loop off bytes | bytes <= 0 = return off
719 #ifndef mingw32_TARGET_OS
720 ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
721 let r = fromIntegral ssize :: Int
723 then do errno <- getErrno
724 if (errno == eAGAIN || errno == eWOULDBLOCK)
726 else throwErrno "writeChunk"
727 else loop (off + r) (bytes - r)
729 (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
732 let r = fromIntegral ssize :: Int
734 then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
735 else loop (off + r) (bytes - r)
738 -- ---------------------------------------------------------------------------
741 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
742 -- into the buffer @buf@ until either EOF is reached or
743 -- @count@ 8-bit bytes have been read.
744 -- It returns the number of bytes actually read. This may be zero if
745 -- EOF was reached before any data was read (or if @count@ is zero).
747 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
748 -- smaller than @count@.
750 -- If the handle is a pipe or socket, and the writing end
751 -- is closed, 'hGetBuf' will behave as if EOF was reached.
753 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
754 hGetBuf h ptr count = hGetBuf' h ptr count True
756 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
757 hGetBufNonBlocking h ptr count = hGetBuf' h ptr count False
759 hGetBuf' :: Handle -> Ptr a -> Int -> Bool -> IO Int
760 hGetBuf' handle ptr count can_block
761 | count == 0 = return 0
762 | count < 0 = illegalBufferSize handle "hGetBuf" count
764 wantReadableHandle "hGetBuf" handle $
765 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
766 bufRead fd ref is_stream ptr 0 count can_block
768 bufRead fd ref is_stream ptr so_far count can_block =
769 seq fd $ seq so_far $ seq count $ do -- strictness hack
770 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
772 then if so_far > 0 then return so_far else
775 mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf
779 writeIORef ref new_buf
780 bufRead fd ref is_stream ptr so_far count can_block
782 then readChunk fd is_stream ptr count
783 else readChunkNonBlocking fd is_stream ptr count
788 memcpy_ptr_baoff ptr raw r (fromIntegral count)
789 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
790 return (so_far + count)
794 memcpy_ptr_baoff ptr raw r (fromIntegral count)
795 writeIORef ref buf{ bufRPtr = r + count }
796 return (so_far + count)
799 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
800 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
802 let remaining = count - avail
803 so_far' = so_far + avail
804 ptr' = ptr `plusPtr` avail
807 then bufRead fd ref is_stream ptr' so_far' remaining can_block
811 then readChunk fd is_stream ptr' remaining
812 else readChunkNonBlocking 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)
828 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
829 readChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
831 loop :: Int -> Int -> IO Int
832 loop off bytes | bytes <= 0 = return off
834 #ifndef mingw32_TARGET_OS
835 ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
836 let r = fromIntegral ssize :: Int
838 then do errno <- getErrno
839 if (errno == eAGAIN || errno == eWOULDBLOCK)
841 else throwErrno "readChunk"
844 else loop (off + r) (bytes - r)
846 (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
849 let r = fromIntegral ssize :: Int
851 then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
854 else loop (off + r) (bytes - r)
857 slurpFile :: FilePath -> IO (Ptr (), Int)
859 handle <- openFile fname ReadMode
860 sz <- hFileSize handle
861 if sz > fromIntegral (maxBound::Int) then
862 ioError (userError "slurpFile: file too big")
864 let sz_i = fromIntegral sz
865 if sz_i == 0 then return (nullPtr, 0) else do
866 chunk <- mallocBytes sz_i
867 r <- hGetBuf handle chunk sz_i
871 -- ---------------------------------------------------------------------------
874 foreign import ccall unsafe "__hscore_memcpy_src_off"
875 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
876 foreign import ccall unsafe "__hscore_memcpy_src_off"
877 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
878 foreign import ccall unsafe "__hscore_memcpy_dst_off"
879 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
880 foreign import ccall unsafe "__hscore_memcpy_dst_off"
881 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
883 -----------------------------------------------------------------------------
886 illegalBufferSize :: Handle -> String -> Int -> IO a
887 illegalBufferSize handle fn (sz :: Int) =
888 ioException (IOError (Just handle)
890 ("illegal buffer size " ++ showsPrec 9 sz [])