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 <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
109 else do (c,_) <- readCharFromBuffer raw 0
112 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
113 = do (c,r) <- readCharFromBuffer b r
114 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
115 | otherwise = buf{ bufRPtr=r }
116 writeIORef ref new_buf
119 -- ---------------------------------------------------------------------------
122 -- If EOF is reached before EOL is encountered, ignore the EOF and
123 -- return the partial line. Next attempt at calling hGetLine on the
124 -- handle will yield an EOF IO exception though.
126 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
128 hGetLine :: Handle -> IO String
130 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
131 case haBufferMode handle_ of
132 NoBuffering -> return Nothing
134 l <- hGetLineBuffered handle_
136 BlockBuffering _ -> do
137 l <- hGetLineBuffered handle_
140 Nothing -> hGetLineUnBuffered h
144 hGetLineBuffered handle_ = do
145 let ref = haBuffer handle_
147 hGetLineBufferedLoop handle_ ref buf []
150 hGetLineBufferedLoop handle_ ref
151 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
153 -- find the end-of-line character, if there is one
155 | r == w = return (False, w)
157 (c,r') <- readCharFromBuffer raw r
159 then return (True, r) -- NB. not r': don't include the '\n'
162 (eol, off) <- loop raw r
165 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
168 xs <- unpack raw r off
170 -- if eol == True, then off is the offset of the '\n'
171 -- otherwise off == w and the buffer is now empty.
173 then do if (w == off + 1)
174 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
175 else writeIORef ref buf{ bufRPtr = off + 1 }
176 return (concat (reverse (xs:xss)))
178 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
179 buf{ bufWPtr=0, bufRPtr=0 }
181 -- Nothing indicates we caught an EOF, and we may have a
182 -- partial line to return.
184 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
185 let str = concat (reverse (xs:xss))
190 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
193 maybeFillReadBuffer fd is_line is_stream buf
195 (do buf <- fillReadBuffer fd is_line is_stream buf
198 (\e -> do if isEOFError e
203 unpack :: RawBuffer -> Int -> Int -> IO [Char]
204 unpack buf r 0 = return ""
205 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
208 | i <# r = (# s, acc #)
210 case readCharArray# buf i s of
211 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
214 hGetLineUnBuffered :: Handle -> IO String
215 hGetLineUnBuffered h = do
228 if isEOFError err then
238 -- -----------------------------------------------------------------------------
241 -- hGetContents returns the list of characters corresponding to the
242 -- unread portion of the channel or file managed by the handle, which
243 -- is made semi-closed.
245 -- hGetContents on a DuplexHandle only affects the read side: you can
246 -- carry on writing to it afterwards.
248 hGetContents :: Handle -> IO String
249 hGetContents handle =
250 withHandle "hGetContents" handle $ \handle_ ->
251 case haType handle_ of
252 ClosedHandle -> ioe_closedHandle
253 SemiClosedHandle -> ioe_closedHandle
254 AppendHandle -> ioe_notReadable
255 WriteHandle -> ioe_notReadable
256 _ -> do xs <- lazyRead handle
257 return (handle_{ haType=SemiClosedHandle}, xs )
259 -- Note that someone may close the semi-closed handle (or change its
260 -- buffering), so each time these lazy read functions are pulled on,
261 -- they have to check whether the handle has indeed been closed.
263 lazyRead :: Handle -> IO String
266 withHandle "lazyRead" handle $ \ handle_ -> do
267 case haType handle_ of
268 ClosedHandle -> return (handle_, "")
269 SemiClosedHandle -> lazyRead' handle handle_
271 (IOError (Just handle) IllegalOperation "lazyRead"
272 "illegal handle type" Nothing)
274 lazyRead' h handle_ = do
275 let ref = haBuffer handle_
278 -- even a NoBuffering handle can have a char in the buffer...
281 if not (bufferEmpty buf)
282 then lazyReadHaveBuffer h handle_ fd ref buf
285 case haBufferMode handle_ of
287 -- make use of the minimal buffer we already have
289 r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
291 then do handle_ <- hClose_help handle_
293 else do (c,_) <- readCharFromBuffer raw 0
295 return (handle_, c : rest)
297 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
298 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
300 -- we never want to block during the read, so we call fillReadBuffer with
301 -- is_line==True, which tells it to "just read what there is".
302 lazyReadBuffered h handle_ fd ref buf = do
304 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
305 lazyReadHaveBuffer h handle_ fd ref buf
307 -- all I/O errors are discarded. Additionally, we close the handle.
308 (\e -> do handle_ <- hClose_help handle_
312 lazyReadHaveBuffer h handle_ fd ref buf = do
314 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
315 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
319 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
320 unpackAcc buf r 0 acc = return acc
321 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
324 | i <# r = (# s, acc #)
326 case readCharArray# buf i s of
327 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
329 -- ---------------------------------------------------------------------------
332 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
333 -- managed by `hdl'. Characters may be buffered if buffering is
334 -- enabled for `hdl'.
336 hPutChar :: Handle -> Char -> IO ()
338 c `seq` do -- must evaluate c before grabbing the handle lock
339 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
340 let fd = haFD handle_
341 case haBufferMode handle_ of
342 LineBuffering -> hPutcBuffered handle_ True c
343 BlockBuffering _ -> hPutcBuffered handle_ False c
345 withObject (castCharToCChar c) $ \buf -> do
346 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
349 hPutcBuffered handle_ is_line c = do
350 let ref = haBuffer handle_
353 w' <- writeCharIntoBuffer (bufBuf buf) w c
354 let new_buf = buf{ bufWPtr = w' }
355 if bufferFull new_buf || is_line && c == '\n'
357 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
358 writeIORef ref flushed_buf
360 writeIORef ref new_buf
363 hPutChars :: Handle -> [Char] -> IO ()
364 hPutChars handle [] = return ()
365 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
367 -- ---------------------------------------------------------------------------
370 -- `hPutStr hdl s' writes the string `s' to the file or
371 -- hannel managed by `hdl', buffering the output if needs be.
373 -- We go to some trouble to avoid keeping the handle locked while we're
374 -- evaluating the string argument to hPutStr, in case doing so triggers another
375 -- I/O operation on the same handle which would lead to deadlock. The classic
378 -- putStr (trace "hello" "world")
380 -- so the basic scheme is this:
382 -- * copy the string into a fresh buffer,
383 -- * "commit" the buffer to the handle.
385 -- Committing may involve simply copying the contents of the new
386 -- buffer into the handle's buffer, flushing one or both buffers, or
387 -- maybe just swapping the buffers over (if the handle's buffer was
388 -- empty). See commitBuffer below.
390 hPutStr :: Handle -> String -> IO ()
391 hPutStr handle str = do
392 buffer_mode <- wantWritableHandle "hPutStr" handle
393 (\ handle_ -> do getSpareBuffer handle_)
395 (NoBuffering, _) -> do
396 hPutChars handle str -- v. slow, but we don't care
397 (LineBuffering, buf) -> do
398 writeLines handle buf str
399 (BlockBuffering _, buf) -> do
400 writeBlocks handle buf str
403 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
404 getSpareBuffer Handle__{haBuffer=ref,
409 NoBuffering -> return (mode, error "no buffer!")
411 bufs <- readIORef spare_ref
414 BufferListCons b rest -> do
415 writeIORef spare_ref rest
416 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
418 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
419 return (mode, new_buf)
422 writeLines :: Handle -> Buffer -> String -> IO ()
423 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
425 shoveString :: Int -> [Char] -> IO ()
426 -- check n == len first, to ensure that shoveString is strict in n.
427 shoveString n cs | n == len = do
428 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
429 writeLines hdl new_buf cs
430 shoveString n [] = do
431 commitBuffer hdl raw len n False{-no flush-} True{-release-}
433 shoveString n (c:cs) = do
434 n' <- writeCharIntoBuffer raw n c
437 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
438 writeLines hdl new_buf cs
444 writeBlocks :: Handle -> Buffer -> String -> IO ()
445 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
447 shoveString :: Int -> [Char] -> IO ()
448 -- check n == len first, to ensure that shoveString is strict in n.
449 shoveString n cs | n == len = do
450 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
451 writeBlocks hdl new_buf cs
452 shoveString n [] = do
453 commitBuffer hdl raw len n False{-no flush-} True{-release-}
455 shoveString n (c:cs) = do
456 n' <- writeCharIntoBuffer raw n c
461 -- -----------------------------------------------------------------------------
462 -- commitBuffer handle buf sz count flush release
464 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
465 -- 'count' bytes of data) to handle (handle must be block or line buffered).
469 -- for block/line buffering,
470 -- 1. If there isn't room in the handle buffer, flush the handle
473 -- 2. If the handle buffer is empty,
475 -- then write buf directly to the device.
476 -- else swap the handle buffer with buf.
478 -- 3. If the handle buffer is non-empty, copy buf into the
479 -- handle buffer. Then, if flush != 0, flush
483 :: Handle -- handle to commit to
484 -> RawBuffer -> Int -- address and size (in bytes) of buffer
485 -> Int -- number of bytes of data in buffer
486 -> Bool -- True <=> flush the handle afterward
487 -> Bool -- release the buffer?
490 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
491 wantWritableHandle "commitAndReleaseBuffer" hdl $
492 commitBuffer' hdl raw sz count flush release
494 -- Explicitly lambda-lift this function to subvert GHC's full laziness
495 -- optimisations, which otherwise tends to float out subexpressions
496 -- past the \handle, which is really a pessimisation in this case because
497 -- that lambda is a one-shot lambda.
499 -- Don't forget to export the function, to stop it being inlined too
500 -- (this appears to be better than NOINLINE, because the strictness
501 -- analyser still gets to worker-wrapper it).
503 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
505 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
506 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
509 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
510 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
513 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
517 -- enough room in handle buffer?
518 if (not flush && (size - w > count))
519 -- The > is to be sure that we never exactly fill
520 -- up the buffer, which would require a flush. So
521 -- if copying the new data into the buffer would
522 -- make the buffer full, we just flush the existing
523 -- buffer and the new data immediately, rather than
524 -- copying before flushing.
526 -- not flushing, and there's enough room in the buffer:
527 -- just copy the data in and update bufWPtr.
528 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
529 writeIORef ref old_buf{ bufWPtr = w + count }
530 return (newEmptyBuffer raw WriteBuffer sz)
532 -- else, we have to flush
533 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
536 Buffer{ bufBuf=raw, bufState=WriteBuffer,
537 bufRPtr=0, bufWPtr=count, bufSize=sz }
539 -- if: (a) we don't have to flush, and
540 -- (b) size(new buffer) == size(old buffer), and
541 -- (c) new buffer is not full,
542 -- we can just just swap them over...
543 if (not flush && sz == size && count /= sz)
545 writeIORef ref this_buf
548 -- otherwise, we have to flush the new data too,
549 -- and start with a fresh buffer
551 flushWriteBuffer fd (haIsStream handle_) this_buf
552 writeIORef ref flushed_buf
553 -- if the sizes were different, then allocate
554 -- a new buffer of the correct size.
556 then return (newEmptyBuffer raw WriteBuffer sz)
557 else allocateBuffer size WriteBuffer
559 -- release the buffer if necessary
561 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
562 if release && buf_ret_sz == size
564 spare_bufs <- readIORef spare_buf_ref
565 writeIORef spare_buf_ref
566 (BufferListCons buf_ret_raw spare_bufs)
571 -- ---------------------------------------------------------------------------
572 -- Reading/writing sequences of bytes.
575 Semantics of hGetBuf:
577 - hGetBuf reads data into the buffer until either
580 (b) the buffer is full
582 It returns the amount of data actually read. This may
583 be zero in case (a). hGetBuf never raises
584 an EOF exception, it always returns zero instead.
586 If the handle is a pipe or socket, and the writing end
587 is closed, hGetBuf will behave as for condition (a).
589 Semantics of hPutBuf:
591 - hPutBuf writes data from the buffer to the handle
592 until the buffer is empty. It returns ().
594 If the handle is a pipe or socket, and the reading end is
595 closed, hPutBuf will raise a ResourceVanished exception.
596 (If this is a POSIX system, and the program has not
597 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
598 instead, whose default action is to terminate the program).
601 -- ---------------------------------------------------------------------------
604 hPutBuf :: Handle -- handle to write to
605 -> Ptr a -- address of buffer
606 -> Int -- number of bytes of data in buffer
608 hPutBuf handle ptr count
609 | count == 0 = return ()
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 is_stream (castPtr ptr) count
632 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
633 writeChunk fd is_stream ptr bytes = loop 0 bytes
635 loop :: Int -> Int -> IO ()
636 loop _ bytes | bytes <= 0 = return ()
638 r <- fromIntegral `liftM`
639 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
640 off (fromIntegral bytes)
641 -- write can't return 0
642 loop (off + r) (bytes - r)
644 -- ---------------------------------------------------------------------------
647 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
648 hGetBuf handle ptr count
649 | count == 0 = return 0
650 | count < 0 = illegalBufferSize handle "hGetBuf" count
652 wantReadableHandle "hGetBuf" handle $
653 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
654 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
656 then readChunk fd is_stream 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 is_stream (ptr `plusPtr` copied) remaining
672 return (rest + copied)
675 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
676 readChunk fd is_stream ptr bytes = loop 0 bytes
678 loop :: Int -> Int -> IO Int
679 loop off bytes | bytes <= 0 = return off
681 r <- fromIntegral `liftM`
682 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
683 (castPtr ptr) off (fromIntegral bytes)
686 else loop (off + r) (bytes - r)
688 slurpFile :: FilePath -> IO (Ptr (), Int)
690 handle <- openFile fname ReadMode
691 sz <- hFileSize handle
692 if sz > fromIntegral (maxBound::Int) then
693 ioError (userError "slurpFile: file too big")
695 let sz_i = fromIntegral sz
696 if sz_i == 0 then return (nullPtr, 0) else do
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 [])