ghc/compiler/main/TmpFiles.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: TmpFiles.hs,v 1.4 2000/10/24 13:23:33 sewardj Exp $
   3 --
   4 -- Temporary file management
   5 --
   6 -- (c) The University of Glasgow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module TmpFiles (
  11    Suffix,
  12    initTempFileStorage,  -- :: IO ()
  13    cleanTempFiles,       -- :: IO ()
  14    newTempName,          -- :: Suffix -> IO FilePath
  15    addFilesToClean       -- :: [FilePath] -> IO ()
  16  ) where
  17
  18 -- main
  19 import DriverState
  20 import Config
  21 import Util
  22
  23 -- hslibs
  24 #ifndef mingw32_TARGET_OS
  25 import Posix ( getProcessID )
  26 #endif
  27 import Exception
  28 import IOExts
  29
  30 -- std
  31 import System
  32 import Directory
  33 import IO
  34 import Monad
  35
  36 #include "HsVersions.h"
  37
  38 GLOBAL_VAR(v_FilesToClean, [],               [String] )
  39
  40 initTempFileStorage = do
  41         -- check whether TMPDIR is set in the environment
  42    IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
  43               writeIORef v_TmpDir dir)
  44
  45
  46 cleanTempFiles :: Bool -> IO ()
  47 cleanTempFiles verbose = do
  48   fs <- readIORef v_FilesToClean
  49
  50   let blowAway f =
  51            (do  when verbose (hPutStrLn stderr ("removing: " ++ f))
  52                 if '*' `elem` f then system ("rm -f " ++ f) >> return ()
  53                                 else removeFile f)
  54             `catchAllIO`
  55            (\_ -> when verbose (hPutStrLn stderr
  56                                 ("warning: can't remove tmp file" ++ f)))
  57   mapM_ blowAway fs
  58
  59 type Suffix = String
  60
  61 -- find a temporary name that doesn't already exist.
  62 #ifdef mingw32_TARGET_OS
  63 getProcessID :: IO Int
  64 getProcessID
  65    = do putStr "warning: faking getProcessID in main/TmpFiles.lhs"
  66         return 12345
  67 #endif
  68
  69 newTempName :: Suffix -> IO FilePath
  70 newTempName extn = do
  71   x <- getProcessID
  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
  79                         return filename
  80
  81 addFilesToClean :: [FilePath] -> IO ()
  82 addFilesToClean files = mapM_ (add v_FilesToClean) files
  83
  84 add :: IORef [a] -> a -> IO ()
  85 add var x = do
  86   xs <- readIORef var
  87   writeIORef var (x:xs)
  88