1 {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
2 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
3 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
4 {-# OPTIONS_GHC -XRecordWildCards #-}
5 {-# OPTIONS_HADDOCK hide #-}
9 -----------------------------------------------------------------------------
11 -- Module : GHC.IO.Handle.Internals
12 -- Copyright : (c) The University of Glasgow, 1994-2001
13 -- License : see libraries/base/LICENSE
15 -- Maintainer : libraries@haskell.org
16 -- Stability : internal
17 -- Portability : non-portable
19 -- This module defines the basic operations on I\/O \"handles\". All
20 -- of the operations defined here are independent of the underlying
23 -----------------------------------------------------------------------------
26 module GHC.IO.Handle.Internals (
27 withHandle, withHandle', withHandle_,
28 withHandle__', withHandle_', withAllHandles__,
29 wantWritableHandle, wantReadableHandle, wantReadableHandle_,
32 mkHandle, mkFileHandle, mkDuplexHandle,
33 openTextEncoding, initBufferState,
34 dEFAULT_CHAR_BUFFER_SIZE,
36 flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer,
37 flushCharBuffer, flushByteReadBuffer,
39 readTextDevice, writeTextDevice, readTextDeviceNonBlocking,
42 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
43 ioe_finalizedHandle, ioe_bufsiz,
45 hClose_help, hLookAhead_,
47 HandleFinalizer, handleFinalizer,
54 import GHC.IO.Encoding
55 import GHC.IO.Handle.Types
57 import GHC.IO.BufferedIO (BufferedIO)
58 import GHC.IO.Exception
59 import GHC.IO.Device (IODevice, SeekMode(..))
60 import qualified GHC.IO.Device as IODevice
61 import qualified GHC.IO.BufferedIO as Buffered
66 import GHC.Num ( Num(..) )
74 -- import System.IO.Error
75 import System.Posix.Internals hiding (FD)
81 -- ---------------------------------------------------------------------------
82 -- Creating a new handle
84 type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
86 newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
87 newFileHandle filepath mb_finalizer hc = do
90 Just finalizer -> addMVarFinalizer m (finalizer filepath m)
92 return (FileHandle filepath m)
94 -- ---------------------------------------------------------------------------
95 -- Working with Handles
98 In the concurrent world, handles are locked during use. This is done
99 by wrapping an MVar around the handle which acts as a mutex over
100 operations on the handle.
102 To avoid races, we use the following bracketing operations. The idea
103 is to obtain the lock, do some operation and replace the lock again,
104 whether the operation succeeded or failed. We also want to handle the
105 case where the thread receives an exception while processing the IO
106 operation: in these cases we also want to relinquish the lock.
108 There are three versions of @withHandle@: corresponding to the three
109 possible combinations of:
111 - the operation may side-effect the handle
112 - the operation may return a result
114 If the operation generates an error or an exception is raised, the
115 original handle is always replaced.
118 {-# INLINE withHandle #-}
119 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
120 withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
121 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
123 withHandle' :: String -> Handle -> MVar Handle__
124 -> (Handle__ -> IO (Handle__,a)) -> IO a
125 withHandle' fun h m act =
128 checkHandleInvariants h_
129 (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
130 `catchException` \ex -> ioError (augmentIOError ex fun h)
131 checkHandleInvariants h'
135 {-# INLINE withHandle_ #-}
136 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
137 withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
138 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
140 withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
141 withHandle_' fun h m act =
144 checkHandleInvariants h_
145 v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
146 `catchException` \ex -> ioError (augmentIOError ex fun h)
147 checkHandleInvariants h_
151 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
152 withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
153 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
154 withHandle__' fun h r act
155 withHandle__' fun h w act
157 withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
159 withHandle__' fun h m act =
162 checkHandleInvariants h_
163 h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
164 `catchException` \ex -> ioError (augmentIOError ex fun h)
165 checkHandleInvariants h'
169 augmentIOError :: IOException -> String -> Handle -> IOException
170 augmentIOError ioe@IOError{ ioe_filename = fp } fun h
171 = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
174 | otherwise = case h of
175 FileHandle path _ -> Just path
176 DuplexHandle path _ _ -> Just path
178 -- ---------------------------------------------------------------------------
179 -- Wrapper for write operations.
181 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
182 wantWritableHandle fun h@(FileHandle _ m) act
183 = wantWritableHandle' fun h m act
184 wantWritableHandle fun h@(DuplexHandle _ _ m) act
185 = withHandle_' fun h m act
188 :: String -> Handle -> MVar Handle__
189 -> (Handle__ -> IO a) -> IO a
190 wantWritableHandle' fun h m act
191 = withHandle_' fun h m (checkWritableHandle act)
193 checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
194 checkWritableHandle act h_@Handle__{..}
196 ClosedHandle -> ioe_closedHandle
197 SemiClosedHandle -> ioe_closedHandle
198 ReadHandle -> ioe_notWritable
199 ReadWriteHandle -> do
200 buf <- readIORef haCharBuffer
201 when (not (isWriteBuffer buf)) $ do
202 flushCharReadBuffer h_
203 flushByteReadBuffer h_
204 buf <- readIORef haCharBuffer
205 writeIORef haCharBuffer buf{ bufState = WriteBuffer }
206 buf <- readIORef haByteBuffer
207 buf' <- Buffered.emptyWriteBuffer haDevice buf
208 writeIORef haByteBuffer buf'
212 -- ---------------------------------------------------------------------------
213 -- Wrapper for read operations.
215 wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
216 wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)
218 wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
219 wantReadableHandle_ fun h@(FileHandle _ m) act
220 = wantReadableHandle' fun h m act
221 wantReadableHandle_ fun h@(DuplexHandle _ m _) act
222 = withHandle_' fun h m act
225 :: String -> Handle -> MVar Handle__
226 -> (Handle__ -> IO a) -> IO a
227 wantReadableHandle' fun h m act
228 = withHandle_' fun h m (checkReadableHandle act)
230 checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
231 checkReadableHandle act h_@Handle__{..} =
233 ClosedHandle -> ioe_closedHandle
234 SemiClosedHandle -> ioe_closedHandle
235 AppendHandle -> ioe_notReadable
236 WriteHandle -> ioe_notReadable
237 ReadWriteHandle -> do
238 -- a read/write handle and we want to read from it. We must
239 -- flush all buffered write data first.
240 cbuf <- readIORef haCharBuffer
241 when (isWriteBuffer cbuf) $ do
242 cbuf' <- flushWriteBuffer_ h_ cbuf
243 writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
244 bbuf <- readIORef haByteBuffer
245 writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
249 -- ---------------------------------------------------------------------------
250 -- Wrapper for seek operations.
252 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
253 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
254 ioException (IOError (Just h) IllegalOperation fun
255 "handle is not seekable" Nothing Nothing)
256 wantSeekableHandle fun h@(FileHandle _ m) act =
257 withHandle_' fun h m (checkSeekableHandle act)
259 checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
260 checkSeekableHandle act handle_@Handle__{haDevice=dev} =
261 case haType handle_ of
262 ClosedHandle -> ioe_closedHandle
263 SemiClosedHandle -> ioe_closedHandle
264 AppendHandle -> ioe_notSeekable
265 _ -> do b <- IODevice.isSeekable dev
266 if b then act handle_
269 -- -----------------------------------------------------------------------------
272 ioe_closedHandle, ioe_EOF,
273 ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
274 ioe_notSeekable, ioe_invalidCharacter :: IO a
276 ioe_closedHandle = ioException
277 (IOError Nothing IllegalOperation ""
278 "handle is closed" Nothing Nothing)
279 ioe_EOF = ioException
280 (IOError Nothing EOF "" "" Nothing Nothing)
281 ioe_notReadable = ioException
282 (IOError Nothing IllegalOperation ""
283 "handle is not open for reading" Nothing Nothing)
284 ioe_notWritable = ioException
285 (IOError Nothing IllegalOperation ""
286 "handle is not open for writing" Nothing Nothing)
287 ioe_notSeekable = ioException
288 (IOError Nothing IllegalOperation ""
289 "handle is not seekable" Nothing Nothing)
290 ioe_cannotFlushNotSeekable = ioException
291 (IOError Nothing IllegalOperation ""
292 "cannot flush the read buffer: underlying device is not seekable"
294 ioe_invalidCharacter = ioException
295 (IOError Nothing InvalidArgument ""
296 ("invalid byte sequence for this encoding") Nothing Nothing)
298 ioe_finalizedHandle :: FilePath -> Handle__
299 ioe_finalizedHandle fp = throw
300 (IOError Nothing IllegalOperation ""
301 "handle is finalized" Nothing (Just fp))
303 ioe_bufsiz :: Int -> IO a
304 ioe_bufsiz n = ioException
305 (IOError Nothing InvalidArgument "hSetBuffering"
306 ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
307 -- 9 => should be parens'ified.
309 -- -----------------------------------------------------------------------------
312 -- For a duplex handle, we arrange that the read side points to the write side
313 -- (and hence keeps it alive if the read side is alive). This is done by
314 -- having the haOtherSide field of the read side point to the read side.
315 -- The finalizer is then placed on the write side, and the handle only gets
316 -- finalized once, when both sides are no longer required.
318 -- NOTE about finalized handles: It's possible that a handle can be
319 -- finalized and then we try to use it later, for example if the
320 -- handle is referenced from another finalizer, or from a thread that
321 -- has become unreferenced and then resurrected (arguably in the
322 -- latter case we shouldn't finalize the Handle...). Anyway,
323 -- we try to emit a helpful message which is better than nothing.
325 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
326 handleFinalizer fp m = do
327 handle_ <- takeMVar m
328 case haType handle_ of
329 ClosedHandle -> return ()
330 _ -> do flushWriteBuffer handle_ `catchAny` \_ -> return ()
331 -- ignore errors and async exceptions, and close the
332 -- descriptor anyway...
333 _ <- hClose_handle_ handle_
335 putMVar m (ioe_finalizedHandle fp)
337 -- ---------------------------------------------------------------------------
338 -- Allocating buffers
340 -- using an 8k char buffer instead of 32k improved performance for a
341 -- basic "cat" program by ~30% for me. --SDM
342 dEFAULT_CHAR_BUFFER_SIZE :: Int
343 dEFAULT_CHAR_BUFFER_SIZE = dEFAULT_BUFFER_SIZE `div` 4
345 getCharBuffer :: IODevice dev => dev -> BufferState
346 -> IO (IORef CharBuffer, BufferMode)
347 getCharBuffer dev state = do
348 buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
349 ioref <- newIORef buffer
350 is_tty <- IODevice.isTerminal dev
353 | is_tty = LineBuffering
354 | otherwise = BlockBuffering Nothing
356 return (ioref, buffer_mode)
358 mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
359 mkUnBuffer state = do
360 buffer <- case state of -- See [note Buffer Sizing], GHC.IO.Handle.Types
361 ReadBuffer -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
362 WriteBuffer -> newCharBuffer 1 state
363 ref <- newIORef buffer
364 return (ref, NoBuffering)
366 -- -----------------------------------------------------------------------------
369 -- | syncs the file with the buffer, including moving the
370 -- file pointer backwards in the case of a read buffer. This can fail
371 -- on a non-seekable read Handle.
372 flushBuffer :: Handle__ -> IO ()
373 flushBuffer h_@Handle__{..} = do
374 buf <- readIORef haCharBuffer
377 flushCharReadBuffer h_
378 flushByteReadBuffer h_
380 buf' <- flushWriteBuffer_ h_ buf
381 writeIORef haCharBuffer buf'
383 -- | flushes at least the Char buffer, and the byte buffer for a write
384 -- Handle. Works on all Handles.
385 flushCharBuffer :: Handle__ -> IO ()
386 flushCharBuffer h_@Handle__{..} = do
387 buf <- readIORef haCharBuffer
390 flushCharReadBuffer h_
392 buf' <- flushWriteBuffer_ h_ buf
393 writeIORef haCharBuffer buf'
395 -- -----------------------------------------------------------------------------
396 -- Writing data (flushing write buffers)
398 -- flushWriteBuffer flushes the buffer iff it contains pending write
399 -- data. Flushes both the Char and the byte buffer, leaving both
401 flushWriteBuffer :: Handle__ -> IO ()
402 flushWriteBuffer h_@Handle__{..} = do
403 buf <- readIORef haCharBuffer
405 then do buf' <- flushWriteBuffer_ h_ buf
406 writeIORef haCharBuffer buf'
409 flushWriteBuffer_ :: Handle__ -> CharBuffer -> IO CharBuffer
410 flushWriteBuffer_ h_@Handle__{..} cbuf = do
411 bbuf <- readIORef haByteBuffer
412 if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf)
413 then do writeTextDevice h_ cbuf
414 return cbuf{ bufL=0, bufR=0 }
417 -- -----------------------------------------------------------------------------
418 -- Flushing read buffers
420 -- It is always possible to flush the Char buffer back to the byte buffer.
421 flushCharReadBuffer :: Handle__ -> IO ()
422 flushCharReadBuffer Handle__{..} = do
423 cbuf <- readIORef haCharBuffer
424 if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do
426 -- haLastDecode is the byte buffer just before we did our last batch of
427 -- decoding. We're going to re-decode the bytes up to the current char,
428 -- to find out where we should revert the byte buffer to.
429 (codec_state, bbuf0) <- readIORef haLastDecode
431 cbuf0 <- readIORef haCharBuffer
432 writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
434 -- if we haven't used any characters from the char buffer, then just
435 -- re-install the old byte buffer.
437 then do writeIORef haByteBuffer bbuf0
443 writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
444 -- no decoder: the number of bytes to decode is the same as the
445 -- number of chars we have used up.
448 debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
449 " cbuf=" ++ summaryBuffer cbuf0)
451 -- restore the codec state
452 setState decoder codec_state
454 (bbuf1,cbuf1) <- (encode decoder) bbuf0
455 cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
457 debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
458 " cbuf=" ++ summaryBuffer cbuf1)
460 writeIORef haByteBuffer bbuf1
463 -- When flushing the byte read buffer, we seek backwards by the number
464 -- of characters in the buffer. The file descriptor must therefore be
465 -- seekable: attempting to flush the read buffer on an unseekable
466 -- handle is not allowed.
468 flushByteReadBuffer :: Handle__ -> IO ()
469 flushByteReadBuffer h_@Handle__{..} = do
470 bbuf <- readIORef haByteBuffer
472 if isEmptyBuffer bbuf then return () else do
474 seekable <- IODevice.isSeekable haDevice
475 when (not seekable) $ ioe_cannotFlushNotSeekable
477 let seek = negate (bufR bbuf - bufL bbuf)
479 debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
480 IODevice.seek haDevice RelativeSeek (fromIntegral seek)
482 writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }
484 -- ----------------------------------------------------------------------------
487 mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
491 -> Maybe TextEncoding
493 -> Maybe HandleFinalizer
494 -> Maybe (MVar Handle__)
497 mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
498 openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
500 let buf_state = initBufferState ha_type
501 bbuf <- Buffered.newBuffer dev buf_state
502 bbufref <- newIORef bbuf
503 last_decode <- newIORef (error "codec_state", bbuf)
506 if buffered then getCharBuffer dev buf_state
507 else mkUnBuffer buf_state
509 spares <- newIORef BufferListNil
510 newFileHandle filepath finalizer
511 (Handle__ { haDevice = dev,
513 haBufferMode = bmode,
514 haByteBuffer = bbufref,
515 haLastDecode = last_decode,
516 haCharBuffer = cbufref,
518 haEncoder = mb_encoder,
519 haDecoder = mb_decoder,
521 haInputNL = inputNL nl,
522 haOutputNL = outputNL nl,
523 haOtherSide = other_side
526 -- | makes a new 'Handle'
527 mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
528 => dev -- ^ the underlying IO device, which must support
529 -- 'IODevice', 'BufferedIO' and 'Typeable'
531 -- ^ a string describing the 'Handle', e.g. the file
532 -- path for a file. Used in error messages.
534 -- The mode in which the 'Handle' is to be used
535 -> Maybe TextEncoding
536 -- Create the 'Handle' with no text encoding?
538 -- Translate newlines?
540 mkFileHandle dev filepath iomode mb_codec tr_newlines = do
541 mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
543 (Just handleFinalizer) Nothing{-other_side-}
545 -- | like 'mkFileHandle', except that a 'Handle' is created with two
546 -- independent buffers, one for reading and one for writing. Used for
547 -- full-dupliex streams, such as network sockets.
548 mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
549 -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
550 mkDuplexHandle dev filepath mb_codec tr_newlines = do
552 write_side@(FileHandle _ write_m) <-
553 mkHandle dev filepath WriteHandle True mb_codec
555 (Just handleFinalizer)
556 Nothing -- no othersie
558 read_side@(FileHandle _ read_m) <-
559 mkHandle dev filepath ReadHandle True mb_codec
561 Nothing -- no finalizer
564 return (DuplexHandle filepath read_m write_m)
566 ioModeToHandleType :: IOMode -> HandleType
567 ioModeToHandleType ReadMode = ReadHandle
568 ioModeToHandleType WriteMode = WriteHandle
569 ioModeToHandleType ReadWriteMode = ReadWriteHandle
570 ioModeToHandleType AppendMode = AppendHandle
572 initBufferState :: HandleType -> BufferState
573 initBufferState ReadHandle = ReadBuffer
574 initBufferState _ = WriteBuffer
577 :: Maybe TextEncoding
579 -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
582 openTextEncoding Nothing ha_type cont = cont Nothing Nothing
583 openTextEncoding (Just TextEncoding{..}) ha_type cont = do
584 mb_decoder <- if isReadableHandleType ha_type then do
585 decoder <- mkTextDecoder
586 return (Just decoder)
589 mb_encoder <- if isWritableHandleType ha_type then do
590 encoder <- mkTextEncoder
591 return (Just encoder)
594 cont mb_encoder mb_decoder
596 -- ---------------------------------------------------------------------------
599 -- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
600 -- EOF is read or an IO error occurs on a lazy stream. The
601 -- semi-closed Handle is then closed immediately. We have to be
602 -- careful with DuplexHandles though: we have to leave the closing to
603 -- the finalizer in that case, because the write side may still be in
605 hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
606 hClose_help handle_ =
607 case haType handle_ of
608 ClosedHandle -> return (handle_,Nothing)
609 _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
610 -- it is important that hClose doesn't fail and
611 -- leave the Handle open (#3128), so we catch
612 -- exceptions when flushing the buffer.
613 (h_, mb_exc2) <- hClose_handle_ handle_
614 return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
617 trymaybe :: IO () -> IO (Maybe SomeException)
618 trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
620 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
621 hClose_handle_ Handle__{..} = do
623 -- close the file descriptor, but not when this is the read
624 -- side of a duplex handle.
625 -- If an exception is raised by the close(), we want to continue
626 -- to close the handle and release the lock if it has one, then
627 -- we return the exception to the caller of hClose_help which can
628 -- raise it if necessary.
631 Nothing -> trymaybe $ IODevice.close haDevice
632 Just _ -> return Nothing
634 -- free the spare buffers
635 writeIORef haBuffers BufferListNil
636 writeIORef haCharBuffer noCharBuffer
637 writeIORef haByteBuffer noByteBuffer
639 -- release our encoder/decoder
640 case haDecoder of Nothing -> return (); Just d -> close d
641 case haEncoder of Nothing -> return (); Just d -> close d
643 -- we must set the fd to -1, because the finalizer is going
644 -- to run eventually and try to close/unlock it.
645 -- ToDo: necessary? the handle will be marked ClosedHandle
646 -- XXX GHC won't let us use record update here, hence wildcards
647 return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
649 {-# NOINLINE noCharBuffer #-}
650 noCharBuffer :: CharBuffer
651 noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
653 {-# NOINLINE noByteBuffer #-}
654 noByteBuffer :: Buffer Word8
655 noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
657 -- ---------------------------------------------------------------------------
660 hLookAhead_ :: Handle__ -> IO Char
661 hLookAhead_ handle_@Handle__{..} = do
662 buf <- readIORef haCharBuffer
664 -- fill up the read buffer if necessary
665 new_buf <- if isEmptyBuffer buf
666 then readTextDevice handle_ buf
668 writeIORef haCharBuffer new_buf
670 peekCharBuf (bufRaw buf) (bufL buf)
672 -- ---------------------------------------------------------------------------
675 debugIO :: String -> IO ()
676 #if defined(DEBUG_DUMP)
678 withCStringLen (s++"\n") $ \(p,len) -> c_write 1 (castPtr p) (fromIntegral len)
681 debugIO s = return ()
684 -- ----------------------------------------------------------------------------
687 -- Write the contents of the supplied Char buffer to the device, return
688 -- only when all the data has been written.
689 writeTextDevice :: Handle__ -> CharBuffer -> IO ()
690 writeTextDevice h_@Handle__{..} cbuf = do
692 bbuf <- readIORef haByteBuffer
694 debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++
695 " bbuf=" ++ summaryBuffer bbuf)
697 (cbuf',bbuf') <- case haEncoder of
698 Nothing -> latin1_encode cbuf bbuf
699 Just encoder -> (encode encoder) cbuf bbuf
701 debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++
702 " bbuf=" ++ summaryBuffer bbuf')
704 bbuf' <- Buffered.flushWriteBuffer haDevice bbuf'
705 writeIORef haByteBuffer bbuf'
706 if not (isEmptyBuffer cbuf')
707 then writeTextDevice h_ cbuf'
710 -- Read characters into the provided buffer. Return when any
711 -- characters are available; raise an exception if the end of
713 readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
714 readTextDevice h_@Handle__{..} cbuf = do
716 bbuf0 <- readIORef haByteBuffer
718 debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
719 " bbuf=" ++ summaryBuffer bbuf0)
721 bbuf1 <- if not (isEmptyBuffer bbuf0)
724 (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
725 if r == 0 then ioe_EOF else do -- raise EOF
728 debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
733 writeIORef haLastDecode (error "codec_state", bbuf1)
734 latin1_decode bbuf1 cbuf
736 state <- getState decoder
737 writeIORef haLastDecode (state, bbuf1)
738 (encode decoder) bbuf1 cbuf
740 debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf2 ++
741 " bbuf=" ++ summaryBuffer bbuf2)
743 cbuf3 <- stripByteOrderMark cbuf2
745 writeIORef haByteBuffer bbuf2
746 if bufR cbuf3 == bufR cbuf -- no new characters
747 then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
751 -- we have an incomplete byte sequence at the end of the buffer: try to
753 readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
754 readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
756 -- copy the partial sequence to the beginning of the buffer, so we have
757 -- room to read more bytes.
758 bbuf1 <- slideContents bbuf0
760 bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
762 then ioe_invalidCharacter
765 debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2)
770 writeIORef haLastDecode (error "codec_state", bbuf2)
771 latin1_decode bbuf2 cbuf
773 state <- getState decoder
774 writeIORef haLastDecode (state, bbuf2)
775 (encode decoder) bbuf2 cbuf
777 debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
778 " bbuf=" ++ summaryBuffer bbuf3)
780 writeIORef haByteBuffer bbuf3
781 if bufR cbuf == bufR cbuf'
782 then readTextDevice' h_ bbuf3 cbuf'
785 -- Read characters into the provided buffer. Do not block;
786 -- return zero characters instead. Raises an exception on end-of-file.
787 readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
788 readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
790 bbuf0 <- readIORef haByteBuffer
791 bbuf1 <- if not (isEmptyBuffer bbuf0)
794 (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
795 if isNothing r then ioe_EOF else do -- raise EOF
801 writeIORef haLastDecode (error "codec_state", bbuf1)
802 latin1_decode bbuf1 cbuf
804 state <- getState decoder
805 writeIORef haLastDecode (state, bbuf1)
806 (encode decoder) bbuf1 cbuf
808 cbuf3 <- stripByteOrderMark cbuf2
810 writeIORef haByteBuffer bbuf2
814 -- | When converting from UTF-8 to UCS-4, Solaris iconv adds a Byte Order Mark (BOM)
815 -- of value 0xfeff to the start of the stream. We don't want to return this to
816 -- the caller, so strip it here. This is a safe operation for other platforms,
818 stripByteOrderMark :: CharBuffer -> IO CharBuffer
819 stripByteOrderMark cbuf
824 = do firstChar <- peekCharBuf (bufRaw cbuf) 0
825 if firstChar == chr 0xfeff
826 then return (bufferRemove 1 cbuf)