X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FIO.hs;h=29996d4d730025a816835fe6076167e88963f0fe;hb=33a57fb5a398b4ac78061732eb3e506aa5c0fb60;hp=201bb226be6e75b3da79ff5ae0449cc7f55e82e8;hpb=9856777164f36906b953f3796eea0b8851100b01;p=ghc-base.git

diff --git a/System/IO.hs b/System/IO.hs
index 201bb22..29996d4 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -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,25 +145,40 @@ 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
 
-    -- * Temporary files
+    -- * Temporary files (not portable: GHC\/Hugs only)
 
-#ifdef __GLASGOW_HASKELL__
+#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
@@ -179,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
 
@@ -214,11 +231,13 @@ 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
 
 -- -----------------------------------------------------------------------------
@@ -295,8 +314,7 @@ 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 f txt = bracket (openFile f WriteMode) hClose
-			  (\hdl -> hPutStr hdl txt) 
+writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt)
 
 -- | The computation 'appendFile' @file str@ function appends the string @str@,
 -- to the file @file@.
@@ -308,10 +326,7 @@ writeFile f txt = bracket (openFile f WriteMode) hClose
 -- > 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'.
 
@@ -364,6 +379,20 @@ 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
 
@@ -387,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.
@@ -409,6 +522,7 @@ hSetBinaryMode _ _ = return ()
 -- -----------------------------------------------------------------------------
 -- Utils
 
+#ifdef __GLASGOW_HASKELL__
 -- Copied here to avoid recursive dependency with Control.Exception
 bracket 
 	:: IO a		-- ^ computation to run first (\"acquire resource\")
@@ -424,3 +538,4 @@ bracket before after thing =
     after a
     return r
  )
+#endif