X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=c63a88a1579bc38baa568602e016d01becef69e4;hb=40001ff06f1058c5b375f8b6c6c3dfd0471600ba;hp=872334a8bebcfe43b5abbb3d493da3fee6983538;hpb=b72dda8318394f238214364dc01b8963599f8cd6;p=ghc-base.git

diff --git a/System/Directory.hs b/System/Directory.hs
index 872334a..c63a88a 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -5,7 +5,7 @@
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
--- Stability   :  provisional
+-- Stability   :  stable
 -- Portability :  portable
 --
 -- System-independent interface to directory manipulation.
@@ -25,9 +25,17 @@ module System.Directory
     , getCurrentDirectory       -- :: IO FilePath
     , setCurrentDirectory       -- :: FilePath -> IO ()
 
+    -- * Pre-defined directories
+    , getHomeDirectory
+    , getAppUserDataDirectory
+    , getUserDocumentsDirectory
+
     -- * Actions on files
     , removeFile		-- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()
+#ifdef __GLASGOW_HASKELL__
+    , copyFile                  -- :: FilePath -> FilePath -> IO ()
+#endif
 
     -- * Existence tests
     , doesFileExist		-- :: FilePath -> IO Bool
@@ -55,23 +63,31 @@ module System.Directory
 
 #ifdef __NHC__
 import Directory
-#elif defined(__HUGS__)
+import System (getEnv)
+#endif /* __NHC__ */
+
+#ifdef __HUGS__
 import Hugs.Directory
-#else
+import System.Environment (getEnv)
+#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 System.Posix.Internals
 import GHC.IOBase	( IOException(..), IOErrorType(..), ioException )
