X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FHandle%2FInternals.hs;h=a2b644f51493dea1141eb25531ea54b724cc2ed0;hb=509f28cc93b980d30aca37008cbe66c677a0d6f6;hp=ed32eaa2b32cc5fad0d7902eae653a275b73d5f0;hpb=ccc931d0905f6e0d55cb90b045881d4515112411;p=ghc-base.git diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs index ed32eaa..a2b644f 100644 --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -1,12 +1,14 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , BangPatterns + , PatternGuards + , NondecreasingIndentation + , Rank2Types + #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -XRecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} -#undef DEBUG_DUMP - ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Handle.Internals @@ -31,13 +33,14 @@ module GHC.IO.Handle.Internals ( wantSeekableHandle, mkHandle, mkFileHandle, mkDuplexHandle, - openTextEncoding, initBufferState, + openTextEncoding, closeTextCodecs, initBufferState, dEFAULT_CHAR_BUFFER_SIZE, - flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer, - flushCharBuffer, flushByteReadBuffer, + flushBuffer, flushWriteBuffer, flushCharReadBuffer, + flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer, - readTextDevice, writeTextDevice, readTextDeviceNonBlocking, + readTextDevice, writeCharBuffer, readTextDeviceNonBlocking, + decodeByteBuf, augmentIOError, ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, @@ -52,7 +55,7 @@ module GHC.IO.Handle.Internals ( import GHC.IO import GHC.IO.IOMode -import GHC.IO.Encoding +import GHC.IO.Encoding as Encoding import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO (BufferedIO) @@ -61,9 +64,9 @@ import GHC.IO.Device (IODevice, SeekMode(..)) import qualified GHC.IO.Device as IODevice import qualified GHC.IO.BufferedIO as Buffered +import GHC.Conc.Sync import GHC.Real import GHC.Base -import GHC.List import GHC.Exception import GHC.Num ( Num(..) ) import GHC.Show @@ -72,14 +75,14 @@ import GHC.MVar import Data.Typeable import Control.Monad import Data.Maybe -import Foreign -import System.IO.Error +import Foreign hiding (unsafePerformIO) +-- import System.IO.Error import System.Posix.Internals hiding (FD) -import qualified System.Posix.Internals as Posix -#ifdef DEBUG_DUMP import Foreign.C -#endif + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False -- --------------------------------------------------------------------------- -- Creating a new handle @@ -126,11 +129,8 @@ withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act withHandle' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO (Handle__,a)) -> IO a withHandle' fun h m act = - block $ do - h_ <- takeMVar m - checkHandleInvariants h_ - (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) + mask_ $ do + (h',v) <- do_operation fun h act m checkHandleInvariants h' putMVar m h' return v @@ -141,15 +141,9 @@ withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkHandleInvariants h_ - v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkHandleInvariants h_ - putMVar m h_ - return v +withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do + a <- act h_ + return (h_,a) withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act @@ -160,15 +154,62 @@ withAllHandles__ fun h@(DuplexHandle _ r w) act = do withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO () withHandle__' fun h m act = - block $ do - h_ <- takeMVar m - checkHandleInvariants h_ - h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) + mask_ $ do + h' <- do_operation fun h act m checkHandleInvariants h' putMVar m h' return () +do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a +do_operation fun h act m = do + h_ <- takeMVar m + checkHandleInvariants h_ + act h_ `catchException` handler h_ + where + handler h_ e = do + putMVar m h_ + case () of + _ | Just ioe <- fromException e -> + ioError (augmentIOError ioe fun h) + _ | Just async_ex <- fromException e -> do -- see Note [async] + let _ = async_ex :: AsyncException + t <- myThreadId + throwTo t e + do_operation fun h act m + _otherwise -> + throwIO e + +-- Note [async] +-- +-- If an asynchronous exception is raised during an I/O operation, +-- normally it is fine to just re-throw the exception synchronously. +-- However, if we are inside an unsafePerformIO or an +-- unsafeInterleaveIO, this would replace the enclosing thunk with the +-- exception raised, which is wrong (#3997). We have to release the +-- lock on the Handle, but what do we replace the thunk with? What +-- should happen when the thunk is subsequently demanded again? +-- +-- The only sensible choice we have is to re-do the IO operation on +-- resumption, but then we have to be careful in the IO library that +-- this is always safe to do. In particular we should +-- +-- never perform any side-effects before an interruptible operation +-- +-- because the interruptible operation may raise an asynchronous +-- exception, which may cause the operation and its side effects to be +-- subsequently performed again. +-- +-- Re-doing the IO operation is achieved by: +-- - using throwTo to re-throw the asynchronous exception asynchronously +-- in the current thread +-- - on resumption, it will be as if throwTo returns. In that case, we +-- recursively invoke the original operation (see do_operation above). +-- +-- Interruptible operations in the I/O library are: +-- - threadWaitRead/threadWaitWrite +-- - fillReadBuffer/flushWriteBuffer +-- - readTextDevice/writeTextDevice + augmentIOError :: IOException -> String -> Handle -> IOException augmentIOError ioe@IOError{ ioe_filename = fp } fun h = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath } @@ -185,7 +226,9 @@ wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantWritableHandle fun h@(FileHandle _ m) act = wantWritableHandle' fun h m act wantWritableHandle fun h@(DuplexHandle _ _ m) act - = withHandle_' fun h m act + = wantWritableHandle' fun h m act + -- we know it's not a ReadHandle or ReadWriteHandle, but we have to + -- check for ClosedHandle/SemiClosedHandle. (#4808) wantWritableHandle' :: String -> Handle -> MVar Handle__ @@ -207,7 +250,8 @@ checkWritableHandle act h_@Handle__{..} buf <- readIORef haCharBuffer writeIORef haCharBuffer buf{ bufState = WriteBuffer } buf <- readIORef haByteBuffer - writeIORef haByteBuffer buf{ bufState = WriteBuffer } + buf' <- Buffered.emptyWriteBuffer haDevice buf + writeIORef haByteBuffer buf' act h_ _other -> act h_ @@ -221,7 +265,9 @@ wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a wantReadableHandle_ fun h@(FileHandle _ m) act = wantReadableHandle' fun h m act wantReadableHandle_ fun h@(DuplexHandle _ m _) act - = withHandle_' fun h m act + = wantReadableHandle' fun h m act + -- we know it's not a WriteHandle or ReadWriteHandle, but we have to + -- check for ClosedHandle/SemiClosedHandle. (#4808) wantReadableHandle' :: String -> Handle -> MVar Handle__ @@ -239,9 +285,10 @@ checkReadableHandle act h_@Handle__{..} = ReadWriteHandle -> do -- a read/write handle and we want to read from it. We must -- flush all buffered write data first. - cbuf <- readIORef haCharBuffer - when (isWriteBuffer cbuf) $ do - cbuf' <- flushWriteBuffer_ h_ cbuf + bbuf <- readIORef haByteBuffer + when (isWriteBuffer bbuf) $ do + when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_ + cbuf' <- readIORef haCharBuffer writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer } bbuf <- readIORef haByteBuffer writeIORef haByteBuffer bbuf{ bufState = ReadBuffer } @@ -272,8 +319,8 @@ checkSeekableHandle act handle_@Handle__{haDevice=dev} = -- Handy IOErrors ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, ioe_cannotFlushTextRead, - ioe_notSeekable, ioe_notSeekable_notBin, ioe_invalidCharacter :: IO a + ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable, + ioe_notSeekable, ioe_invalidCharacter :: IO a ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" @@ -289,13 +336,9 @@ ioe_notWritable = ioException ioe_notSeekable = ioException (IOError Nothing IllegalOperation "" "handle is not seekable" Nothing Nothing) -ioe_notSeekable_notBin = ioException +ioe_cannotFlushNotSeekable = ioException (IOError Nothing IllegalOperation "" - "seek operations on text-mode handles are not allowed on this platform" - Nothing Nothing) -ioe_cannotFlushTextRead = ioException - (IOError Nothing IllegalOperation "" - "cannot flush the read buffer of a text-mode handle" + "cannot flush the read buffer: underlying device is not seekable" Nothing Nothing) ioe_invalidCharacter = ioException (IOError Nothing InvalidArgument "" @@ -312,6 +355,38 @@ ioe_bufsiz n = ioException ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) -- 9 => should be parens'ified. +-- --------------------------------------------------------------------------- +-- Wrapper for Handle encoding/decoding. + +-- The interface for TextEncoding changed so that a TextEncoding doesn't raise +-- an exception if it encounters an invalid sequnce. Furthermore, encoding +-- returns a reason as to why encoding stopped, letting us know if it was due +-- to input/output underflow or an invalid sequence. +-- +-- This code adapts this elaborated interface back to the original TextEncoding +-- interface. +-- +-- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields +-- could be made clearer by using the 'encode' interface directly. I have not +-- looked into this. +-- +-- FIXME: we should use recover to deal with EOF, rather than always throwing an +-- IOException (ioe_invalidCharacter). + +streamEncode :: BufferCodec from to state + -> Buffer from -> Buffer to + -> IO (Buffer from, Buffer to) +streamEncode codec from to = go (from, to) + where + go (from, to) = do + (why, from', to') <- encode codec from to + -- When we are dealing with Handles, we don't care about input/output + -- underflow particularly, and we want to delay errors about invalid + -- sequences as far as possible. + case why of + Encoding.InvalidSequence | bufL from == bufL from' -> recover codec from' to' >>= go + _ -> return (from', to') + -- ----------------------------------------------------------------------------- -- Handle Finalizers @@ -327,18 +402,25 @@ ioe_bufsiz n = ioException -- has become unreferenced and then resurrected (arguably in the -- latter case we shouldn't finalize the Handle...). Anyway, -- we try to emit a helpful message which is better than nothing. +-- +-- [later; 8/2010] However, a program like this can yield a strange +-- error message: +-- +-- main = writeFile "out" loop +-- loop = let x = x in x +-- +-- because the main thread and the Handle are both unreachable at the +-- same time, the Handle may get finalized before the main thread +-- receives the NonTermination exception, and the exception handler +-- will then report an error. We'd rather this was not an error and +-- the program just prints "<>". handleFinalizer :: FilePath -> MVar Handle__ -> IO () handleFinalizer fp m = do handle_ <- takeMVar m - case haType handle_ of - ClosedHandle -> return () - _ -> do flushWriteBuffer handle_ `catchAny` \_ -> return () - -- ignore errors and async exceptions, and close the - -- descriptor anyway... - hClose_handle_ handle_ - return () - putMVar m (ioe_finalizedHandle fp) + (handle_', _) <- hClose_help handle_ + putMVar m handle_' + return () -- --------------------------------------------------------------------------- -- Allocating buffers @@ -346,7 +428,7 @@ handleFinalizer fp m = do -- using an 8k char buffer instead of 32k improved performance for a -- basic "cat" program by ~30% for me. --SDM dEFAULT_CHAR_BUFFER_SIZE :: Int -dEFAULT_CHAR_BUFFER_SIZE = dEFAULT_BUFFER_SIZE `div` 4 +dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar) getCharBuffer :: IODevice dev => dev -> BufferState -> IO (IORef CharBuffer, BufferMode) @@ -363,9 +445,8 @@ getCharBuffer dev state = do mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode) mkUnBuffer state = do - buffer <- case state of -- See [note Buffer Sizing], GHC.IO.Handle.Types - ReadBuffer -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state - WriteBuffer -> newCharBuffer 1 state + buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + -- See [note Buffer Sizing], GHC.IO.Handle.Types ref <- newIORef buffer return (ref, NoBuffering) @@ -383,20 +464,18 @@ flushBuffer h_@Handle__{..} = do flushCharReadBuffer h_ flushByteReadBuffer h_ WriteBuffer -> do - buf' <- flushWriteBuffer_ h_ buf - writeIORef haCharBuffer buf' + flushByteWriteBuffer h_ --- | flushes at least the Char buffer, and the byte buffer for a write --- Handle. Works on all Handles. +-- | flushes the Char buffer only. Works on all Handles. flushCharBuffer :: Handle__ -> IO () flushCharBuffer h_@Handle__{..} = do - buf <- readIORef haCharBuffer - case bufState buf of + cbuf <- readIORef haCharBuffer + case bufState cbuf of ReadBuffer -> do flushCharReadBuffer h_ - WriteBuffer -> do - buf' <- flushWriteBuffer_ h_ buf - writeIORef haCharBuffer buf' + WriteBuffer -> + when (not (isEmptyBuffer cbuf)) $ + error "internal IO library error: Char buffer non-empty" -- ----------------------------------------------------------------------------- -- Writing data (flushing write buffers) @@ -406,19 +485,52 @@ flushCharBuffer h_@Handle__{..} = do -- empty. flushWriteBuffer :: Handle__ -> IO () flushWriteBuffer h_@Handle__{..} = do - buf <- readIORef haCharBuffer - if isWriteBuffer buf - then do buf' <- flushWriteBuffer_ h_ buf - writeIORef haCharBuffer buf' - else return () + buf <- readIORef haByteBuffer + when (isWriteBuffer buf) $ flushByteWriteBuffer h_ -flushWriteBuffer_ :: Handle__ -> CharBuffer -> IO CharBuffer -flushWriteBuffer_ h_@Handle__{..} cbuf = do +flushByteWriteBuffer :: Handle__ -> IO () +flushByteWriteBuffer h_@Handle__{..} = do bbuf <- readIORef haByteBuffer - if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf) - then do writeTextDevice h_ cbuf - return cbuf{ bufL=0, bufR=0 } - else return cbuf + when (not (isEmptyBuffer bbuf)) $ do + bbuf' <- Buffered.flushWriteBuffer haDevice bbuf + writeIORef haByteBuffer bbuf' + +-- write the contents of the CharBuffer to the Handle__. +-- The data will be encoded and pushed to the byte buffer, +-- flushing if the buffer becomes full. +writeCharBuffer :: Handle__ -> CharBuffer -> IO () +writeCharBuffer h_@Handle__{..} !cbuf = do + -- + bbuf <- readIORef haByteBuffer + + debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++ + " bbuf=" ++ summaryBuffer bbuf) + + (cbuf',bbuf') <- case haEncoder of + Nothing -> latin1_encode cbuf bbuf + Just encoder -> (streamEncode encoder) cbuf bbuf + + debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf') + + -- flush if the write buffer is full + if isFullBuffer bbuf' + -- or we made no progress + || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf + -- or the byte buffer has more elements than the user wanted buffered + || (case haBufferMode of + BlockBuffering (Just s) -> bufferElems bbuf' >= s + NoBuffering -> True + _other -> False) + then do + bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf' + writeIORef haByteBuffer bbuf'' + else + writeIORef haByteBuffer bbuf' + + if not (isEmptyBuffer cbuf') + then writeCharBuffer h_ cbuf' + else return () -- ----------------------------------------------------------------------------- -- Flushing read buffers @@ -457,7 +569,7 @@ flushCharReadBuffer Handle__{..} = do -- restore the codec state setState decoder codec_state - (bbuf1,cbuf1) <- (encode decoder) bbuf0 + (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0 cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 } debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++ @@ -478,7 +590,7 @@ flushByteReadBuffer h_@Handle__{..} = do if isEmptyBuffer bbuf then return () else do seekable <- IODevice.isSeekable haDevice - when (not seekable) $ ioe_cannotFlushTextRead + when (not seekable) $ ioe_cannotFlushNotSeekable let seek = negate (bufR bbuf - bufL bbuf) @@ -523,6 +635,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do haBuffers = spares, haEncoder = mb_encoder, haDecoder = mb_decoder, + haCodec = mb_codec, haInputNL = inputNL nl, haOutputNL = outputNL nl, haOtherSide = other_side @@ -549,7 +662,7 @@ mkFileHandle dev filepath iomode mb_codec tr_newlines = do -- | like 'mkFileHandle', except that a 'Handle' is created with two -- independent buffers, one for reading and one for writing. Used for --- full-dupliex streams, such as network sockets. +-- full-duplex streams, such as network sockets. mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle mkDuplexHandle dev filepath mb_codec tr_newlines = do @@ -598,6 +711,11 @@ openTextEncoding (Just TextEncoding{..}) ha_type cont = do return Nothing cont mb_encoder mb_decoder +closeTextCodecs :: Handle__ -> IO () +closeTextCodecs Handle__{..} = do + case haDecoder of Nothing -> return (); Just d -> Encoding.close d + case haEncoder of Nothing -> return (); Just d -> Encoding.close d + -- --------------------------------------------------------------------------- -- closing Handles @@ -623,7 +741,7 @@ trymaybe :: IO () -> IO (Maybe SomeException) trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e) hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) -hClose_handle_ Handle__{..} = do +hClose_handle_ h_@Handle__{..} = do -- close the file descriptor, but not when this is the read -- side of a duplex handle. @@ -642,8 +760,7 @@ hClose_handle_ Handle__{..} = do writeIORef haByteBuffer noByteBuffer -- release our encoder/decoder - case haDecoder of Nothing -> return (); Just d -> close d - case haEncoder of Nothing -> return (); Just d -> close d + closeTextCodecs h_ -- we must set the fd to -1, because the finalizer is going -- to run eventually and try to close/unlock it. @@ -678,40 +795,16 @@ hLookAhead_ handle_@Handle__{..} = do -- debugging debugIO :: String -> IO () -#if defined(DEBUG_DUMP) -debugIO s = do - withCStringLen (s++"\n") $ \(p,len) -> c_write 1 p (fromIntegral len) - return () -#else -debugIO s = return () -#endif +debugIO s + | c_DEBUG_DUMP + = do _ <- withCStringLen (s ++ "\n") $ + \(p, len) -> c_write 1 (castPtr p) (fromIntegral len) + return () + | otherwise = return () -- ---------------------------------------------------------------------------- -- Text input/output --- Write the contents of the supplied Char buffer to the device, return --- only when all the data has been written. -writeTextDevice :: Handle__ -> CharBuffer -> IO () -writeTextDevice h_@Handle__{..} cbuf = do - -- - bbuf <- readIORef haByteBuffer - - debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++ - " bbuf=" ++ summaryBuffer bbuf) - - (cbuf',bbuf') <- case haEncoder of - Nothing -> latin1_encode cbuf bbuf - Just encoder -> (encode encoder) cbuf bbuf - - debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++ - " bbuf=" ++ summaryBuffer bbuf') - - Buffered.flushWriteBuffer haDevice bbuf' - writeIORef haByteBuffer bbuf{bufL=0,bufR=0} - if not (isEmptyBuffer cbuf') - then writeTextDevice h_ cbuf' - else return () - -- Read characters into the provided buffer. Return when any -- characters are available; raise an exception if the end of -- file is reached. @@ -740,7 +833,7 @@ readTextDevice h_@Handle__{..} cbuf = do Just decoder -> do state <- getState decoder writeIORef haLastDecode (state, bbuf1) - (encode decoder) bbuf1 cbuf + (streamEncode decoder) bbuf1 cbuf debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ " bbuf=" ++ summaryBuffer bbuf2) @@ -764,7 +857,7 @@ readTextDevice' h_@Handle__{..} bbuf0 cbuf = do then ioe_invalidCharacter else return bbuf2 - debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2) + debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2) (bbuf3,cbuf') <- case haDecoder of @@ -774,9 +867,9 @@ readTextDevice' h_@Handle__{..} bbuf0 cbuf = do Just decoder -> do state <- getState decoder writeIORef haLastDecode (state, bbuf2) - (encode decoder) bbuf2 cbuf + (streamEncode decoder) bbuf2 cbuf - debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ + debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++ " bbuf=" ++ summaryBuffer bbuf3) writeIORef haByteBuffer bbuf3 @@ -790,16 +883,28 @@ readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer readTextDeviceNonBlocking h_@Handle__{..} cbuf = do -- bbuf0 <- readIORef haByteBuffer - bbuf1 <- if not (isEmptyBuffer bbuf0) - then return bbuf0 - else do - (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0 - if r == 0 then ioe_EOF else do -- raise EOF - return bbuf1 + when (isEmptyBuffer bbuf0) $ do + (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0 + if isNothing r then ioe_EOF else do -- raise EOF + writeIORef haByteBuffer bbuf1 + + decodeByteBuf h_ cbuf + +-- Decode bytes from the byte buffer into the supplied CharBuffer. +decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer +decodeByteBuf h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer - (bbuf2,cbuf') <- case haDecoder of - Nothing -> latin1_decode bbuf1 cbuf - Just decoder -> (encode decoder) bbuf1 cbuf + (bbuf2,cbuf') <- + case haDecoder of + Nothing -> do + writeIORef haLastDecode (error "codec_state", bbuf0) + latin1_decode bbuf0 cbuf + Just decoder -> do + state <- getState decoder + writeIORef haLastDecode (state, bbuf0) + (streamEncode decoder) bbuf0 cbuf writeIORef haByteBuffer bbuf2 return cbuf'