fix Hugs implementation of openTempFile

[ghc-base.git] / System / IO.hs

diff --git a/System/IO.hs b/System/IO.hs
index f45e51d..a5b9d7d 100644 (file)
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -148,10 +148,8 @@ module System.IO (
     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
@@ -159,12 +157,24 @@ module System.IO (
 
     -- * Temporary files
 
-#ifdef __GLASGOW_HASKELL__
     openTempFile,
     openBinaryTempFile,
-#endif
   ) where
 
+import Data.Bits
+import Data.List
+import Data.Maybe
+import Foreign.C.Error
+import Foreign.C.String
+import System.Posix.Internals
+
+#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
@@ -222,7 +232,8 @@ import IO
   , IO ()
   , FilePath                  -- :: String
   )
-import NHC.IOExtras (fixIO)
+import NHC.IOExtras (fixIO, hPutBuf, hGetBuf)
+import NHC.FFI (Ptr)
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -401,6 +412,78 @@ openBinaryFile = openFile
 hSetBinaryMode _ _ = return ()
 #endif
 
+-- | 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 create 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
+                          (rev_suffix, rev_prefix) ->
+                              (reverse rev_prefix, reverse rev_suffix)
+
+    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
+
 -- $locking
 -- Implementations should enforce as far as possible, at least locally to the
 -- Haskell process, multiple-reader single-writer locking on files.