ghc/compiler/main/TmpFiles.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: TmpFiles.hs,v 1.15 2001/02/12 13:33:47 simonmar 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,       -- :: Int -> IO ()
  14    cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
  15    newTempName,          -- :: Suffix -> IO FilePath
  16    addFilesToClean,      -- :: [FilePath] -> IO ()
  17    removeTmpFiles,       -- :: Int -> [FilePath] -> IO ()
  18    v_TmpDir
  19  ) where
  20
  21 -- main
  22 import Config
  23 import Util
  24 import DriverUtil
  25
  26 -- hslibs
  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 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
  40
  41
  42 initTempFileStorage = do
  43         -- check whether TMPDIR is set in the environment
  44    IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
  45 #ifndef mingw32_TARGET_OS
  46               writeIORef v_TmpDir dir
  47 #endif
  48               return ()
  49           )
  50
  51 cleanTempFiles :: Int -> IO ()
  52 cleanTempFiles verb = do
  53   fs <- readIORef v_FilesToClean
  54   removeTmpFiles verb fs
  55
  56 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
  57 cleanTempFilesExcept verb dont_delete = do
  58   fs <- readIORef v_FilesToClean
  59   let leftovers = filter (`notElem` dont_delete) fs
  60   removeTmpFiles verb leftovers
  61   writeIORef v_FilesToClean dont_delete
  62
  63 type Suffix = String
  64
  65 -- find a temporary name that doesn't already exist.
  66 newTempName :: Suffix -> IO FilePath
  67 newTempName extn = do
  68   x <- myGetProcessID
  69   tmp_dir <- readIORef v_TmpDir
  70   findTempName tmp_dir x
  71   where findTempName tmp_dir x = do
  72            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
  73            b  <- doesFileExist filename
  74            if b then findTempName tmp_dir (x+1)
  75                 else do add v_FilesToClean filename -- clean it up later
  76                         return filename
  77
  78 addFilesToClean :: [FilePath] -> IO ()
  79 addFilesToClean files = mapM_ (add v_FilesToClean) files
  80
  81 removeTmpFiles :: Int -> [FilePath] -> IO ()
  82 removeTmpFiles verb fs = do
  83   let verbose = verb >= 2
  84       blowAway f =
  85            (do  when verbose (hPutStrLn stderr ("Removing: " ++ f))
  86                 if '*' `elem` f
  87                   then kludgedSystem ("rm -f " ++ f) "Cleaning temp files" >> return ()
  88                   else removeFile f)
  89             `catchAllIO`
  90            (\_ -> when verbose (hPutStrLn stderr
  91                                 ("Warning: can't remove tmp file " ++ f)))
  92   mapM_ blowAway fs