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
36 import System.Posix.Internals
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 True (haIsStream handle_) buf
103 -- don't wait for a completely full buffer.
104 hGetcBuffered fd ref new_buf
106 -- make use of the minimal buffer we already have
108 r <- readRawBuffer "hGetChar" (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 <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
293 then do handle_ <- hClose_help handle_
295 else do (c,_) <- readCharFromBuffer raw 0
297 return (handle_, c : rest)
299 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
300 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
302 -- we never want to block during the read, so we call fillReadBuffer with
303 -- is_line==True, which tells it to "just read what there is".
304 lazyReadBuffered h handle_ fd ref buf = do
306 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
307 lazyReadHaveBuffer h handle_ fd ref buf
309 -- all I/O errors are discarded. Additionally, we close the handle.
310 (\e -> do handle_ <- hClose_help handle_
314 lazyReadHaveBuffer h handle_ fd ref buf = do
316 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
317 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
321 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
322 unpackAcc buf r 0 acc = return acc
323 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
326 | i <# r = (# s, acc #)
328 case readCharArray# buf i s of
329 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
331 -- ---------------------------------------------------------------------------
334 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
335 -- managed by `hdl'. Characters may be buffered if buffering is
336 -- enabled for `hdl'.
338 hPutChar :: Handle -> Char -> IO ()
340 c `seq` do -- must evaluate c before grabbing the handle lock
341 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
342 let fd = haFD handle_
343 case haBufferMode handle_ of
344 LineBuffering -> hPutcBuffered handle_ True c
345 BlockBuffering _ -> hPutcBuffered handle_ False c
347 withObject (castCharToCChar c) $ \buf -> do
348 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
351 hPutcBuffered handle_ is_line c = do
352 let ref = haBuffer handle_
355 w' <- writeCharIntoBuffer (bufBuf buf) w c
356 let new_buf = buf{ bufWPtr = w' }
357 if bufferFull new_buf || is_line && c == '\n'
359 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
360 writeIORef ref flushed_buf
362 writeIORef ref new_buf
365 hPutChars :: Handle -> [Char] -> IO ()
366 hPutChars handle [] = return ()
367 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
369 -- ---------------------------------------------------------------------------
372 -- `hPutStr hdl s' writes the string `s' to the file or
373 -- hannel managed by `hdl', buffering the output if needs be.
375 -- We go to some trouble to avoid keeping the handle locked while we're
376 -- evaluating the string argument to hPutStr, in case doing so triggers another
377 -- I/O operation on the same handle which would lead to deadlock. The classic
380 -- putStr (trace "hello" "world")
382 -- so the basic scheme is this:
384 -- * copy the string into a fresh buffer,
385 -- * "commit" the buffer to the handle.
387 -- Committing may involve simply copying the contents of the new
388 -- buffer into the handle's buffer, flushing one or both buffers, or
389 -- maybe just swapping the buffers over (if the handle's buffer was
390 -- empty). See commitBuffer below.
392 hPutStr :: Handle -> String -> IO ()
393 hPutStr handle str = do
394 buffer_mode <- wantWritableHandle "hPutStr" handle
395 (\ handle_ -> do getSpareBuffer handle_)
397 (NoBuffering, _) -> do
398 hPutChars handle str -- v. slow, but we don't care
399 (LineBuffering, buf) -> do
400 writeLines handle buf str
401 (BlockBuffering _, buf) -> do
402 writeBlocks handle buf str
405 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
406 getSpareBuffer Handle__{haBuffer=ref,
411 NoBuffering -> return (mode, error "no buffer!")
413 bufs <- readIORef spare_ref
416 BufferListCons b rest -> do
417 writeIORef spare_ref rest
418 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
420 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
421 return (mode, new_buf)
424 writeLines :: Handle -> Buffer -> String -> IO ()
425 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
427 shoveString :: Int -> [Char] -> IO ()
428 -- check n == len first, to ensure that shoveString is strict in n.
429 shoveString n cs | n == len = do
430 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
431 writeLines hdl new_buf cs
432 shoveString n [] = do
433 commitBuffer hdl raw len n False{-no flush-} True{-release-}
435 shoveString n (c:cs) = do
436 n' <- writeCharIntoBuffer raw n c
439 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
440 writeLines hdl new_buf cs
446 writeBlocks :: Handle -> Buffer -> String -> IO ()
447 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
449 shoveString :: Int -> [Char] -> IO ()
450 -- check n == len first, to ensure that shoveString is strict in n.
451 shoveString n cs | n == len = do
452 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
453 writeBlocks hdl new_buf cs
454 shoveString n [] = do
455 commitBuffer hdl raw len n False{-no flush-} True{-release-}
457 shoveString n (c:cs) = do
458 n' <- writeCharIntoBuffer raw n c
463 -- -----------------------------------------------------------------------------
464 -- commitBuffer handle buf sz count flush release
466 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
467 -- 'count' bytes of data) to handle (handle must be block or line buffered).
471 -- for block/line buffering,
472 -- 1. If there isn't room in the handle buffer, flush the handle
475 -- 2. If the handle buffer is empty,
477 -- then write buf directly to the device.
478 -- else swap the handle buffer with buf.
480 -- 3. If the handle buffer is non-empty, copy buf into the
481 -- handle buffer. Then, if flush != 0, flush
485 :: Handle -- handle to commit to
486 -> RawBuffer -> Int -- address and size (in bytes) of buffer
487 -> Int -- number of bytes of data in buffer
488 -> Bool -- True <=> flush the handle afterward
489 -> Bool -- release the buffer?
492 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
493 wantWritableHandle "commitAndReleaseBuffer" hdl $
494 commitBuffer' hdl raw sz count flush release
496 -- Explicitly lambda-lift this function to subvert GHC's full laziness
497 -- optimisations, which otherwise tends to float out subexpressions
498 -- past the \handle, which is really a pessimisation in this case because
499 -- that lambda is a one-shot lambda.
501 -- Don't forget to export the function, to stop it being inlined too
502 -- (this appears to be better than NOINLINE, because the strictness
503 -- analyser still gets to worker-wrapper it).
505 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
507 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
508 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
511 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
512 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
515 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
519 -- enough room in handle buffer?
520 if (not flush && (size - w > count))
521 -- The > is to be sure that we never exactly fill
522 -- up the buffer, which would require a flush. So
523 -- if copying the new data into the buffer would
524 -- make the buffer full, we just flush the existing
525 -- buffer and the new data immediately, rather than
526 -- copying before flushing.
528 -- not flushing, and there's enough room in the buffer:
529 -- just copy the data in and update bufWPtr.
530 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
531 writeIORef ref old_buf{ bufWPtr = w + count }
532 return (newEmptyBuffer raw WriteBuffer sz)
534 -- else, we have to flush
535 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
538 Buffer{ bufBuf=raw, bufState=WriteBuffer,
539 bufRPtr=0, bufWPtr=count, bufSize=sz }
541 -- if: (a) we don't have to flush, and
542 -- (b) size(new buffer) == size(old buffer), and
543 -- (c) new buffer is not full,
544 -- we can just just swap them over...
545 if (not flush && sz == size && count /= sz)
547 writeIORef ref this_buf
550 -- otherwise, we have to flush the new data too,
551 -- and start with a fresh buffer
553 flushWriteBuffer fd (haIsStream handle_) this_buf
554 writeIORef ref flushed_buf
555 -- if the sizes were different, then allocate
556 -- a new buffer of the correct size.
558 then return (newEmptyBuffer raw WriteBuffer sz)
559 else allocateBuffer size WriteBuffer
561 -- release the buffer if necessary
563 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
564 if release && buf_ret_sz == size
566 spare_bufs <- readIORef spare_buf_ref
567 writeIORef spare_buf_ref
568 (BufferListCons buf_ret_raw spare_bufs)
573 -- ---------------------------------------------------------------------------
574 -- Reading/writing sequences of bytes.
577 Semantics of hGetBuf:
579 - hGetBuf reads data into the buffer until either
582 (b) the buffer is full
584 It returns the amount of data actually read. This may
585 be zero in case (a). hGetBuf never raises
586 an EOF exception, it always returns zero instead.
588 If the handle is a pipe or socket, and the writing end
589 is closed, hGetBuf will behave as for condition (a).
591 Semantics of hPutBuf:
593 - hPutBuf writes data from the buffer to the handle
594 until the buffer is empty. It returns ().
596 If the handle is a pipe or socket, and the reading end is
597 closed, hPutBuf will raise a ResourceVanished exception.
598 (If this is a POSIX system, and the program has not
599 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
600 instead, whose default action is to terminate the program).
603 -- ---------------------------------------------------------------------------
606 hPutBuf :: Handle -- handle to write to
607 -> Ptr a -- address of buffer
608 -> Int -- number of bytes of data in buffer
610 hPutBuf handle ptr count
611 | count == 0 = return ()
612 | count < 0 = illegalBufferSize handle "hPutBuf" count
614 wantWritableHandle "hPutBuf" handle $
615 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
617 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
620 -- enough room in handle buffer?
621 if (size - w > count)
622 -- There's enough room in the buffer:
623 -- just copy the data in and update bufWPtr.
624 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
625 writeIORef ref old_buf{ bufWPtr = w + count }
628 -- else, we have to flush
629 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
630 writeIORef ref flushed_buf
631 -- ToDo: should just memcpy instead of writing if possible
632 writeChunk fd is_stream (castPtr ptr) count
634 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
635 writeChunk fd is_stream ptr bytes = loop 0 bytes
637 loop :: Int -> Int -> IO ()
638 loop _ bytes | bytes <= 0 = return ()
640 r <- fromIntegral `liftM`
641 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
642 off (fromIntegral bytes)
643 -- write can't return 0
644 loop (off + r) (bytes - r)
646 -- ---------------------------------------------------------------------------
649 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
650 hGetBuf handle ptr count
651 | count == 0 = return 0
652 | count < 0 = illegalBufferSize handle "hGetBuf" count
654 wantReadableHandle "hGetBuf" handle $
655 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
656 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
658 then readChunk fd is_stream ptr count
661 copied <- if (count >= avail)
663 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
664 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
667 memcpy_ptr_baoff ptr raw r (fromIntegral count)
668 writeIORef ref buf{ bufRPtr = r + count }
671 let remaining = count - copied
673 then do rest <- readChunk fd is_stream (ptr `plusPtr` copied) remaining
674 return (rest + copied)
677 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
678 readChunk fd is_stream ptr bytes = loop 0 bytes
680 loop :: Int -> Int -> IO Int
681 loop off bytes | bytes <= 0 = return off
683 r <- fromIntegral `liftM`
684 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
685 (castPtr ptr) off (fromIntegral bytes)
688 else loop (off + r) (bytes - r)
690 slurpFile :: FilePath -> IO (Ptr (), Int)
692 handle <- openFile fname ReadMode
693 sz <- hFileSize handle
694 if sz > fromIntegral (maxBound::Int) then
695 ioError (userError "slurpFile: file too big")
697 let sz_i = fromIntegral sz
698 if sz_i == 0 then return (nullPtr, 0) else do
699 chunk <- mallocBytes sz_i
700 r <- hGetBuf handle chunk sz_i
704 -- ---------------------------------------------------------------------------
707 foreign import ccall unsafe "__hscore_memcpy_src_off"
708 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
709 foreign import ccall unsafe "__hscore_memcpy_src_off"
710 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
711 foreign import ccall unsafe "__hscore_memcpy_dst_off"
712 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
713 foreign import ccall unsafe "__hscore_memcpy_dst_off"
714 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
716 -----------------------------------------------------------------------------
719 illegalBufferSize :: Handle -> String -> Int -> IO a
720 illegalBufferSize handle fn (sz :: Int) =
721 ioException (IOError (Just handle)
723 ("illegal buffer size " ++ showsPrec 9 sz [])