X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=6760b1f545961ca0184deff753bbcddc5c49e802;hb=7fed02d08be1f19b470e2a79e587064789f0b564;hp=94b02036a6ebf5f7a5065f1be9c0be87c3a43818;hpb=260e7f2ed9a43c6ecf5a556d77817f39ed2893ab;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 94b0203..6760b1f 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,14 +1,21 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-} +{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} #undef DEBUG_DUMP #undef DEBUG --- ----------------------------------------------------------------------------- --- $Id: Handle.hs,v 1.1 2001/12/21 15:07:22 simonmar Exp $ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Handle +-- Copyright : (c) The University of Glasgow, 1994-2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable -- --- (c) The University of Glasgow, 1994-2001 +-- This module defines the basic operations on I\/O \"handles\". -- --- This module defines the basic operations on I/O "handles". +----------------------------------------------------------------------------- module GHC.Handle ( withHandle, withHandle', withHandle_, @@ -16,23 +23,23 @@ module GHC.Handle ( newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer, - read_off, + read_off, read_off_ba, + write_off, write_off_ba, unlockFile, ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, + IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, fdToHandle, hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, - hFlush, + hFlush, hDuplicate, hDuplicateTo, hClose, hClose_help, HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, + SeekMode(..), hSeek, hTell, hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, hSetEcho, hGetEcho, hIsTerminalDevice, - ioeGetFileName, ioeGetErrorString, ioeGetHandle, #ifdef DEBUG_DUMP puts, @@ -40,11 +47,14 @@ module GHC.Handle ( ) where +#include "config.h" + import Control.Monad import Data.Bits import Data.Maybe import Foreign import Foreign.C +import System.IO.Error import GHC.Posix import GHC.Real @@ -117,12 +127,17 @@ withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a 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 (Handle__,a)) -> IO a withHandle' fun h m act = block $ do h_ <- takeMVar m checkBufferInvariants h_ (h',v) <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) + (\ err -> putMVar m h_ >> + case err of + IOException ex -> ioError (augmentIOError ex fun h h_) + _ -> throw err) checkBufferInvariants h' putMVar m h' return v @@ -137,7 +152,10 @@ withHandle_' fun h m act = h_ <- takeMVar m checkBufferInvariants h_ v <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) + (\ err -> putMVar m h_ >> + case err of + IOException ex -> ioError (augmentIOError ex fun h h_) + _ -> throw err) checkBufferInvariants h_ putMVar m h_ return v @@ -153,17 +171,18 @@ withHandle__' fun h m act = h_ <- takeMVar m checkBufferInvariants h_ h' <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) + (\ err -> putMVar m h_ >> + case err of + IOException ex -> ioError (augmentIOError ex fun h h_) + _ -> throw err) checkBufferInvariants h' putMVar m h' return () -augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_ - = IOException (IOError (Just h) iot fun str filepath) +augmentIOError (IOError _ iot _ str fp) fun h h_ + = IOError (Just h) iot fun str filepath where filepath | Just _ <- fp = fp | otherwise = Just (haFilePath h_) -augmentIOError other_exception _ _ _ - = other_exception -- --------------------------------------------------------------------------- -- Wrapper for write operations. @@ -296,16 +315,23 @@ stdHandleFinalizer m = do handleFinalizer :: MVar Handle__ -> IO () handleFinalizer m = do h_ <- takeMVar m - flushWriteBufferOnly h_ - let fd = fromIntegral (haFD h_) - unlockFile fd - when (fd /= -1) + let + -- hClose puts both the fd and the handle's type + -- into a closed state, so it's a bit excessive + -- to test for both here, but caution sometimes + -- pays off.. + alreadyClosed = + case haType h_ of { ClosedHandle{} -> True; _ -> False } + fd = fromIntegral (haFD h_) + + when (not alreadyClosed && fd /= -1) $ do + flushWriteBufferOnly h_ + unlockFile fd #ifdef mingw32_TARGET_OS (closeFd (haIsStream h_) fd >> return ()) #else (c_close fd >> return ()) #endif - return () -- --------------------------------------------------------------------------- -- Grimy buffer operations @@ -333,19 +359,19 @@ newEmptyBuffer b state size = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state } allocateBuffer :: Int -> BufferState -> IO Buffer -allocateBuffer sz@(I## size) state = IO $ \s -> - case newByteArray## size s of { (## s, b ##) -> - (## s, newEmptyBuffer b state sz ##) } +allocateBuffer sz@(I# size) state = IO $ \s -> + case newByteArray# 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##) ##) +writeCharIntoBuffer slab (I# off) (C# c) + = IO $ \s -> case writeCharArray# slab off c s of + 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##)) ##) +readCharFromBuffer slab (I# off) + = IO $ \s -> case readCharArray# slab off s of + (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #) getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) getBuffer fd state = do @@ -403,7 +429,7 @@ flushReadBuffer fd buf puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") # endif throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek (fromIntegral fd) (fromIntegral off) sSEEK_CUR) + (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR) return buf{ bufWPtr=0, bufRPtr=0 } flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer @@ -416,17 +442,19 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do then return (buf{ bufRPtr=0, bufWPtr=0 }) else do res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer" - (write_off (fromIntegral fd) is_stream b (fromIntegral r) - (fromIntegral bytes)) + (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r) + (fromIntegral bytes)) (threadWaitWrite fd) let res' = fromIntegral res if res' < bytes then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) else return buf{ bufRPtr=0, bufWPtr=0 } -foreign import "__hscore_PrelHandle_write" unsafe - write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +foreign import ccall unsafe "__hscore_PrelHandle_write" + write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +foreign import ccall unsafe "__hscore_PrelHandle_write" + write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer fillReadBuffer fd is_line is_stream @@ -450,7 +478,7 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") #endif res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer" - (read_off fd is_stream b (fromIntegral w) (fromIntegral bytes)) + (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes)) (threadWaitRead fd) let res' = fromIntegral res #ifdef DEBUG_DUMP @@ -464,8 +492,11 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do then fillReadBufferLoop fd is_line is_stream buf b (w+res') size else return buf{ bufRPtr=0, bufWPtr=w+res' } -foreign import "__hscore_PrelHandle_read" unsafe - read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +foreign import ccall unsafe "__hscore_PrelHandle_read" + read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_PrelHandle_read" + read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -- --------------------------------------------------------------------------- -- Standard Handles @@ -533,18 +564,13 @@ Two files are the same if they have the same absolute name. An implementation is free to impose stricter conditions. -} -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) - data IOModeEx = BinaryMode IOMode | TextMode IOMode deriving (Eq, Read, Show) -addFilePathToIOError fun fp (IOException (IOError h iot _ str _)) - = IOException (IOError h iot fun str (Just fp)) -addFilePathToIOError _ _ other_exception - = other_exception +addFilePathToIOError fun fp (IOError h iot _ str _) + = IOError h iot fun str (Just fp) openFile :: FilePath -> IOMode -> IO Handle openFile fp im = @@ -552,13 +578,13 @@ openFile fp im = (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE then BinaryMode im else TextMode im)) - (\e -> throw (addFilePathToIOError "openFile" fp e)) + (\e -> ioError (addFilePathToIOError "openFile" fp e)) openFileEx :: FilePath -> IOModeEx -> IO Handle openFileEx fp m = catch (openFile' fp m) - (\e -> throw (addFilePathToIOError "openFileEx" fp e)) + (\e -> ioError (addFilePathToIOError "openFileEx" fp e)) openFile' filepath ex_mode = @@ -580,7 +606,7 @@ openFile' filepath ex_mode = | otherwise = False binary_flags - | binary = PrelHandle.o_BINARY + | binary = o_BINARY | otherwise = 0 oflags = oflags1 .|. binary_flags @@ -652,10 +678,16 @@ openFd fd mb_fd_type filepath mode binary truncate = do mkFileHandle fd is_stream filepath ha_type binary -foreign import "lockFile" unsafe +fdToHandle :: FD -> IO Handle +fdToHandle fd = do + mode <- fdGetMode fd + let fd_str = "" + openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-} + +foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt -foreign import "unlockFile" unsafe +foreign import ccall unsafe "unlockFile" unlockFile :: CInt -> IO CInt mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode @@ -750,21 +782,27 @@ hClose' h m = withHandle__' "hClose" h m $ hClose_help -- then closed immediately. We have to be careful with DuplexHandles -- though: we have to leave the closing to the finalizer in that case, -- because the write side may still be in use. +hClose_help :: Handle__ -> IO Handle__ hClose_help handle_ = case haType handle_ of ClosedHandle -> return handle_ _ -> do - let fd = fromIntegral (haFD handle_) + let fd = haFD handle_ + c_fd = fromIntegral fd + flushWriteBufferOnly handle_ - -- close the file descriptor, but not when this is the read side - -- of a duplex handle. + -- close the file descriptor, but not when this is the read + -- side of a duplex handle, and not when this is one of the + -- std file handles. case haOtherSide handle_ of - Nothing -> throwErrnoIfMinus1Retry_ "hClose" + Nothing -> + when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $ + throwErrnoIfMinus1Retry_ "hClose" #ifdef mingw32_TARGET_OS - (closeFd (haIsStream handle_) fd) + (closeFd (haIsStream handle_) c_fd) #else - (c_close fd) + (c_close c_fd) #endif Just _ -> return () @@ -772,7 +810,7 @@ hClose_help handle_ = writeIORef (haBuffers handle_) BufferListNil -- unlock it - unlockFile fd + unlockFile c_fd -- we must set the fd to -1, because the finalizer is going -- to run eventually and try to close/unlock it. @@ -812,7 +850,7 @@ hIsEOF :: Handle -> IO Bool hIsEOF handle = catch (do hLookAhead handle; return False) - (\e -> if isEOFError e then return True else throw e) + (\e -> if isEOFError e then return True else ioError e) isEOF :: IO Bool isEOF = hIsEOF stdin @@ -903,7 +941,11 @@ hSetBuffering handle mode = is_tty <- fdIsTTY (haFD handle_) when (is_tty && isReadableHandleType (haType handle_)) $ case mode of +#ifndef mingw32_TARGET_OS + -- 'raw' mode under win32 is a bit too specialised (and troublesome + -- for most common uses), so simply disable its use here. NoBuffering -> setCooked (haFD handle_) False +#endif _ -> setCooked (haFD handle_) True -- throw away spare buffers, they might be the wrong size @@ -927,7 +969,7 @@ hFlush handle = writeIORef (haBuffer handle_) flushed_buf else return () - + -- ----------------------------------------------------------------------------- -- Repositioning Handles @@ -951,32 +993,9 @@ type HandlePosition = Integer -- position of `hdl' to a previously obtained position `p'. hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = - wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - -#if defined(mingw32_TARGET_OS) - -- urgh, on Windows we have to worry about \n -> \r\n translation, - -- so we can't easily calculate the file position using the - -- current buffer size. Just flush instead. - flushBuffer handle_ -#endif - let fd = fromIntegral (haFD handle_) - posn <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 sEEK_CUR) - - let ref = haBuffer handle_ - buf <- readIORef ref - - let real_posn - | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) - | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") - puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") -# endif - return (HandlePosn handle real_posn) - +hGetPosn handle = do + posn <- hTell handle + return (HandlePosn handle posn) hSetPosn :: HandlePosn -> IO () hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i @@ -1050,6 +1069,34 @@ hSeek handle mode offset = writeIORef ref new_buf do_seek + +hTell :: Handle -> IO Integer +hTell handle = + wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do + +#if defined(mingw32_TARGET_OS) + -- urgh, on Windows we have to worry about \n -> \r\n translation, + -- so we can't easily calculate the file position using the + -- current buffer size. Just flush instead. + flushBuffer handle_ +#endif + let fd = fromIntegral (haFD handle_) + posn <- fromIntegral `liftM` + throwErrnoIfMinus1Retry "hGetPosn" + (c_lseek fd 0 sEEK_CUR) + + let ref = haBuffer handle_ + buf <- readIORef ref + + let real_posn + | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) + | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) +# ifdef DEBUG_DUMP + puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") + puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") +# endif + return real_posn + -- ----------------------------------------------------------------------------- -- Handle Properties @@ -1162,55 +1209,102 @@ hIsTerminalDevice handle = do -- ----------------------------------------------------------------------------- -- hSetBinaryMode +-- | On Windows, reading a file in text mode (which is the default) will +-- translate CRLF to LF, and writing will translate LF to CRLF. This +-- is usually what you want with text files. With binary files this is +-- undesirable; also, as usual under Microsoft operating systems, text +-- mode treats control-Z as EOF. Setting binary mode using +-- 'hSetBinaryMode' turns off all special treatment of end-of-line and +-- end-of-file characters. +-- +hSetBinaryMode :: Handle -> Bool -> IO () hSetBinaryMode handle bin = withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> do throwErrnoIfMinus1_ "hSetBinaryMode" (setmode (fromIntegral (haFD handle_)) bin) return handle_{haIsBin=bin} -foreign import "__hscore_setmode" unsafe +foreign import ccall unsafe "__hscore_setmode" setmode :: CInt -> Bool -> IO CInt -- ----------------------------------------------------------------------------- --- Miscellaneous +-- Duplicating a Handle + +-- |Returns a duplicate of the original handle, with its own buffer +-- and file pointer. The original handle's buffer is flushed, including +-- discarding any input data, before the handle is duplicated. + +hDuplicate :: Handle -> IO Handle +hDuplicate h@(FileHandle m) = do + new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing) + new_m <- newMVar new_h_ + return (FileHandle new_m) +hDuplicate h@(DuplexHandle r w) = do + new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing) + new_w <- newMVar new_w_ + new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w)) + new_r <- newMVar new_r_ + return (DuplexHandle new_r new_w) + +dupHandle_ other_side h_ = do + -- flush the buffer first, so we don't have to copy its contents + flushBuffer h_ + new_fd <- c_dup (fromIntegral (haFD h_)) + buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_)) + ioref <- newIORef buffer + ioref_buffers <- newIORef BufferListNil + + let new_handle_ = h_{ haFD = fromIntegral new_fd, + haBuffer = ioref, + haBuffers = ioref_buffers, + haOtherSide = other_side } + return (h_, new_handle_) --- These three functions are meant to get things out of an IOError. +-- ----------------------------------------------------------------------------- +-- Replacing a Handle -ioeGetFileName :: IOError -> Maybe FilePath -ioeGetErrorString :: IOError -> String -ioeGetHandle :: IOError -> Maybe Handle +{- | +Makes the second handle a duplicate of the first handle. The second +handle will be closed first, if it is not already. -ioeGetHandle (IOException (IOError h _ _ _ _)) = h -ioeGetHandle (UserError _) = Nothing -ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" +This can be used to retarget the standard Handles, for example: -ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot -ioeGetErrorString (UserError str) = str -ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" +> do h <- openFile "mystdout" WriteMode +> hDuplicateTo h stdout +-} -ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn -ioeGetFileName (UserError _) = Nothing -ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" +hDuplicateTo :: Handle -> Handle -> IO () +hDuplicateTo h1@(FileHandle m1) h2@(FileHandle m2) = do + withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do + _ <- hClose_help h2_ + withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing) +hDuplicateTo h1@(DuplexHandle r1 w1) h2@(DuplexHandle r2 w2) = do + withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do + _ <- hClose_help w2_ + withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing) + withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do + _ <- hClose_help r2_ + withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1)) +hDuplicateTo h1 _ = + ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" + "handles are incompatible" Nothing) -- --------------------------------------------------------------------------- -- debugging #ifdef DEBUG_DUMP puts :: String -> IO () -puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s)) +puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s)) return () #endif -- ----------------------------------------------------------------------------- -- wrappers to platform-specific constants: -foreign import ccall "__hscore_supportsTextMode" unsafe +foreign import ccall unsafe "__hscore_supportsTextMode" tEXT_MODE_SEEK_ALLOWED :: Bool -foreign import ccall "__hscore_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int -foreign import ccall "__hscore_seek_cur" unsafe sEEK_CUR :: CInt -foreign import ccall "__hscore_seek_set" unsafe sEEK_SET :: CInt -foreign import ccall "__hscore_seek_end" unsafe sEEK_END :: CInt -foreign import ccall "__hscore_o_binary" unsafe o_BINARY :: CInt - - +foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int +foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt +foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt +foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt