ghc/compiler/main/TmpFiles.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: TmpFiles.hs,v 1.19 2001/05/28 03:31:19 sof 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    kludgedSystem
  20  ) where
  21
  22 -- main
  23 import DriverUtil
  24 import Config
  25 import Panic
  26 import Util
  27
  28 -- hslibs
  29 import Exception
  30 import IOExts
  31
  32 -- std
  33 import System
  34 import Directory
  35 import IO
  36 import Monad
  37
  38 #include "../includes/config.h"
  39 #include "HsVersions.h"
  40
  41 GLOBAL_VAR(v_FilesToClean, [],               [String] )
  42 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
  43
  44
  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
  50 #endif
  51               return ()
  52           )
  53
  54 cleanTempFiles :: Int -> IO ()
  55 cleanTempFiles verb = do
  56   fs <- readIORef v_FilesToClean
  57   removeTmpFiles verb fs
  58
  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
  65
  66 type Suffix = String
  67
  68 -- find a temporary name that doesn't already exist.
  69 newTempName :: Suffix -> IO FilePath
  70 newTempName extn = do
  71   x <- myGetProcessID
  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 removeTmpFiles :: Int -> [FilePath] -> IO ()
  85 removeTmpFiles verb fs = do
  86   let verbose = verb >= 2
  87       blowAway f =
  88            (do  when verbose (hPutStrLn stderr ("Removing: " ++ f))
  89                 if '*' `elem` f
  90 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
  91                   then kludgedSystem (cRM ++ ' ':dosifyPath f) "Cleaning temp files" >> return ()
  92 #else
  93                   then kludgedSystem (cRM ++ f) "Cleaning temp files" >> return ()
  94 #endif
  95                   else removeFile f)
  96             `catchAllIO`
  97            (\_ -> when verbose (hPutStrLn stderr
  98                                 ("Warning: can't remove tmp file " ++ f)))
  99   mapM_ blowAway fs
 100
 101
 102 -- system that works feasibly under Windows (i.e. passes the command line to sh,
 103 -- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
 104 kludgedSystem cmd phase_name
 105  = do
 106 #if !defined(mingw32_TARGET_OS) || defined(MINIMAL_UNIX_DEPS)
 107     -- in the case where we do want to use an MSDOS command shell, we assume
 108     -- that files and paths have been converted to a form that's
 109     -- understandable to the command we're invoking.
 110    exit_code <- system cmd `catchAllIO`
 111                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 112 #else
 113    pid <- myGetProcessID
 114    tmp_dir <- readIORef v_TmpDir
 115    let tmp = tmp_dir++"/sh"++show pid
 116    h <- openFile tmp WriteMode
 117    hPutStrLn h cmd
 118    hClose h
 119    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 120                    (\_ -> removeFile tmp >>
 121                           throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 122    removeFile tmp
 123 #endif
 124    return exit_code