X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=295d3a50aa01a7b2daff1b25954cb4e7b89cbf45;hb=819adca5f17b40ee129e4a30edf685f817febbf9;hp=0f7339ede12a24c810c47d2f24f71a891a9792ac;hpb=1de9e3221a6b68dd854352d390158092c6ec5933;p=ghc-base.git

diff --git a/System/Directory.hs b/System/Directory.hs
index 0f7339e..295d3a5 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -18,7 +18,9 @@ module System.Directory
 
     -- * Actions on directories
       createDirectory		-- :: FilePath -> IO ()
+    , createDirectoryIfMissing  -- :: Bool -> FilePath -> IO ()
     , removeDirectory		-- :: FilePath -> IO ()
+    , removeDirectoryRecursive  -- :: FilePath -> IO ()
     , renameDirectory		-- :: FilePath -> FilePath -> IO ()
 
     , getDirectoryContents      -- :: FilePath -> IO [FilePath]
@@ -29,13 +31,15 @@ module System.Directory
     , getHomeDirectory
     , getAppUserDataDirectory
     , getUserDocumentsDirectory
+    , getTemporaryDirectory
 
     -- * Actions on files
     , removeFile		-- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()
-#ifdef __GLASGOW_HASKELL__
     , copyFile                  -- :: FilePath -> FilePath -> IO ()
-#endif
+    
+    , canonicalizePath
+    , findExecutable
 
     -- * Existence tests
     , doesFileExist		-- :: FilePath -> IO Bool
@@ -61,39 +65,32 @@ module System.Directory
     , getModificationTime       -- :: FilePath -> IO ClockTime
    ) where
 
+import System.Directory.Internals
+import System.Environment      ( getEnv )
+import System.IO.Error
+import Control.Monad           ( when, unless )
+
 #ifdef __NHC__
 import Directory
-import System (getEnv)
-getHomeDirectory :: IO FilePath
-getHomeDirectory = getEnv "HOME"
-getAppUserDataDirectory :: String -> IO FilePath
-getAppUserDataDirectory appName = do path <- getEnv "HOME"
-                                     return (path++'/':'.':appName)
-getUserDocumentsDirectory :: IO FilePath
-getUserDocumentsDirectory= getEnv "HOME"
-#elif defined(__HUGS__)
+import NHC.FFI
+#endif /* __NHC__ */
+
+#ifdef __HUGS__
 import Hugs.Directory
-#else
+#endif /* __HUGS__ */
 
+#ifdef __GLASGOW_HASKELL__
 import Prelude
 
 import Control.Exception       ( bracket )
-import Control.Monad           ( when )
 import System.Posix.Types
 import System.Posix.Internals
 import System.Time             ( ClockTime(..) )
 import System.IO
-import System.IO.Error
 import Foreign
 import Foreign.C
 
-#ifdef __GLASGOW_HASKELL__
 import GHC.IOBase	( IOException(..), IOErrorType(..), ioException )
