-----------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.4 2000/10/24 13:23:33 sewardj Exp $
+-- $Id: TmpFiles.hs,v 1.17 2001/04/18 11:58:02 sewardj Exp $
--
-- Temporary file management
--
module TmpFiles (
Suffix,
initTempFileStorage, -- :: IO ()
- cleanTempFiles, -- :: IO ()
+ cleanTempFiles, -- :: Int -> IO ()
+ cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
newTempName, -- :: Suffix -> IO FilePath
- addFilesToClean -- :: [FilePath] -> IO ()
+ addFilesToClean, -- :: [FilePath] -> IO ()
+ removeTmpFiles, -- :: Int -> [FilePath] -> IO ()
+ v_TmpDir,
+ kludgedSystem
) where
-- main
-import DriverState
+import DriverUtil
import Config
+import Panic
import Util
-- hslibs
-#ifndef mingw32_TARGET_OS
-import Posix ( getProcessID )
-#endif
import Exception
import IOExts
import IO
import Monad
+#include "../includes/config.h"
#include "HsVersions.h"
GLOBAL_VAR(v_FilesToClean, [], [String] )
+GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
+
initTempFileStorage = do
-- check whether TMPDIR is set in the environment
IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
- writeIORef v_TmpDir dir)
-
+#ifndef mingw32_TARGET_OS
+ writeIORef v_TmpDir dir
+#endif
+ return ()
+ )
-cleanTempFiles :: Bool -> IO ()
-cleanTempFiles verbose = do
+cleanTempFiles :: Int -> IO ()
+cleanTempFiles verb = do
fs <- readIORef v_FilesToClean
+ removeTmpFiles verb fs
- let blowAway f =
- (do when verbose (hPutStrLn stderr ("removing: " ++ f))
- if '*' `elem` f then system ("rm -f " ++ f) >> return ()
- else removeFile f)
- `catchAllIO`
- (\_ -> when verbose (hPutStrLn stderr
- ("warning: can't remove tmp file" ++ f)))
- mapM_ blowAway fs
+cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
+cleanTempFilesExcept verb dont_delete = do
+ fs <- readIORef v_FilesToClean
+ let leftovers = filter (`notElem` dont_delete) fs
+ removeTmpFiles verb leftovers
+ writeIORef v_FilesToClean dont_delete
type Suffix = String
-- find a temporary name that doesn't already exist.
-#ifdef mingw32_TARGET_OS
-getProcessID :: IO Int
-getProcessID
- = do putStr "warning: faking getProcessID in main/TmpFiles.lhs"
- return 12345
-#endif
-
newTempName :: Suffix -> IO FilePath
newTempName extn = do
- x <- getProcessID
+ x <- myGetProcessID
tmp_dir <- readIORef v_TmpDir
findTempName tmp_dir x
where findTempName tmp_dir x = do
addFilesToClean :: [FilePath] -> IO ()
addFilesToClean files = mapM_ (add v_FilesToClean) files
-add :: IORef [a] -> a -> IO ()
-add var x = do
- xs <- readIORef var
- writeIORef var (x:xs)
+removeTmpFiles :: Int -> [FilePath] -> IO ()
+removeTmpFiles verb fs = do
+ let verbose = verb >= 2
+ blowAway f =
+ (do when verbose (hPutStrLn stderr ("Removing: " ++ f))
+ if '*' `elem` f
+ then kludgedSystem ("rm -f " ++ f) "Cleaning temp files" >> return ()
+ else removeFile f)
+ `catchAllIO`
+ (\_ -> when verbose (hPutStrLn stderr
+ ("Warning: can't remove tmp file " ++ f)))
+ mapM_ blowAway fs
+
+-- system that works feasibly under Windows (i.e. passes the command line to sh,
+-- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
+kludgedSystem cmd phase_name
+ = do
+#ifndef mingw32_TARGET_OS
+ la la la
+ exit_code <- system cmd `catchAllIO`
+ (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+#else
+ pid <- myGetProcessID
+ tmp_dir <- readIORef v_TmpDir
+ let tmp = tmp_dir++"/sh"++show pid
+ h <- openFile tmp WriteMode
+ hPutStrLn h cmd
+ hClose h
+ exit_code <- system ("sh - " ++ tmp) `catchAllIO`
+ (\_ -> removeFile tmp >>
+ throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ removeFile tmp
+#endif
+ return exit_code