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 )
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 -- if eol == True, then off is the offset of the '\n'
173 -- otherwise off == w and the buffer is now empty.
175 then do if (w == off + 1)
176 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
177 else writeIORef ref buf{ bufRPtr = off + 1 }
178 return (concat (reverse (xs:xss)))
180 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
181 buf{ bufWPtr=0, bufRPtr=0 }
183 -- Nothing indicates we caught an EOF, and we may have a
184 -- partial line to return.
186 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
187 let str = concat (reverse (xs:xss))
192 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
195 maybeFillReadBuffer fd is_line is_stream buf
197 (do buf <- fillReadBuffer fd is_line is_stream buf
200 (\e -> do if isEOFError e
205 unpack :: RawBuffer -> Int -> Int -> IO [Char]
206 unpack buf r 0 = return ""
207 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
210 | i <# r = (# s, acc #)
212 case readCharArray# buf i s of
213 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
216 hGetLineUnBuffered :: Handle -> IO String
217 hGetLineUnBuffered h = do
230 if isEOFError err then
240 -- -----------------------------------------------------------------------------
243 -- hGetContents returns the list of characters corresponding to the
244 -- unread portion of the channel or file managed by the handle, which
245 -- is made semi-closed.
247 -- hGetContents on a DuplexHandle only affects the read side: you can
248 -- carry on writing to it afterwards.
250 hGetContents :: Handle -> IO String
251 hGetContents handle =
252 withHandle "hGetContents" handle $ \handle_ ->
253 case haType handle_ of
254 ClosedHandle -> ioe_closedHandle
255 SemiClosedHandle -> ioe_closedHandle
256 AppendHandle -> ioe_notReadable
257 WriteHandle -> ioe_notReadable
258 _ -> do xs <- lazyRead handle
259 return (handle_{ haType=SemiClosedHandle}, xs )
261 -- Note that someone may close the semi-closed handle (or change its
262 -- buffering), so each time these lazy read functions are pulled on,
263 -- they have to check whether the handle has indeed been closed.
265 lazyRead :: Handle -> IO String
268 withHandle "lazyRead" handle $ \ handle_ -> do
269 case haType handle_ of
270 ClosedHandle -> return (handle_, "")
271 SemiClosedHandle -> lazyRead' handle handle_
273 (IOError (Just handle) IllegalOperation "lazyRead"
274 "illegal handle type" Nothing)
276 lazyRead' h handle_ = do
277 let ref = haBuffer handle_
280 -- even a NoBuffering handle can have a char in the buffer...
283 if not (bufferEmpty buf)
284 then lazyReadHaveBuffer h handle_ fd ref buf
287 case haBufferMode handle_ of
289 -- make use of the minimal buffer we already have
291 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
292 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
295 then do handle_ <- hClose_help handle_
297 else do (c,_) <- readCharFromBuffer raw 0
299 return (handle_, c : rest)
301 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
302 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
304 -- we never want to block during the read, so we call fillReadBuffer with
305 -- is_line==True, which tells it to "just read what there is".
306 lazyReadBuffered h handle_ fd ref buf = do
308 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
309 lazyReadHaveBuffer h handle_ fd ref buf
311 -- all I/O errors are discarded. Additionally, we close the handle.
312 (\e -> do handle_ <- hClose_help handle_
316 lazyReadHaveBuffer h handle_ fd ref buf = do
318 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
319 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
323 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
324 unpackAcc buf r 0 acc = return acc
325 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
328 | i <# r = (# s, acc #)
330 case readCharArray# buf i s of
331 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
333 -- ---------------------------------------------------------------------------
336 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
337 -- managed by `hdl'. Characters may be buffered if buffering is
338 -- enabled for `hdl'.
340 hPutChar :: Handle -> Char -> IO ()
342 c `seq` do -- must evaluate c before grabbing the handle lock
343 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
344 let fd = haFD handle_
345 case haBufferMode handle_ of
346 LineBuffering -> hPutcBuffered handle_ True c
347 BlockBuffering _ -> hPutcBuffered handle_ False c
349 withObject (castCharToCChar c) $ \buf ->
350 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
351 (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
355 hPutcBuffered handle_ is_line c = do
356 let ref = haBuffer handle_
359 w' <- writeCharIntoBuffer (bufBuf buf) w c
360 let new_buf = buf{ bufWPtr = w' }
361 if bufferFull new_buf || is_line && c == '\n'
363 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
364 writeIORef ref flushed_buf
366 writeIORef ref new_buf
369 hPutChars :: Handle -> [Char] -> IO ()
370 hPutChars handle [] = return ()
371 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
373 -- ---------------------------------------------------------------------------
376 -- `hPutStr hdl s' writes the string `s' to the file or
377 -- hannel managed by `hdl', buffering the output if needs be.
379 -- We go to some trouble to avoid keeping the handle locked while we're
380 -- evaluating the string argument to hPutStr, in case doing so triggers another
381 -- I/O operation on the same handle which would lead to deadlock. The classic
384 -- putStr (trace "hello" "world")
386 -- so the basic scheme is this:
388 -- * copy the string into a fresh buffer,
389 -- * "commit" the buffer to the handle.
391 -- Committing may involve simply copying the contents of the new
392 -- buffer into the handle's buffer, flushing one or both buffers, or
393 -- maybe just swapping the buffers over (if the handle's buffer was
394 -- empty). See commitBuffer below.
396 hPutStr :: Handle -> String -> IO ()
397 hPutStr handle str = do
398 buffer_mode <- wantWritableHandle "hPutStr" handle
399 (\ handle_ -> do getSpareBuffer handle_)
401 (NoBuffering, _) -> do
402 hPutChars handle str -- v. slow, but we don't care
403 (LineBuffering, buf) -> do
404 writeLines handle buf str
405 (BlockBuffering _, buf) -> do
406 writeBlocks handle buf str
409 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
410 getSpareBuffer Handle__{haBuffer=ref,
415 NoBuffering -> return (mode, error "no buffer!")
417 bufs <- readIORef spare_ref
420 BufferListCons b rest -> do
421 writeIORef spare_ref rest
422 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
424 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
425 return (mode, new_buf)
428 writeLines :: Handle -> Buffer -> String -> IO ()
429 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
431 shoveString :: Int -> [Char] -> IO ()
432 -- check n == len first, to ensure that shoveString is strict in n.
433 shoveString n cs | n == len = do
434 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
435 writeLines hdl new_buf cs
436 shoveString n [] = do
437 commitBuffer hdl raw len n False{-no flush-} True{-release-}
439 shoveString n (c:cs) = do
440 n' <- writeCharIntoBuffer raw n c
443 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
444 writeLines hdl new_buf cs
450 writeBlocks :: Handle -> Buffer -> String -> IO ()
451 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
453 shoveString :: Int -> [Char] -> IO ()
454 -- check n == len first, to ensure that shoveString is strict in n.
455 shoveString n cs | n == len = do
456 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
457 writeBlocks hdl new_buf cs
458 shoveString n [] = do
459 commitBuffer hdl raw len n False{-no flush-} True{-release-}
461 shoveString n (c:cs) = do
462 n' <- writeCharIntoBuffer raw n c
467 -- -----------------------------------------------------------------------------
468 -- commitBuffer handle buf sz count flush release
470 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
471 -- 'count' bytes of data) to handle (handle must be block or line buffered).
475 -- for block/line buffering,
476 -- 1. If there isn't room in the handle buffer, flush the handle
479 -- 2. If the handle buffer is empty,
481 -- then write buf directly to the device.
482 -- else swap the handle buffer with buf.
484 -- 3. If the handle buffer is non-empty, copy buf into the
485 -- handle buffer. Then, if flush != 0, flush
489 :: Handle -- handle to commit to
490 -> RawBuffer -> Int -- address and size (in bytes) of buffer
491 -> Int -- number of bytes of data in buffer
492 -> Bool -- True <=> flush the handle afterward
493 -> Bool -- release the buffer?
496 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
497 wantWritableHandle "commitAndReleaseBuffer" hdl $
498 commitBuffer' hdl raw sz count flush release
500 -- Explicitly lambda-lift this function to subvert GHC's full laziness
501 -- optimisations, which otherwise tends to float out subexpressions
502 -- past the \handle, which is really a pessimisation in this case because
503 -- that lambda is a one-shot lambda.
505 -- Don't forget to export the function, to stop it being inlined too
506 -- (this appears to be better than NOINLINE, because the strictness
507 -- analyser still gets to worker-wrapper it).
509 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
511 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
512 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
515 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
516 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
519 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
523 -- enough room in handle buffer?
524 if (not flush && (size - w > count))
525 -- The > is to be sure that we never exactly fill
526 -- up the buffer, which would require a flush. So
527 -- if copying the new data into the buffer would
528 -- make the buffer full, we just flush the existing
529 -- buffer and the new data immediately, rather than
530 -- copying before flushing.
532 -- not flushing, and there's enough room in the buffer:
533 -- just copy the data in and update bufWPtr.
534 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
535 writeIORef ref old_buf{ bufWPtr = w + count }
536 return (newEmptyBuffer raw WriteBuffer sz)
538 -- else, we have to flush
539 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
542 Buffer{ bufBuf=raw, bufState=WriteBuffer,
543 bufRPtr=0, bufWPtr=count, bufSize=sz }
545 -- if: (a) we don't have to flush, and
546 -- (b) size(new buffer) == size(old buffer), and
547 -- (c) new buffer is not full,
548 -- we can just just swap them over...
549 if (not flush && sz == size && count /= sz)
551 writeIORef ref this_buf
554 -- otherwise, we have to flush the new data too,
555 -- and start with a fresh buffer
557 flushWriteBuffer fd (haIsStream handle_) this_buf
558 writeIORef ref flushed_buf
559 -- if the sizes were different, then allocate
560 -- a new buffer of the correct size.
562 then return (newEmptyBuffer raw WriteBuffer sz)
563 else allocateBuffer size WriteBuffer
565 -- release the buffer if necessary
567 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
568 if release && buf_ret_sz == size
570 spare_bufs <- readIORef spare_buf_ref
571 writeIORef spare_buf_ref
572 (BufferListCons buf_ret_raw spare_bufs)
577 -- ---------------------------------------------------------------------------
578 -- Reading/writing sequences of bytes.
581 Semantics of hGetBuf:
583 - hGetBuf reads data into the buffer until either
586 (b) the buffer is full
588 It returns the amount of data actually read. This may
589 be zero in case (a). hGetBuf never raises
590 an EOF exception, it always returns zero instead.
592 If the handle is a pipe or socket, and the writing end
593 is closed, hGetBuf will behave as for condition (a).
595 Semantics of hPutBuf:
597 - hPutBuf writes data from the buffer to the handle
598 until the buffer is empty. It returns ().
600 If the handle is a pipe or socket, and the reading end is
601 closed, hPutBuf will raise a ResourceVanished exception.
602 (If this is a POSIX system, and the program has not
603 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
604 instead, whose default action is to terminate the program).
607 -- ---------------------------------------------------------------------------
610 hPutBuf :: Handle -- handle to write to
611 -> Ptr a -- address of buffer
612 -> Int -- number of bytes of data in buffer
614 hPutBuf handle ptr count
615 | count == 0 = return ()
616 | count < 0 = illegalBufferSize handle "hPutBuf" count
618 wantWritableHandle "hPutBuf" handle $
619 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
621 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
624 -- enough room in handle buffer?
625 if (size - w > count)
626 -- There's enough room in the buffer:
627 -- just copy the data in and update bufWPtr.
628 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
629 writeIORef ref old_buf{ bufWPtr = w + count }
632 -- else, we have to flush
633 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
634 writeIORef ref flushed_buf
635 -- ToDo: should just memcpy instead of writing if possible
636 writeChunk fd ptr count
638 writeChunk :: FD -> Ptr a -> Int -> IO ()
639 writeChunk fd ptr bytes = loop 0 bytes
641 loop :: Int -> Int -> IO ()
642 loop _ bytes | bytes <= 0 = return ()
644 r <- fromIntegral `liftM`
645 throwErrnoIfMinus1RetryMayBlock "writeChunk"
646 (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
648 -- write can't return 0
649 loop (off + r) (bytes - r)
651 -- ---------------------------------------------------------------------------
654 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
655 hGetBuf handle ptr count
656 | count == 0 = return 0
657 | count < 0 = illegalBufferSize handle "hGetBuf" count
659 wantReadableHandle "hGetBuf" handle $
660 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
661 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
663 then readChunk fd ptr count
666 copied <- if (count >= avail)
668 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
669 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
672 memcpy_ptr_baoff ptr raw r (fromIntegral count)
673 writeIORef ref buf{ bufRPtr = r + count }
676 let remaining = count - copied
678 then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
679 return (rest + copied)
682 readChunk :: FD -> Ptr a -> Int -> IO Int
683 readChunk fd ptr bytes = loop 0 bytes
685 loop :: Int -> Int -> IO Int
686 loop off bytes | bytes <= 0 = return off
688 r <- fromIntegral `liftM`
689 throwErrnoIfMinus1RetryMayBlock "readChunk"
690 (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
694 else loop (off + r) (bytes - r)
696 slurpFile :: FilePath -> IO (Ptr (), Int)
698 handle <- openFile fname ReadMode
699 sz <- hFileSize handle
700 if sz > fromIntegral (maxBound::Int) then
701 ioError (userError "slurpFile: file too big")
703 let sz_i = fromIntegral sz
704 if sz_i == 0 then return (nullPtr, 0) else do
705 chunk <- mallocBytes sz_i
706 r <- hGetBuf handle chunk sz_i
710 -- ---------------------------------------------------------------------------
713 foreign import ccall unsafe "__hscore_memcpy_src_off"
714 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
715 foreign import ccall unsafe "__hscore_memcpy_src_off"
716 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
717 foreign import ccall unsafe "__hscore_memcpy_dst_off"
718 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
719 foreign import ccall unsafe "__hscore_memcpy_dst_off"
720 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
722 -----------------------------------------------------------------------------
725 illegalBufferSize :: Handle -> String -> Int -> IO a
726 illegalBufferSize handle fn (sz :: Int) =
727 ioException (IOError (Just handle)
729 ("illegal buffer size " ++ showsPrec 9 sz [])