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

diff --git a/System/IO.hs b/System/IO.hs
index 0d9d029..29996d4 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -95,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
@@ -104,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
@@ -155,20 +155,29 @@ module System.IO (
     hGetBufNonBlocking,	       -- :: Handle -> Ptr a -> Int -> IO Int
 #endif
 
-    -- * Temporary files (not portable: GHC only)
+    -- * 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
@@ -407,11 +416,12 @@ 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 create file will be \"fooXXX.ext\" where XXX is some
+                           -- 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
@@ -425,7 +435,22 @@ openTempFile' loc tmp_dir template binary = do
   pid <- c_getpid
   findTempName pid
   where
-    (prefix,suffix) = break (=='.') template
+    -- 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
 
@@ -445,12 +470,18 @@ openTempFile' loc tmp_dir template binary = do
            then findTempName (x+1)
            else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
        else do
-         h <- fdToHandle' fd Nothing False filepath ReadWriteMode True
-	        `catchException` \e -> do c_close fd; throw e
+         -- 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
@@ -467,6 +498,7 @@ 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