-#endif
-
-#ifndef mingw32_TARGET_OS
-import System.Environment
-#endif
 
 {- $intro
 A directory contains a series of entries, each of which is a named
@@ -239,10 +236,27 @@ The path refers to an existing non-directory object.
 
 createDirectory :: FilePath -> IO ()
 createDirectory path = do
+  modifyIOError (`ioeSetFileName` path) $
     withCString path $ \s -> do
       throwErrnoIfMinus1Retry_ "createDirectory" $
 	mkdir s 0o777
+#endif
 
+-- | @'createDirectoryIfMissing' parents dir@ creates a new directory 
+-- @dir@ if it doesn\'t exist. If the first argument is 'True'
+-- the function will also create all parent directories if they are missing.
+createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
+		         -> FilePath -- ^ The path to the directory you want to make
+		         -> IO ()
+createDirectoryIfMissing parents file = do
+  b <- doesDirectoryExist file
+  case (b,parents, file) of 
+    (_,     _, "") -> return ()
+    (True,  _,  _) -> return ()
+    (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
+    (_, False,  _) -> createDirectory file
+
+#if __GLASGOW_HASKELL__
 {- | @'removeDirectory' dir@ removes an existing directory /dir/.  The
 implementation may specify additional constraints which must be
 satisfied before a directory can be removed (e.g. the directory has to
@@ -289,7 +303,27 @@ removeDirectory path = do
   modifyIOError (`ioeSetFileName` path) $
     withCString path $ \s ->
        throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+#endif
 
+-- | @'removeDirectoryRecursive' dir@  removes an existing directory /dir/
+-- together with its content and all subdirectories. Be careful, 
+-- if the directory contains symlinks, the function will follow them.
+removeDirectoryRecursive :: FilePath -> IO ()
+removeDirectoryRecursive startLoc = do
+  cont <- getDirectoryContents startLoc
+  sequence_ [rm (startLoc `joinFileName` x) | x <- cont, x /= "." && x /= ".."]
+  removeDirectory startLoc
+  where
+    rm :: FilePath -> IO ()
+    rm f = do temp <- try (removeFile f)
+              case temp of
+                Left e  -> do isDir <- doesDirectoryExist f
+                              -- If f is not a directory, re-throw the error
+                              unless isDir $ ioError e
+                              removeDirectoryRecursive f
+                Right _ -> return ()
+
+#if __GLASGOW_HASKELL__
 {- |'removeFile' /file/ removes the directory entry for an existing file
 /file/, where /file/ is not itself a directory. The
 implementation may specify additional constraints which must be
@@ -449,16 +483,25 @@ renameFile opath npath =
       withCString npath $ \s2 ->
          throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
 
+#endif /* __GLASGOW_HASKELL__ */
+
 {- |@'copyFile' old new@ copies the existing file from /old/ to /new/.
 If the /new/ file already exists, it is atomically replaced by the /old/ file.
 Neither path may refer to an existing directory.
 -}
 copyFile :: FilePath -> FilePath -> IO ()
 copyFile fromFPath toFPath =
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
+	do readFile fromFPath >>= writeFile toFPath
+	   try (getPermissions fromFPath >>= setPermissions toFPath)
+	   return ()
+#else
 	(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
 	 bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
-	 allocaBytes bufferSize $ \buffer ->
-		copyContents hFrom hTo buffer) `catch` (ioError . changeFunName)
+	 allocaBytes bufferSize $ \buffer -> do
+		copyContents hFrom hTo buffer
+		try (getPermissions fromFPath >>= setPermissions toFPath)
+		return ()) `catch` (ioError . changeFunName)
 	where
 		bufferSize = 1024
 		
@@ -469,8 +512,68 @@ copyFile fromFPath toFPath =
 			when (count > 0) $ do
 				hPutBuf hTo buffer count
 				copyContents hFrom hTo buffer
+#endif
 
+#ifdef __GLASGOW_HASKELL__
+-- | Given path referring to a file or directory, returns a
+-- canonicalized path, with the intent that two paths referring
+-- to the same file\/directory will map to the same canonicalized
+-- path. Note that it is impossible to guarantee that the
+-- implication (same file\/dir \<=\> same canonicalizedPath) holds
+-- in either direction: this function can make only a best-effort
+-- attempt.
+canonicalizePath :: FilePath -> IO FilePath
+canonicalizePath fpath =
+  withCString fpath $ \pInPath ->
+  allocaBytes long_path_size $ \pOutPath ->
+#if defined(mingw32_HOST_OS)
+  alloca $ \ppFilePart ->
+    do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
+#else
+    do c_realpath pInPath pOutPath
+#endif
+       peekCString pOutPath
+
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "GetFullPathName"
+            c_GetFullPathName :: CString
+                              -> CInt
+                              -> CString
+                              -> Ptr CString
+                              -> IO CInt
+#else
+foreign import ccall unsafe "realpath"
+                   c_realpath :: CString
+                              -> CString
+                              -> IO CString
+#endif
+#else /* !__GLASGOW_HASKELL__ */
+-- dummy implementation
+canonicalizePath :: FilePath -> IO FilePath
+canonicalizePath fpath = return fpath
+#endif /* !__GLASGOW_HASKELL__ */
+
+-- | Given an executable file name, searches for such file
+-- in the directories listed in system PATH. The returned value 
+-- is the path to the found executable or Nothing if there isn't
+-- such executable. For example (findExecutable \"ghc\")
+-- gives you the path to GHC.
+findExecutable :: String -> IO (Maybe FilePath)
+findExecutable binary = do
+  path <- getEnv "PATH"
+  search (parseSearchPath path)
+  where
+    fileName = binary `joinFileExt` exeExtension
 
+    search :: [FilePath] -> IO (Maybe FilePath)
+    search [] = return Nothing
+    search (d:ds) = do
+	let path = d `joinFileName` fileName
+	b <- doesFileExist path
+	if b then return (Just path)
+             else search ds
+
+#ifdef __GLASGOW_HASKELL__
 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
 in /dir/. 
 
@@ -619,6 +722,93 @@ setCurrentDirectory path = do
        throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
 	-- ToDo: add path to error
 
+{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
+exists and is a directory, and 'False' otherwise.
+-}
+
+doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist name = 
+ catch
+   (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
+   (\ _ -> return False)
+
+{- |The operation 'doesFileExist' returns 'True'
+if the argument file exists and is not a directory, and 'False' otherwise.
+-}
+
+doesFileExist :: FilePath -> IO Bool
+doesFileExist name = do 
+ catch
+   (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
+   (\ _ -> return False)
+
+{- |The 'getModificationTime' operation returns the
+clock time at which the file or directory was last modified.
+
+The operation may fail with:
+
+* 'isPermissionError' if the user is not permitted to access
+  the modification time; or
+
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+
+getModificationTime :: FilePath -> IO ClockTime
+getModificationTime name =
+ withFileStatus "getModificationTime" name $ \ st ->
+ modificationTime st
+
+withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileStatus loc name f = do
+  modifyIOError (`ioeSetFileName` name) $
+    allocaBytes sizeof_stat $ \p ->
+      withCString (fileNameEndClean name) $ \s -> do
+        throwErrnoIfMinus1Retry_ loc (c_stat s p)
+	f p
+
+withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileOrSymlinkStatus loc name f = do
+  modifyIOError (`ioeSetFileName` name) $
+    allocaBytes sizeof_stat $ \p ->
+      withCString name $ \s -> do
+        throwErrnoIfMinus1Retry_ loc (lstat s p)
+	f p
+
+modificationTime :: Ptr CStat -> IO ClockTime
+modificationTime stat = do
+    mtime <- st_mtime stat
+    let realToInteger = round . realToFrac :: Real a => a -> Integer
+    return (TOD (realToInteger (mtime :: CTime)) 0)
+    
+isDirectory :: Ptr CStat -> IO Bool
+isDirectory stat = do
+  mode <- st_mode stat
+  return (s_isdir mode)
+
+fileNameEndClean :: String -> String
+fileNameEndClean name = 
+  if i > 0 && (ec == '\\' || ec == '/') then 
+     fileNameEndClean (take i name)
+   else
+     name
+  where
+      i  = (length name) - 1
+      ec = name !! i
+
+foreign import ccall unsafe "__hscore_long_path_size"
+  long_path_size :: Int
+
+foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode
+foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode
+foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode
+
+foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
+foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
+foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
+
+#endif /* __GLASGOW_HASKELL__ */
+
 {- | Returns the current user's home directory.
 
 The directory returned is expected to be writable by the current user,
@@ -642,7 +832,7 @@ cannot be found.
 -}
 getHomeDirectory :: IO FilePath
 getHomeDirectory =
-#ifdef mingw32_TARGET_OS
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
   allocaBytes long_path_size $ \pPath -> do
      r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
      if (r < 0)
@@ -682,7 +872,7 @@ cannot be found.
 -}
 getAppUserDataDirectory :: String -> IO FilePath
 getAppUserDataDirectory appName = do
-#ifdef mingw32_TARGET_OS
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
   allocaBytes long_path_size $ \pPath -> do
      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
      s <- peekCString pPath
@@ -702,7 +892,7 @@ instead.
 On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@
 environment variable.  On Windows, the system is queried for a
 suitable path; a typical path might be 
-@C:/Documents and Settings/user/My Documents@.
+@C:\/Documents and Settings\/user\/My Documents@.
 
 The operation may fail with:
 
@@ -715,7 +905,7 @@ cannot be found.
 -}
 getUserDocumentsDirectory :: IO FilePath
 getUserDocumentsDirectory = do
-#ifdef mingw32_TARGET_OS
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
   allocaBytes long_path_size $ \pPath -> do
      r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
      peekCString pPath
@@ -723,103 +913,54 @@ getUserDocumentsDirectory = do
   getEnv "HOME"
 #endif
 
-#ifdef mingw32_TARGET_OS
-foreign import stdcall unsafe "SHGetFolderPath" 
-            c_SHGetFolderPath :: Ptr () 
-                              -> CInt 
-                              -> Ptr () 
-                              -> CInt 
-                              -> CString 
-                              -> IO CInt
-foreign import ccall unsafe "__hscore_CSIDL_PROFILE"  csidl_PROFILE  :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_WINDOWS"  csidl_WINDOWS  :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
-#endif
+{- | Returns the current directory for temporary files.
 
-{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
-exists and is a directory, and 'False' otherwise.
--}
+On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@
+environment variable or \"\/tmp\" if the variable isn\'t defined.
+On Windows, the function checks for the existence of environment variables in 
+the following order and uses the first path found:
 
-doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name = 
- catch
-   (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
-   (\ _ -> return False)
+* 
+TMP environment variable. 
 
-{- |The operation 'doesFileExist' returns 'True'
-if the argument file exists and is not a directory, and 'False' otherwise.
--}
+*
+TEMP environment variable. 
 
-doesFileExist :: FilePath -> IO Bool
-doesFileExist name = do 
- catch
-   (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
-   (\ _ -> return False)
+*
+USERPROFILE environment variable. 
 
-{- |The 'getModificationTime' operation returns the
-clock time at which the file or directory was last modified.
+*
+The Windows directory
 
 The operation may fail with:
 
-* 'isPermissionError' if the user is not permitted to access
-  the modification time; or
-
-* 'isDoesNotExistError' if the file or directory does not exist.
+* 'UnsupportedOperation'
+The operating system has no notion of temporary directory.
 
+The function doesn\'t verify whether the path exists.
 -}
+getTemporaryDirectory :: IO FilePath
+getTemporaryDirectory = do
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_GetTempPath (fromIntegral long_path_size) pPath
+     peekCString pPath
+#else
+  catch (getEnv "TMPDIR") (\ex -> return "/tmp")
+#endif
 
-getModificationTime :: FilePath -> IO ClockTime
-getModificationTime name =
- withFileStatus "getModificationTime" name $ \ st ->
- modificationTime st
-
-withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileStatus loc name f = do
-  modifyIOError (`ioeSetFileName` name) $
-    allocaBytes sizeof_stat $ \p ->
-      withCString (fileNameEndClean name) $ \s -> do
-        throwErrnoIfMinus1Retry_ loc (c_stat s p)
-	f p
-
-withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileOrSymlinkStatus loc name f = do
-  modifyIOError (`ioeSetFileName` name) $
-    allocaBytes sizeof_stat $ \p ->
-      withCString name $ \s -> do
-        throwErrnoIfMinus1Retry_ loc (lstat s p)
-	f p
-
-modificationTime :: Ptr CStat -> IO ClockTime
-modificationTime stat = do
-    mtime <- st_mtime stat
-    let realToInteger = round . realToFrac :: Real a => a -> Integer
-    return (TOD (realToInteger (mtime :: CTime)) 0)
-    
-isDirectory :: Ptr CStat -> IO Bool
-isDirectory stat = do
-  mode <- st_mode stat
-  return (s_isdir mode)
-
-fileNameEndClean :: String -> String
-fileNameEndClean name = 
-  if i > 0 && (ec == '\\' || ec == '/') then 
-     fileNameEndClean (take i name)
-   else
-     name
-  where
-      i  = (length name) - 1
-      ec = name !! i
-
-foreign import ccall unsafe "__hscore_long_path_size"
-  long_path_size :: Int
-
-foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode
-foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode
-foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode
-
-foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
-foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
-foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "SHGetFolderPath" 
+            c_SHGetFolderPath :: Ptr () 
+                              -> CInt 
+                              -> Ptr () 
+                              -> CInt 
+                              -> CString 
+                              -> IO CInt
+foreign import ccall unsafe "__hscore_CSIDL_PROFILE"  csidl_PROFILE  :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_WINDOWS"  csidl_WINDOWS  :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
 
+foreign import stdcall unsafe "GetTempPath" c_GetTempPath :: CInt -> CString -> IO CInt
 #endif