+
+#ifndef mingw32_TARGET_OS
+import System.Environment
 #endif
 
 {- $intro
@@ -136,7 +152,7 @@ getPermissions name = do
   read  <- c_access s r_OK
   write <- c_access s w_OK
   exec  <- c_access s x_OK
-  withFileStatus name $ \st -> do
+  withFileStatus "getPermissions" name $ \st -> do
   is_dir <- isDirectory st
   return (
     Permissions {
@@ -161,15 +177,20 @@ The operation may fail with:
 
 setPermissions :: FilePath -> Permissions -> IO ()
 setPermissions name (Permissions r w e s) = do
-    let
-     read  = if r      then s_IRUSR else emptyCMode
-     write = if w      then s_IWUSR else emptyCMode
-     exec  = if e || s then s_IXUSR else emptyCMode
-
-     mode  = read `unionCMode` (write `unionCMode` exec)
-
-    withCString name $ \s ->
-      throwErrnoIfMinus1_ "setPermissions" $ c_chmod s mode
+  allocaBytes sizeof_stat $ \ p_stat -> do
+  withCString name $ \p_name -> do
+    throwErrnoIfMinus1_ "setPermissions" $ do
+      c_stat p_name p_stat
+      mode <- st_mode p_stat
+      let mode1 = modifyBit r mode s_IRUSR
+      let mode2 = modifyBit w mode1 s_IWUSR
+      let mode3 = modifyBit (e || s) mode2 s_IXUSR
+      c_chmod p_name mode3
+
+ where
+   modifyBit :: Bool -> CMode -> CMode -> CMode
+   modifyBit False m b = m .&. (complement b)
+   modifyBit True  m b = m .|. b
 
 -----------------------------------------------------------------------------
 -- Implementation
@@ -236,7 +257,7 @@ EIO
 The operand is not a valid directory name.
 [ENAMETOOLONG, ELOOP]
 
-* 'isDoesNotExist'  'NoSuchThing'
+* 'isDoesNotExistError' \/ 'NoSuchThing'
 The directory does not exist. 
 @[ENOENT, ENOTDIR]@
 
@@ -264,7 +285,7 @@ removeDirectory path = do
     withCString path $ \s ->
        throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
 
-{- |@'removefile' file@ removes the directory entry for an existing file
+{- |'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
 satisfied before a file can be removed (e.g. the file may not be in
@@ -274,13 +295,13 @@ The operation may fail with:
 
 * 'HardwareFault'
 A physical I\/O error has occurred.
-'EIO'
+@[EIO]@
 
 * 'InvalidArgument'
 The operand is not a valid file name.
 @[ENAMETOOLONG, ELOOP]@
 
-* 'isDoesNotExist' \/ 'NoSuchThing'
+* 'isDoesNotExistError' \/ 'NoSuchThing'
 The file does not exist. 
 @[ENOENT, ENOTDIR]@
 
@@ -355,7 +376,7 @@ Either path refers to an existing non-directory object.
 
 renameDirectory :: FilePath -> FilePath -> IO ()
 renameDirectory opath npath =
-   withFileStatus opath $ \st -> do
+   withFileStatus "renameDirectory" opath $ \st -> do
    is_dir <- isDirectory st
    if (not is_dir)
 	then ioException (IOError Nothing InappropriateType "renameDirectory"
@@ -412,7 +433,7 @@ Either path refers to an existing directory.
 
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath =
-   withFileOrSymlinkStatus opath $ \st -> do
+   withFileOrSymlinkStatus "renameFile" opath $ \st -> do
    is_dir <- isDirectory st
    if is_dir
 	then ioException (IOError Nothing InappropriateType "renameFile"
@@ -423,6 +444,28 @@ renameFile opath npath =
       withCString npath $ \s2 ->
          throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
 
+{- |@'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 =
+	(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+	 bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+	 allocaBytes bufferSize $ \buffer ->
+		copyContents hFrom hTo buffer) `catch` (ioError . changeFunName)
+	where
+		bufferSize = 1024
+		
+		changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
+		
+		copyContents hFrom hTo buffer = do
+			count <- hGetBuf hFrom buffer bufferSize
+			when (count > 0) $ do
+				hPutBuf hTo buffer count
+				copyContents hFrom hTo buffer
+
+
 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
 in /dir/. 
 
@@ -517,8 +560,8 @@ The operating system has no notion of current directory.
 
 getCurrentDirectory :: IO FilePath
 getCurrentDirectory = do
-  p <- mallocBytes path_max
-  go p path_max
+  p <- mallocBytes long_path_size
+  go p long_path_size
   where go p bytes = do
     	  p' <- c_getcwd p (fromIntegral bytes)
 	  if p' /= nullPtr 
@@ -578,7 +621,7 @@ exists and is a directory, and 'False' otherwise.
 doesDirectoryExist :: FilePath -> IO Bool
 doesDirectoryExist name = 
  catch
-   (withFileStatus name $ \st -> isDirectory st)
+   (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
    (\ _ -> return False)
 
 {- |The operation 'doesFileExist' returns 'True'
@@ -588,7 +631,7 @@ if the argument file exists and is not a directory, and 'False' otherwise.
 doesFileExist :: FilePath -> IO Bool
 doesFileExist name = do 
  catch
-   (withFileStatus name $ \st -> do b <- isDirectory st; return (not b))
+   (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
    (\ _ -> return False)
 
 {- |The 'getModificationTime' operation returns the
@@ -605,29 +648,30 @@ The operation may fail with:
 
 getModificationTime :: FilePath -> IO ClockTime
 getModificationTime name =
- withFileStatus name $ \ st ->
+ withFileStatus "getModificationTime" name $ \ st ->
  modificationTime st
 
-withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileStatus name f = do
+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_ "withFileStatus" (c_stat s p)
+        throwErrnoIfMinus1Retry_ loc (c_stat s p)
 	f p
 
-withFileOrSymlinkStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileOrSymlinkStatus name f = do
+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_ "withFileOrSymlinkStatus" (lstat s p)
+        throwErrnoIfMinus1Retry_ loc (lstat s p)
 	f p
 
 modificationTime :: Ptr CStat -> IO ClockTime
 modificationTime stat = do
     mtime <- st_mtime stat
-    return (TOD (toInteger (mtime :: CTime)) 0)
+    let realToInteger = round . realToFrac :: Real a => a -> Integer
+    return (TOD (realToInteger (mtime :: CTime)) 0)
     
 isDirectory :: Ptr CStat -> IO Bool
 isDirectory stat = do
@@ -636,7 +680,7 @@ isDirectory stat = do
 
 fileNameEndClean :: String -> String
 fileNameEndClean name = 
-  if i >= 0 && (ec == '\\' || ec == '/') then 
+  if i > 0 && (ec == '\\' || ec == '/') then 
      fileNameEndClean (take i name)
    else
      name
@@ -644,15 +688,8 @@ fileNameEndClean name =
       i  = (length name) - 1
       ec = name !! i
 
-emptyCMode     :: CMode
-emptyCMode     = 0
-
-unionCMode     :: CMode -> CMode -> CMode
-unionCMode     = (+)
-
-
-foreign import ccall unsafe "__hscore_path_max"
-  path_max :: Int
+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
@@ -662,4 +699,122 @@ 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,
+but note that it isn't generally considered good practice to store
+application-specific data here; use 'getAppUserDataDirectory'
+instead.
+
+On Unix, 'getHomeDirectory' 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@.
+
+The operation may fail with:
+
+* 'UnsupportedOperation'
+The operating system has no notion of home directory.
+
+* 'isDoesNotExistError'
+The home directory for the current user does not exist, or
+cannot be found.
+-}
+getHomeDirectory :: IO FilePath
+getHomeDirectory =
+#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
+     if (r < 0)
+       then c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
+       else return 0
+     peekCString pPath
+#else
+  getEnv "HOME"
+#endif
+
+{- | Returns the pathname of a directory in which application-specific
+data for the current user can be stored.  The result of
+'getAppUserDataDirectory' for a given application is specific to
+the current user.
+
+The argument should be the name of the application, which will be used
+to construct the pathname (so avoid using unusual characters that
+might result in an invalid pathname).
+
+Note: the directory may not actually exist, and may need to be created
+first.  It is expected that the parent directory exists and is
+writable.
+
+On Unix, this function returns @$HOME\/.appName@.  On Windows, a
+typical path might be 
+
+> C:/Documents And Settings/user/Application Data/appName
+
+The operation may fail with:
+
+* 'UnsupportedOperation'
+The operating system has no notion of application-specific data directory.
+
+* 'isDoesNotExistError'
+The home directory for the current user does not exist, or
+cannot be found.
+-}
+getAppUserDataDirectory :: String -> IO FilePath
+getAppUserDataDirectory appName = do
+#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
+     s <- peekCString pPath
+     return (s++'\\':appName)
+#else
+  path <- getEnv "HOME"
+  return (path++'/':'.':appName)
+#endif
+
+{- | Returns the current user's document directory.
+
+The directory returned is expected to be writable by the current user,
+but note that it isn't generally considered good practice to store
+application-specific data here; use 'getAppUserDataDirectory'
+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@.
+
+The operation may fail with:
+
+* 'UnsupportedOperation'
+The operating system has no notion of document directory.
+
+* 'isDoesNotExistError'
+The document directory for the current user does not exist, or
+cannot be found.
+-}
+getUserDocumentsDirectory :: IO FilePath
+getUserDocumentsDirectory = do
+#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
+     peekCString pPath
+#else
+  getEnv "HOME"
+#endif
+
+#if __GLASGOW_HASKELL__ && defined(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