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, hPutBuf, slurpFile,
33 import System.IO.Error
41 import GHC.Handle -- much of the real stuff is in here
46 import GHC.Exception ( ioError, catch, throw )
49 -- ---------------------------------------------------------------------------
50 -- Simple input operations
52 -- Computation "hReady hdl" indicates whether at least
53 -- one item is available for input from handle "hdl".
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 hWaitForInput :: Handle -> Int -> IO Bool
61 hWaitForInput h msecs = do
62 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
63 let ref = haBuffer handle_
66 if not (bufferEmpty buf)
70 r <- throwErrnoIfMinus1Retry "hWaitForInput"
71 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
74 foreign import ccall unsafe "inputReady"
75 inputReady :: CInt -> CInt -> Bool -> IO CInt
77 -- ---------------------------------------------------------------------------
80 -- hGetChar reads the next character from a handle,
81 -- blocking until a character is available.
83 hGetChar :: Handle -> IO Char
85 wantReadableHandle "hGetChar" handle $ \handle_ -> do
88 ref = haBuffer handle_
91 if not (bufferEmpty buf)
92 then hGetcBuffered fd ref buf
96 case haBufferMode handle_ of
98 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
99 hGetcBuffered fd ref new_buf
100 BlockBuffering _ -> do
101 new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
102 hGetcBuffered fd ref new_buf
104 -- make use of the minimal buffer we already have
106 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
107 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
111 else do (c,_) <- readCharFromBuffer raw 0
114 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
115 = do (c,r) <- readCharFromBuffer b r
116 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
117 | otherwise = buf{ bufRPtr=r }
118 writeIORef ref new_buf
121 -- ---------------------------------------------------------------------------
124 -- If EOF is reached before EOL is encountered, ignore the EOF and
125 -- return the partial line. Next attempt at calling hGetLine on the
126 -- handle will yield an EOF IO exception though.
128 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
130 hGetLine :: Handle -> IO String
132 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
133 case haBufferMode handle_ of
134 NoBuffering -> return Nothing
136 l <- hGetLineBuffered handle_
138 BlockBuffering _ -> do
139 l <- hGetLineBuffered handle_
142 Nothing -> hGetLineUnBuffered h
146 hGetLineBuffered handle_ = do
147 let ref = haBuffer handle_
149 hGetLineBufferedLoop handle_ ref buf []
152 hGetLineBufferedLoop handle_ ref
153 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
155 -- find the end-of-line character, if there is one
157 | r == w = return (False, w)
159 (c,r') <- readCharFromBuffer raw r
161 then return (True, r) -- NB. not r': don't include the '\n'
164 (eol, off) <- loop raw r
167 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
170 xs <- unpack raw r off
172 then do if w == off + 1
173 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
174 else writeIORef ref buf{ bufRPtr = off + 1 }
175 return (concat (reverse (xs:xss)))
177 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
178 buf{ bufWPtr=0, bufRPtr=0 }
180 -- Nothing indicates we caught an EOF, and we may have a
181 -- partial line to return.
182 Nothing -> let str = concat (reverse (xs:xss)) in
187 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
190 maybeFillReadBuffer fd is_line is_stream buf
192 (do buf <- fillReadBuffer fd is_line is_stream buf
195 (\e -> do if isEOFError e
200 unpack :: RawBuffer -> Int -> Int -> IO [Char]
201 unpack buf r 0 = return ""
202 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
205 | i <# r = (# s, acc #)
207 case readCharArray# buf i s of
208 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
211 hGetLineUnBuffered :: Handle -> IO String
212 hGetLineUnBuffered h = do
225 if isEOFError err then
235 -- -----------------------------------------------------------------------------
238 -- hGetContents returns the list of characters corresponding to the
239 -- unread portion of the channel or file managed by the handle, which
240 -- is made semi-closed.
242 -- hGetContents on a DuplexHandle only affects the read side: you can
243 -- carry on writing to it afterwards.
245 hGetContents :: Handle -> IO String
246 hGetContents handle =
247 withHandle "hGetContents" handle $ \handle_ ->
248 case haType handle_ of
249 ClosedHandle -> ioe_closedHandle
250 SemiClosedHandle -> ioe_closedHandle
251 AppendHandle -> ioe_notReadable
252 WriteHandle -> ioe_notReadable
253 _ -> do xs <- lazyRead handle
254 return (handle_{ haType=SemiClosedHandle}, xs )
256 -- Note that someone may close the semi-closed handle (or change its
257 -- buffering), so each time these lazy read functions are pulled on,
258 -- they have to check whether the handle has indeed been closed.
260 lazyRead :: Handle -> IO String
263 withHandle "lazyRead" handle $ \ handle_ -> do
264 case haType handle_ of
265 ClosedHandle -> return (handle_, "")
266 SemiClosedHandle -> lazyRead' handle handle_
268 (IOError (Just handle) IllegalOperation "lazyRead"
269 "illegal handle type" Nothing)
271 lazyRead' h handle_ = do
272 let ref = haBuffer handle_
275 -- even a NoBuffering handle can have a char in the buffer...
278 if not (bufferEmpty buf)
279 then lazyReadHaveBuffer h handle_ fd ref buf
282 case haBufferMode handle_ of
284 -- make use of the minimal buffer we already have
286 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
287 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
290 then do handle_ <- hClose_help handle_
292 else do (c,_) <- readCharFromBuffer raw 0
294 return (handle_, c : rest)
296 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
297 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
299 -- we never want to block during the read, so we call fillReadBuffer with
300 -- is_line==True, which tells it to "just read what there is".
301 lazyReadBuffered h handle_ fd ref buf = do
303 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
304 lazyReadHaveBuffer h handle_ fd ref buf
306 -- all I/O errors are discarded. Additionally, we close the handle.
307 (\e -> do handle_ <- hClose_help handle_
311 lazyReadHaveBuffer h handle_ fd ref buf = do
313 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
314 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
318 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
319 unpackAcc buf r 0 acc = return acc
320 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
323 | i <# r = (# s, acc #)
325 case readCharArray# buf i s of
326 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
328 -- ---------------------------------------------------------------------------
331 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
332 -- managed by `hdl'. Characters may be buffered if buffering is
333 -- enabled for `hdl'.
335 hPutChar :: Handle -> Char -> IO ()
337 c `seq` do -- must evaluate c before grabbing the handle lock
338 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
339 let fd = haFD handle_
340 case haBufferMode handle_ of
341 LineBuffering -> hPutcBuffered handle_ True c
342 BlockBuffering _ -> hPutcBuffered handle_ False c
344 withObject (castCharToCChar c) $ \buf ->
345 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
346 (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
350 hPutcBuffered handle_ is_line c = do
351 let ref = haBuffer handle_
354 w' <- writeCharIntoBuffer (bufBuf buf) w c
355 let new_buf = buf{ bufWPtr = w' }
356 if bufferFull new_buf || is_line && c == '\n'
358 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
359 writeIORef ref flushed_buf
361 writeIORef ref new_buf
364 hPutChars :: Handle -> [Char] -> IO ()
365 hPutChars handle [] = return ()
366 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
368 -- ---------------------------------------------------------------------------
371 -- `hPutStr hdl s' writes the string `s' to the file or
372 -- hannel managed by `hdl', buffering the output if needs be.
374 -- We go to some trouble to avoid keeping the handle locked while we're
375 -- evaluating the string argument to hPutStr, in case doing so triggers another
376 -- I/O operation on the same handle which would lead to deadlock. The classic
379 -- putStr (trace "hello" "world")
381 -- so the basic scheme is this:
383 -- * copy the string into a fresh buffer,
384 -- * "commit" the buffer to the handle.
386 -- Committing may involve simply copying the contents of the new
387 -- buffer into the handle's buffer, flushing one or both buffers, or
388 -- maybe just swapping the buffers over (if the handle's buffer was
389 -- empty). See commitBuffer below.
391 hPutStr :: Handle -> String -> IO ()
392 hPutStr handle str = do
393 buffer_mode <- wantWritableHandle "hPutStr" handle
394 (\ handle_ -> do getSpareBuffer handle_)
396 (NoBuffering, _) -> do
397 hPutChars handle str -- v. slow, but we don't care
398 (LineBuffering, buf) -> do
399 writeLines handle buf str
400 (BlockBuffering _, buf) -> do
401 writeBlocks handle buf str
404 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
405 getSpareBuffer Handle__{haBuffer=ref,
410 NoBuffering -> return (mode, error "no buffer!")
412 bufs <- readIORef spare_ref
415 BufferListCons b rest -> do
416 writeIORef spare_ref rest
417 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
419 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
420 return (mode, new_buf)
423 writeLines :: Handle -> Buffer -> String -> IO ()
424 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
426 shoveString :: Int -> [Char] -> IO ()
427 -- check n == len first, to ensure that shoveString is strict in n.
428 shoveString n cs | n == len = do
429 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
430 writeLines hdl new_buf cs
431 shoveString n [] = do
432 commitBuffer hdl raw len n False{-no flush-} True{-release-}
434 shoveString n (c:cs) = do
435 n' <- writeCharIntoBuffer raw n c
438 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
439 writeLines hdl new_buf cs
445 writeBlocks :: Handle -> Buffer -> String -> IO ()
446 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
448 shoveString :: Int -> [Char] -> IO ()
449 -- check n == len first, to ensure that shoveString is strict in n.
450 shoveString n cs | n == len = do
451 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
452 writeBlocks hdl new_buf cs
453 shoveString n [] = do
454 commitBuffer hdl raw len n False{-no flush-} True{-release-}
456 shoveString n (c:cs) = do
457 n' <- writeCharIntoBuffer raw n c
462 -- -----------------------------------------------------------------------------
463 -- commitBuffer handle buf sz count flush release
465 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
466 -- 'count' bytes of data) to handle (handle must be block or line buffered).
470 -- for block/line buffering,
471 -- 1. If there isn't room in the handle buffer, flush the handle
474 -- 2. If the handle buffer is empty,
476 -- then write buf directly to the device.
477 -- else swap the handle buffer with buf.
479 -- 3. If the handle buffer is non-empty, copy buf into the
480 -- handle buffer. Then, if flush != 0, flush
484 :: Handle -- handle to commit to
485 -> RawBuffer -> Int -- address and size (in bytes) of buffer
486 -> Int -- number of bytes of data in buffer
487 -> Bool -- True <=> flush the handle afterward
488 -> Bool -- release the buffer?
491 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
492 wantWritableHandle "commitAndReleaseBuffer" hdl $
493 commitBuffer' hdl raw sz count flush release
495 -- Explicitly lambda-lift this function to subvert GHC's full laziness
496 -- optimisations, which otherwise tends to float out subexpressions
497 -- past the \handle, which is really a pessimisation in this case because
498 -- that lambda is a one-shot lambda.
500 -- Don't forget to export the function, to stop it being inlined too
501 -- (this appears to be better than NOINLINE, because the strictness
502 -- analyser still gets to worker-wrapper it).
504 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
506 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
507 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
510 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
511 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
514 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
518 -- enough room in handle buffer?
519 if (not flush && (size - w > count))
520 -- The > is to be sure that we never exactly fill
521 -- up the buffer, which would require a flush. So
522 -- if copying the new data into the buffer would
523 -- make the buffer full, we just flush the existing
524 -- buffer and the new data immediately, rather than
525 -- copying before flushing.
527 -- not flushing, and there's enough room in the buffer:
528 -- just copy the data in and update bufWPtr.
529 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
530 writeIORef ref old_buf{ bufWPtr = w + count }
531 return (newEmptyBuffer raw WriteBuffer sz)
533 -- else, we have to flush
534 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
537 Buffer{ bufBuf=raw, bufState=WriteBuffer,
538 bufRPtr=0, bufWPtr=count, bufSize=sz }
540 -- if: (a) we don't have to flush, and
541 -- (b) size(new buffer) == size(old buffer), and
542 -- (c) new buffer is not full,
543 -- we can just just swap them over...
544 if (not flush && sz == size && count /= sz)
546 writeIORef ref this_buf
549 -- otherwise, we have to flush the new data too,
550 -- and start with a fresh buffer
552 flushWriteBuffer fd (haIsStream handle_) this_buf
553 writeIORef ref flushed_buf
554 -- if the sizes were different, then allocate
555 -- a new buffer of the correct size.
557 then return (newEmptyBuffer raw WriteBuffer sz)
558 else allocateBuffer size WriteBuffer
560 -- release the buffer if necessary
562 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
563 if release && buf_ret_sz == size
565 spare_bufs <- readIORef spare_buf_ref
566 writeIORef spare_buf_ref
567 (BufferListCons buf_ret_raw spare_bufs)
572 -- ---------------------------------------------------------------------------
573 -- Reading/writing sequences of bytes.
576 Semantics of hGetBuf:
578 - hGetBuf reads data into the buffer until either
581 (b) the buffer is full
583 It returns the amount of data actually read. This may
584 be zero in case (a). hGetBuf never raises
585 an EOF exception, it always returns zero instead.
587 If the handle is a pipe or socket, and the writing end
588 is closed, hGetBuf will behave as for condition (a).
590 Semantics of hPutBuf:
592 - hPutBuf writes data from the buffer to the handle
593 until the buffer is empty. It returns ().
595 If the handle is a pipe or socket, and the reading end is
596 closed, hPutBuf will raise a ResourceVanished exception.
597 (If this is a POSIX system, and the program has not
598 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
599 instead, whose default action is to terminate the program).
602 -- ---------------------------------------------------------------------------
605 hPutBuf :: Handle -- handle to write to
606 -> Ptr a -- address of buffer
607 -> Int -- number of bytes of data in buffer
609 hPutBuf handle ptr count
610 | count <= 0 = illegalBufferSize handle "hPutBuf" count
612 wantWritableHandle "hPutBuf" handle $
613 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
615 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
618 -- enough room in handle buffer?
619 if (size - w > count)
620 -- There's enough room in the buffer:
621 -- just copy the data in and update bufWPtr.
622 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
623 writeIORef ref old_buf{ bufWPtr = w + count }
626 -- else, we have to flush
627 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
628 writeIORef ref flushed_buf
629 -- ToDo: should just memcpy instead of writing if possible
630 writeChunk fd ptr count
632 writeChunk :: FD -> Ptr a -> Int -> IO ()
633 writeChunk fd ptr bytes = loop 0 bytes
635 loop :: Int -> Int -> IO ()
636 loop _ bytes | bytes <= 0 = return ()
638 r <- fromIntegral `liftM`
639 throwErrnoIfMinus1RetryMayBlock "writeChunk"
640 (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
642 -- write can't return 0
643 loop (off + r) (bytes - r)
645 -- ---------------------------------------------------------------------------
648 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
649 hGetBuf handle ptr count
650 | count <= 0 = illegalBufferSize handle "hGetBuf" count
652 wantReadableHandle "hGetBuf" handle $
653 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
654 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
656 then readChunk fd ptr count
659 copied <- if (count >= avail)
661 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
662 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
665 memcpy_ptr_baoff ptr raw r (fromIntegral count)
666 writeIORef ref buf{ bufRPtr = r + count }
669 let remaining = count - copied
671 then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
672 return (rest + copied)
675 readChunk :: FD -> Ptr a -> Int -> IO Int
676 readChunk fd ptr bytes = loop 0 bytes
678 loop :: Int -> Int -> IO Int
679 loop off bytes | bytes <= 0 = return off
681 r <- fromIntegral `liftM`
682 throwErrnoIfMinus1RetryMayBlock "readChunk"
683 (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
687 else loop (off + r) (bytes - r)
689 slurpFile :: FilePath -> IO (Ptr (), Int)
691 handle <- openFile fname ReadMode
692 sz <- hFileSize handle
693 if sz > fromIntegral (maxBound::Int) then
694 ioError (userError "slurpFile: file too big")
696 let sz_i = fromIntegral sz
697 chunk <- mallocBytes sz_i
698 r <- hGetBuf handle chunk sz_i
702 -- ---------------------------------------------------------------------------
705 foreign import ccall unsafe "__hscore_memcpy_src_off"
706 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
707 foreign import ccall unsafe "__hscore_memcpy_src_off"
708 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
709 foreign import ccall unsafe "__hscore_memcpy_dst_off"
710 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
711 foreign import ccall unsafe "__hscore_memcpy_dst_off"
712 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
714 -----------------------------------------------------------------------------
717 illegalBufferSize :: Handle -> String -> Int -> IO a
718 illegalBufferSize handle fn (sz :: Int) =
719 ioException (IOError (Just handle)
721 ("illegal buffer size " ++ showsPrec 9 sz [])