1 -----------------------------------------------------------------------------
2 -- $Id: TmpFiles.hs,v 1.18 2001/04/21 10:19:53 panne Exp $
4 -- Temporary file management
6 -- (c) The University of Glasgow 2000
8 -----------------------------------------------------------------------------
12 initTempFileStorage, -- :: IO ()
13 cleanTempFiles, -- :: Int -> IO ()
14 cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
15 newTempName, -- :: Suffix -> IO FilePath
16 addFilesToClean, -- :: [FilePath] -> IO ()
17 removeTmpFiles, -- :: Int -> [FilePath] -> IO ()
38 #include "../includes/config.h"
39 #include "HsVersions.h"
41 GLOBAL_VAR(v_FilesToClean, [], [String] )
42 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
45 initTempFileStorage = do
46 -- check whether TMPDIR is set in the environment
47 IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
48 #ifndef mingw32_TARGET_OS
49 writeIORef v_TmpDir dir
54 cleanTempFiles :: Int -> IO ()
55 cleanTempFiles verb = do
56 fs <- readIORef v_FilesToClean
57 removeTmpFiles verb fs
59 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
60 cleanTempFilesExcept verb dont_delete = do
61 fs <- readIORef v_FilesToClean
62 let leftovers = filter (`notElem` dont_delete) fs
63 removeTmpFiles verb leftovers
64 writeIORef v_FilesToClean dont_delete
68 -- find a temporary name that doesn't already exist.
69 newTempName :: Suffix -> IO FilePath
72 tmp_dir <- readIORef v_TmpDir
73 findTempName tmp_dir x
74 where findTempName tmp_dir x = do
75 let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
76 b <- doesFileExist filename
77 if b then findTempName tmp_dir (x+1)
78 else do add v_FilesToClean filename -- clean it up later
81 addFilesToClean :: [FilePath] -> IO ()
82 addFilesToClean files = mapM_ (add v_FilesToClean) files
84 removeTmpFiles :: Int -> [FilePath] -> IO ()
85 removeTmpFiles verb fs = do
86 let verbose = verb >= 2
88 (do when verbose (hPutStrLn stderr ("Removing: " ++ f))
90 then kludgedSystem ("rm -f " ++ f) "Cleaning temp files" >> return ()
93 (\_ -> when verbose (hPutStrLn stderr
94 ("Warning: can't remove tmp file " ++ f)))
98 -- system that works feasibly under Windows (i.e. passes the command line to sh,
99 -- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
100 kludgedSystem cmd phase_name
102 #ifndef mingw32_TARGET_OS
103 exit_code <- system cmd `catchAllIO`
104 (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
106 pid <- myGetProcessID
107 tmp_dir <- readIORef v_TmpDir
108 let tmp = tmp_dir++"/sh"++show pid
109 h <- openFile tmp WriteMode
112 exit_code <- system ("sh - " ++ tmp) `catchAllIO`
113 (\_ -> removeFile tmp >>
114 throwDyn (PhaseFailed phase_name (ExitFailure 1)))