X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=6255a79a16db90dcd902d7755c0f1936093faf7d;hb=37ab854f9d2c1280117658bbd29919968f4f4585;hp=c33ddab62871a1bf5c3fecf257c04e85f6bc3e4c;hpb=8e9892cd14b7558649fcd9ba0597805eb57505b3;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index c33ddab..6255a79 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_HADDOCK hide #-} #undef DEBUG_DUMP @@ -38,7 +40,7 @@ module GHC.Handle ( stdin, stdout, stderr, IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle', - hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, + hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode, hFlush, hDuplicate, hDuplicateTo, hClose, hClose_help, @@ -58,7 +60,6 @@ module GHC.Handle ( ) where import Control.Monad -import Data.Bits import Data.Maybe import Foreign import Foreign.C @@ -75,9 +76,8 @@ import GHC.List import GHC.IOBase import GHC.Exception import GHC.Enum -import GHC.Num ( Integer(..), Num(..) ) +import GHC.Num ( Integer, Num(..) ) import GHC.Show -import GHC.Real ( toInteger ) #if defined(DEBUG_DUMP) import GHC.Pack #endif @@ -98,7 +98,8 @@ import GHC.Conc -- Are files opened by default in text or binary mode, if the user doesn't -- specify? -dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool +dEFAULT_OPEN_IN_BINARY_MODE :: Bool +dEFAULT_OPEN_IN_BINARY_MODE = False -- --------------------------------------------------------------------------- -- Creating a new handle @@ -173,6 +174,8 @@ withAllHandles__ fun h@(DuplexHandle _ r w) act = do withHandle__' fun h r act withHandle__' fun h w act +withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) + -> IO () withHandle__' fun h m act = block $ do h_ <- takeMVar m @@ -183,13 +186,14 @@ withHandle__' fun h m act = putMVar m h' return () -augmentIOError (IOError _ iot _ str fp) fun h - = IOError (Just h) iot fun str filepath +augmentIOError :: IOException -> String -> Handle -> IOException +augmentIOError ioe@IOError{ ioe_filename = fp } fun h + = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath } where filepath | Just _ <- fp = fp | otherwise = case h of - FileHandle fp _ -> Just fp - DuplexHandle fp _ _ -> Just fp + FileHandle path _ -> Just path + DuplexHandle path _ _ -> Just path -- --------------------------------------------------------------------------- -- Wrapper for write operations. @@ -207,6 +211,7 @@ wantWritableHandle' wantWritableHandle' fun h m act = withHandle_' fun h m (checkWritableHandle act) +checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a checkWritableHandle act handle_ = case haType handle_ of ClosedHandle -> ioe_closedHandle @@ -240,6 +245,7 @@ wantReadableHandle' wantReadableHandle' fun h m act = withHandle_' fun h m (checkReadableHandle act) +checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a checkReadableHandle act handle_ = case haType handle_ of ClosedHandle -> ioe_closedHandle @@ -261,10 +267,11 @@ checkReadableHandle act handle_ = wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing) + "handle is not seekable" Nothing Nothing) wantSeekableHandle fun h@(FileHandle _ m) act = withHandle_' fun h m (checkSeekableHandle act) +checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a checkSeekableHandle act handle_ = case haType handle_ of ClosedHandle -> ioe_closedHandle @@ -282,31 +289,32 @@ ioe_closedHandle, ioe_EOF, ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" - "handle is closed" Nothing) + "handle is closed" Nothing Nothing) ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing) + (IOError Nothing EOF "" "" Nothing Nothing) ioe_notReadable = ioException (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing) + "handle is not open for reading" Nothing Nothing) ioe_notWritable = ioException (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing) + "handle is not open for writing" Nothing Nothing) ioe_notSeekable = ioException (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing) + "handle is not seekable" Nothing Nothing) ioe_notSeekable_notBin = ioException (IOError Nothing IllegalOperation "" "seek operations on text-mode handles are not allowed on this platform" - Nothing) + Nothing Nothing) +ioe_finalizedHandle :: FilePath -> Handle__ ioe_finalizedHandle fp = throw (IOError Nothing IllegalOperation "" - "handle is finalized" (Just fp)) + "handle is finalized" Nothing (Just fp)) ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException (IOError Nothing InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing) + ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) -- 9 => should be parens'ified. -- ----------------------------------------------------------------------------- @@ -346,6 +354,7 @@ handleFinalizer fp m = do -- --------------------------------------------------------------------------- -- Grimy buffer operations +checkBufferInvariants :: Handle__ -> IO () #ifdef DEBUG checkBufferInvariants h_ = do let ref = haBuffer h_ @@ -361,7 +370,7 @@ checkBufferInvariants h_ = do then error "buffer invariant violation" else return () #else -checkBufferInvariants h_ = return () +checkBufferInvariants _ = return () #endif newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer @@ -372,18 +381,18 @@ allocateBuffer :: Int -> BufferState -> IO Buffer allocateBuffer sz@(I# size) state = IO $ \s -> -- We sometimes need to pass the address of this buffer to -- a "safe" foreign call, hence it must be immovable. - case newPinnedByteArray# size s of { (# s, b #) -> - (# s, newEmptyBuffer b state sz #) } + case newPinnedByteArray# size s of { (# s', b #) -> + (# s', newEmptyBuffer b state sz #) } writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int writeCharIntoBuffer slab (I# off) (C# c) = IO $ \s -> case writeCharArray# slab off c s of - s -> (# s, I# (off +# 1#) #) + s' -> (# s', I# (off +# 1#) #) readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int) readCharFromBuffer slab (I# off) = IO $ \s -> case readCharArray# slab off s of - (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #) + (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #) getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) getBuffer fd state = do @@ -474,6 +483,8 @@ fillReadBuffer fd is_line is_stream -- appears to be what GHC has done for a long time, and I suspect it -- is more useful than line buffering in most cases. +fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int + -> IO Buffer fillReadBufferLoop fd is_line is_stream buf b w size = do let bytes = size - w if bytes == 0 -- buffer full? @@ -676,6 +687,8 @@ readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> I readRawBufferPtrNoBlock = readRawBufferPtr -- Async versions of the read/write primitives, for the non-threaded RTS +asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt + -> IO CInt asyncReadRawBuffer loc fd is_stream buf off len = do (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) off buf @@ -684,6 +697,8 @@ asyncReadRawBuffer loc fd is_stream buf off len = do ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) else return (fromIntegral l) +asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt + -> IO CInt asyncReadRawBufferPtr loc fd is_stream buf off len = do (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) @@ -692,6 +707,8 @@ asyncReadRawBufferPtr loc fd is_stream buf off len = do ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) else return (fromIntegral l) +asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt + -> IO CInt asyncWriteRawBuffer loc fd is_stream buf off len = do (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) off buf @@ -700,6 +717,8 @@ asyncWriteRawBuffer loc fd is_stream buf off len = do ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) else return (fromIntegral l) +asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt + -> IO CInt asyncWriteRawBufferPtr loc fd is_stream buf off len = do (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) @@ -710,6 +729,8 @@ asyncWriteRawBufferPtr loc fd is_stream buf off len = do -- Blocking versions of the read/write primitives, for the threaded RTS +blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt + -> IO CInt blockingReadRawBuffer loc fd True buf off len = throwErrnoIfMinus1Retry loc $ safe_recv_rawBuffer fd buf off len @@ -717,6 +738,8 @@ blockingReadRawBuffer loc fd False buf off len = throwErrnoIfMinus1Retry loc $ safe_read_rawBuffer fd buf off len +blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt + -> IO CInt blockingReadRawBufferPtr loc fd True buf off len = throwErrnoIfMinus1Retry loc $ safe_recv_off fd buf off len @@ -724,6 +747,8 @@ blockingReadRawBufferPtr loc fd False buf off len = throwErrnoIfMinus1Retry loc $ safe_read_off fd buf off len +blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt + -> IO CInt blockingWriteRawBuffer loc fd True buf off len = throwErrnoIfMinus1Retry loc $ safe_send_rawBuffer fd buf off len @@ -731,6 +756,8 @@ blockingWriteRawBuffer loc fd False buf off len = throwErrnoIfMinus1Retry loc $ safe_write_rawBuffer fd buf off len +blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt + -> IO CInt blockingWriteRawBufferPtr loc fd True buf off len = throwErrnoIfMinus1Retry loc $ safe_send_off fd buf off len @@ -777,9 +804,10 @@ foreign import ccall safe "__hscore_PrelHandle_write" -- or output channel respectively. The third manages output to the -- standard error channel. These handles are initially open. -fd_stdin = 0 :: FD -fd_stdout = 1 :: FD -fd_stderr = 2 :: FD +fd_stdin, fd_stdout, fd_stderr :: FD +fd_stdin = 0 +fd_stdout = 1 +fd_stderr = 2 -- | A handle managing input from the Haskell program's standard input channel. stdin :: Handle @@ -814,8 +842,9 @@ stderr = unsafePerformIO $ do -- --------------------------------------------------------------------------- -- Opening and Closing Files -addFilePathToIOError fun fp (IOError h iot _ str _) - = IOError h iot fun str (Just fp) +addFilePathToIOError :: String -> FilePath -> IOException -> IOException +addFilePathToIOError fun fp ioe + = ioe{ ioe_location = fun, ioe_filename = Just fp } -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ @@ -864,6 +893,7 @@ openBinaryFile fp m = (openFile' fp m True) (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) +openFile' :: String -> IOMode -> Bool -> IO Handle openFile' filepath mode binary = withCString filepath $ \ f -> @@ -915,6 +945,8 @@ openFile' filepath mode binary = return h +std_flags, output_flags, read_flags, write_flags, rw_flags, + append_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY @@ -962,7 +994,7 @@ fdToHandle_stat fd mb_stat is_socket filepath mode binary = do case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing) + "is a directory" Nothing Nothing) -- regular files need to be locked RegularFile -> do @@ -973,7 +1005,7 @@ fdToHandle_stat fd mb_stat is_socket filepath mode binary = do r <- lockFile fd dev ino (fromBool write) when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" - "file is locked" Nothing) + "file is locked" Nothing Nothing) #endif mkFileHandle fd is_socket filepath ha_type binary @@ -1042,9 +1074,11 @@ mkFileHandle fd is_stream filepath ha_type binary = do -- turn off buffering. We don't correctly handle the case of switching -- from read mode to write mode on a buffered text-mode handle, see bug -- \#679. - bmode <- case ha_type of - ReadWriteHandle | not binary -> return NoBuffering - _other -> return bmode + bmode2 <- case ha_type of + ReadWriteHandle | not binary -> return NoBuffering + _other -> return bmode +#else + let bmode2 = bmode #endif spares <- newIORef BufferListNil @@ -1053,7 +1087,7 @@ mkFileHandle fd is_stream filepath ha_type binary = do haType = ha_type, haIsBin = binary, haIsStream = is_stream, - haBufferMode = bmode, + haBufferMode = bmode2, haBuffer = buf, haBuffers = spares, haOtherSide = Nothing @@ -1092,7 +1126,7 @@ mkDuplexHandle fd is_stream filepath binary = do addMVarFinalizer write_side (handleFinalizer filepath write_side) return (DuplexHandle filepath read_side write_side) - +initBufferState :: HandleType -> BufferState initBufferState ReadHandle = ReadBuffer initBufferState _ = WriteBuffer @@ -1121,6 +1155,7 @@ hClose h@(DuplexHandle _ r w) = do Nothing -> return () Just e -> throwIO e +hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read @@ -1177,6 +1212,7 @@ hClose_handle_ handle_ = do maybe_exception) {-# NOINLINE noBuffer #-} +noBuffer :: Buffer noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer ----------------------------------------------------------------------------- @@ -1196,7 +1232,7 @@ hFileSize handle = if r /= -1 then return r else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing) + "not a regular file" Nothing Nothing) -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. @@ -1247,18 +1283,20 @@ isEOF = hIsEOF stdin -- * 'isEOFError' if the end of file has been reached. hLookAhead :: Handle -> IO Char -hLookAhead handle = do - wantReadableHandle "hLookAhead" handle $ \handle_ -> do +hLookAhead handle = + wantReadableHandle "hLookAhead" handle hLookAhead' + +hLookAhead' :: Handle__ -> IO Char +hLookAhead' handle_ = do let ref = haBuffer handle_ fd = haFD handle_ - is_line = haBufferMode handle_ == LineBuffering buf <- readIORef ref -- fill up the read buffer if necessary new_buf <- if bufferEmpty buf then fillReadBuffer fd True (haIsStream handle_) buf else return buf - + writeIORef ref new_buf (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf) @@ -1659,6 +1697,8 @@ dupHandle h other_side h_ = do Just r -> withHandle_' "dupHandle" h r (return . haFD) dupHandle_ other_side h_ new_fd +dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__ + -> IO (Handle__, Handle__) dupHandleTo other_side hto_ h_ = do flushBuffer h_ -- Windows' dup2 does not return the new descriptor, unlike Unix @@ -1706,7 +1746,7 @@ hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) hDuplicateTo h1 _ = ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" - "handles are incompatible" Nothing) + "handles are incompatible" Nothing Nothing) -- --------------------------------------------------------------------------- -- showing Handles. @@ -1718,6 +1758,7 @@ hShow :: Handle -> IO String hShow h@(FileHandle path _) = showHandle' path False h hShow h@(DuplexHandle path _ _) = showHandle' path True h +showHandle' :: String -> Bool -> Handle -> IO String showHandle' filepath is_duplex h = withHandle_ "showHandle" h $ \hdl_ -> let