X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FTmpFiles.hs;h=a1eae3bf030471275dd8390141dcd01da3c02a22;hb=f0d65bc7f6d4f70490fedac2a6ef0bb113c71443;hp=90ebcc23d18d2db98da621ed80db10c5fe820a6a;hpb=2ecf1c9f639dc75f1078e88c2e551116923f742a;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs
index 90ebcc2..a1eae3b 100644
--- a/ghc/compiler/main/TmpFiles.hs
+++ b/ghc/compiler/main/TmpFiles.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.8 2000/10/30 09:52:15 simonpj Exp $
+-- $Id: TmpFiles.hs,v 1.21 2001/05/29 17:53:59 sof Exp $
 --
 -- Temporary file management
 --
@@ -10,14 +10,19 @@
 module TmpFiles (
    Suffix,
    initTempFileStorage,  -- :: IO ()
-   cleanTempFiles,       -- :: IO ()
+   cleanTempFiles,       -- :: Int -> IO ()
+   cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
    newTempName,		 -- :: Suffix -> IO FilePath
    addFilesToClean,	 -- :: [FilePath] -> IO ()
-   v_TmpDir
+   removeTmpFiles,	 -- :: Int -> [FilePath] -> IO ()
+   v_TmpDir,
+   kludgedSystem
  ) where
 
 -- main
+import DriverUtil
 import Config
+import Panic
 import Util
 
 -- hslibs
@@ -30,6 +35,7 @@ import Directory
 import IO
 import Monad
 
+#include "../includes/config.h"
 #include "HsVersions.h"
 
 GLOBAL_VAR(v_FilesToClean, [],               [String] )
@@ -39,21 +45,23 @@ 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)
-
-
-cleanTempFiles :: Bool -> IO ()
-cleanTempFiles verbose = do
+#ifndef mingw32_TARGET_OS
+	      writeIORef v_TmpDir dir
+#endif
+	      return ()
+          )
+
+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
 
@@ -73,8 +81,44 @@ newTempName extn = 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 
+#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
+		  then kludgedSystem (unwords [cRM, dosifyPath f]) "Cleaning temp files" >> return ()
+#else
+		  then kludgedSystem (unwords [cRM, f]) "Cleaning temp files" >> return ()
+#endif
+		  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
+#if !defined(mingw32_TARGET_OS) || defined(MINIMAL_UNIX_DEPS)
+    -- in the case where we do want to use an MSDOS command shell, we assume
+    -- that files and paths have been converted to a form that's
+    -- understandable to the command we're invoking.
+   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