X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FIO.hs;h=29996d4d730025a816835fe6076167e88963f0fe;hb=33a57fb5a398b4ac78061732eb3e506aa5c0fb60;hp=b47bb4266698d1e8b80e6d9248df3023d4d80b1f;hpb=8449ae9350867e2f18cb70f765fdea842ce61542;p=ghc-base.git diff --git a/System/IO.hs b/System/IO.hs index b47bb42..29996d4 100644 --- a/System/IO.hs +++ b/System/IO.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS_GHC -fno-implicit-prelude #-} ----------------------------------------------------------------------------- -- | -- Module : System.IO @@ -36,6 +36,7 @@ module System.IO ( -- ** Opening files + withFile, openFile, -- :: FilePath -> IOMode -> IO Handle IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), @@ -94,7 +95,7 @@ module System.IO ( hIsReadable, hIsWritable, -- :: Handle -> IO Bool hIsSeekable, -- :: Handle -> IO Bool - -- ** Terminal operations + -- ** Terminal operations (not portable: GHC\/Hugs only) #if !defined(__NHC__) hIsTerminalDevice, -- :: Handle -> IO Bool @@ -103,7 +104,7 @@ module System.IO ( hGetEcho, -- :: Handle -> IO Bool #endif - -- ** Showing handle state + -- ** Showing handle state (not portable: GHC only) #ifdef __GLASGOW_HASKELL__ hShow, -- :: Handle -> IO String @@ -144,26 +145,45 @@ module System.IO ( -- * Binary input and output + withBinaryFile, openBinaryFile, -- :: FilePath -> IOMode -> IO Handle hSetBinaryMode, -- :: Handle -> Bool -> IO () -#if !defined(__NHC__) hPutBuf, -- :: Handle -> Ptr a -> Int -> IO () hGetBuf, -- :: Handle -> Ptr a -> Int -> IO Int -#endif #if !defined(__NHC__) && !defined(__HUGS__) hPutBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int hGetBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int #endif - module System.IO.Error, + -- * Temporary files (not portable: GHC\/Hugs only) + +#if !defined(__NHC__) + openTempFile, + openBinaryTempFile, +#endif ) where +#ifndef __NHC__ +import Data.Bits +import Data.List +import Data.Maybe +import Foreign.C.Error +import Foreign.C.String +import System.Posix.Internals +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exception as ExceptionBase hiding (catch) +#endif +#ifdef __HUGS__ +import Hugs.Exception as ExceptionBase +#endif + #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.IOBase -- Together these four Prelude modules define import GHC.Handle -- all the stuff exported by IO for the GHC version import GHC.IO -import GHC.ST ( fixST ) import GHC.Exception import GHC.Num import GHC.Read @@ -175,6 +195,7 @@ import Hugs.IO import Hugs.IOExts import Hugs.IORef import Hugs.Prelude ( throw, Exception(NonTermination) ) +import Control.Exception ( bracket ) import System.IO.Unsafe ( unsafeInterleaveIO ) #endif @@ -210,32 +231,15 @@ import IO , hIsOpen, hIsClosed -- :: Handle -> IO Bool , hIsReadable, hIsWritable -- :: Handle -> IO Bool , hIsSeekable -- :: Handle -> IO Bool + , bracket , IO () , FilePath -- :: String ) -import NHC.IOExtras (fixIO) +import NHC.IOExtras (fixIO, hPutBuf, hGetBuf) +import NHC.FFI (Ptr) #endif -import System.IO.Error ( - isAlreadyExistsError, isDoesNotExistError, -- :: IOError -> Bool - isAlreadyInUseError, isFullError, - isEOFError, isIllegalOperation, - isPermissionError, isUserError, - - ioeGetErrorString, -- :: IOError -> String - ioeGetHandle, -- :: IOError -> Maybe Handle - ioeGetFileName, -- :: IOError -> Maybe FilePath - - try, -- :: IO a -> IO (Either IOError a) - - -- re-exports of Prelude names - IOError, - ioError, -- :: IOError -> IO a - userError, -- :: String -> IOError - catch -- :: IO a -> (IOError -> IO a) -> IO a - ) - -- ----------------------------------------------------------------------------- -- Standard IO @@ -309,12 +313,8 @@ readFile name = openFile name ReadMode >>= hGetContents -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@. - -writeFile :: FilePath -> String -> IO () -writeFile name str = do - hdl <- openFile name WriteMode - hPutStr hdl str - hClose hdl +writeFile :: FilePath -> String -> IO () +writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt) -- | The computation 'appendFile' @file str@ function appends the string @str@, -- to the file @file@. @@ -326,10 +326,7 @@ writeFile name str = do -- > main = appendFile "squares" (show [(x,x*x) | x <- [0,0.1..2]]) appendFile :: FilePath -> String -> IO () -appendFile name str = do - hdl <- openFile name AppendMode - hPutStr hdl str - hClose hdl +appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt) -- | The 'readLn' function combines 'getLine' and 'readIO'. @@ -356,7 +353,7 @@ readIO s = case (do { (x,t) <- reads s ; -- -- This operation may fail with: -- --- * 'isEOFError' if the end of file has been reached. +-- * 'System.IO.Error.isEOFError' if the end of file has been reached. hReady :: Handle -> IO Bool hReady h = hWaitForInput h 0 @@ -374,14 +371,28 @@ hPutStrLn hndl str = do -- -- This operation may fail with: -- --- * 'isFullError' if the device is full; or +-- * 'System.IO.Error.isFullError' if the device is full; or -- --- * 'isPermissionError' if another system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if another system resource limit would be exceeded. hPrint :: Show a => Handle -> a -> IO () hPrint hdl = hPutStrLn hdl . show #endif /* !__NHC__ */ +-- | @'withFile' name mode act@ opens a file using 'openFile' and passes +-- the resulting handle to the computation @act@. The handle will be +-- closed on exit from 'withFile', whether by normal termination or by +-- raising an exception. +withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +withFile name mode = bracket (openFile name mode) hClose + +-- | @'withBinaryFile' name mode act@ opens a file using 'openBinaryFile' +-- and passes the resulting handle to the computation @act@. The handle +-- will be closed on exit from 'withBinaryFile', whether by normal +-- termination or by raising an exception. +withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile name mode = bracket (openBinaryFile name mode) hClose + -- --------------------------------------------------------------------------- -- fixIO @@ -405,6 +416,90 @@ openBinaryFile = openFile hSetBinaryMode _ _ = return () #endif +#ifndef __NHC__ +-- | The function creates a temporary file in ReadWrite mode. +-- The created file isn\'t deleted automatically, so you need to delete it manually. +openTempFile :: FilePath -- ^ Directory in which to create the file + -> String -- ^ File name template. If the template is \"foo.ext\" then + -- the created file will be \"fooXXX.ext\" where XXX is some + -- random number. + -> IO (FilePath, Handle) +openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False + +-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True + +openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle) +openTempFile' loc tmp_dir template binary = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags1 = rw_flags .|. o_EXCL + + binary_flags + | binary = o_BINARY + | otherwise = 0 + + oflags = oflags1 .|. binary_flags + + findTempName x = do + fd <- withCString filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do + -- XXX We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- fdToHandle fd + `ExceptionBase.catchException` \e -> do c_close fd; throw e + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = tmp_dir ++ [pathSeparator] ++ filename +#if __HUGS__ + fdToHandle fd = openFd (fromIntegral fd) False ReadWriteMode binary +#endif + +-- XXX Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- XXX Copied from GHC.Handle +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +read_flags = std_flags .|. o_RDONLY +write_flags = output_flags .|. o_WRONLY +rw_flags = output_flags .|. o_RDWR +append_flags = write_flags .|. o_APPEND +#endif + -- $locking -- Implementations should enforce as far as possible, at least locally to the -- Haskell process, multiple-reader single-writer locking on files. @@ -422,4 +517,25 @@ hSetBinaryMode _ _ = return () -- the file until the entire contents of the file have been consumed. -- It follows that an attempt to write to a file (using 'writeFile', for -- example) that was earlier opened by 'readFile' will usually result in --- failure with 'isAlreadyInUseError'. +-- failure with 'System.IO.Error.isAlreadyInUseError'. + +-- ----------------------------------------------------------------------------- +-- Utils + +#ifdef __GLASGOW_HASKELL__ +-- Copied here to avoid recursive dependency with Control.Exception +bracket + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracket before after thing = + block (do + a <- before + r <- catchException + (unblock (thing a)) + (\e -> do { after a; throw e }) + after a + return r + ) +#endif