[project @ 2004-07-30 20:33:54 by krasimir]

[haskell-directory.git] / System / Directory.hs

diff --git a/System/Directory.hs b/System/Directory.hs
index 0ddd3d2..39ca47f 100644 (file)
--- 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
 -- 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.
 -- Portability :  portable
 --
 -- System-independent interface to directory manipulation.

@@ -14,22 +14,10 @@
 
 module System.Directory 
    ( 
 
 module System.Directory 
    ( 

-     -- $intro
-
-     -- * Permissions
-
-     -- $permissions
-
-     Permissions(
-       Permissions,
-       readable,               -- :: Permissions -> Bool 
-       writable,               -- :: Permissions -> Bool
-       executable,             -- :: Permissions -> Bool
-       searchable              -- :: Permissions -> Bool
-     )
+    -- $intro

 
     -- * Actions on directories
 
     -- * Actions on directories

-    , createDirectory          -- :: FilePath -> IO ()
+      createDirectory          -- :: FilePath -> IO ()

     , removeDirectory          -- :: FilePath -> IO ()
     , renameDirectory          -- :: FilePath -> FilePath -> IO ()
 
     , removeDirectory          -- :: FilePath -> IO ()
     , renameDirectory          -- :: FilePath -> FilePath -> IO ()
 

@@ -40,12 +28,23 @@ module System.Directory
     -- * Actions on files
     , removeFile               -- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()
     -- * Actions on files
     , removeFile               -- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()

+    , copyFile                  -- :: FilePath -> FilePath -> IO ()

 
     -- * Existence tests
     , doesFileExist            -- :: FilePath -> IO Bool
     , doesDirectoryExist        -- :: FilePath -> IO Bool
 
 
     -- * Existence tests
     , doesFileExist            -- :: FilePath -> IO Bool
     , doesDirectoryExist        -- :: FilePath -> IO Bool
 

-    -- * Setting and retrieving permissions
+    -- * Permissions
+
+    -- $permissions
+
+    , Permissions(
+       Permissions,
+       readable,               -- :: Permissions -> Bool
+       writable,               -- :: Permissions -> Bool
+       executable,             -- :: Permissions -> Bool
+       searchable              -- :: Permissions -> Bool
+      )

 
     , getPermissions            -- :: FilePath -> IO Permissions
     , setPermissions           -- :: FilePath -> Permissions -> IO ()
 
     , getPermissions            -- :: FilePath -> IO Permissions
     , setPermissions           -- :: FilePath -> Permissions -> IO ()

@@ -55,16 +54,25 @@ module System.Directory
     , getModificationTime       -- :: FilePath -> IO ClockTime
    ) where
 
     , getModificationTime       -- :: FilePath -> IO ClockTime
    ) where
 

+#ifdef __NHC__
+import Directory
+#elif defined(__HUGS__)
+import Hugs.Directory
+#else
+

 import Prelude
 
 import Prelude
 

+import Control.Exception       ( bracket )
+import Control.Monad           ( when )

 import System.Posix.Types
 import System.Posix.Types

+import System.Posix.Internals

 import System.Time             ( ClockTime(..) )
 import System.IO
 import System.Time             ( ClockTime(..) )
 import System.IO

+import System.IO.Error

 import Foreign
 import Foreign.C
 
 #ifdef __GLASGOW_HASKELL__
 import Foreign
 import Foreign.C
 
 #ifdef __GLASGOW_HASKELL__

-import GHC.Posix

 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 #endif
 
 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 #endif
 

@@ -112,13 +120,25 @@ data Permissions
     executable, searchable :: Bool 
    } deriving (Eq, Ord, Read, Show)
 
     executable, searchable :: Bool 
    } deriving (Eq, Ord, Read, Show)
 

+{- |The 'getPermissions' operation returns the
+permissions for the file or directory.
+
+The operation may fail with:
+
+* 'isPermissionError' if the user is not permitted to access
+  the permissions; or
+
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+

 getPermissions :: FilePath -> IO Permissions
 getPermissions name = do
   withCString name $ \s -> do
   read  <- c_access s r_OK
   write <- c_access s w_OK
   exec  <- c_access s x_OK
 getPermissions :: FilePath -> IO Permissions
 getPermissions name = do
   withCString name $ \s -> 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 {
   is_dir <- isDirectory st
   return (
     Permissions {

@@ -129,17 +149,34 @@ getPermissions name = do
     }
    )
 
     }
    )
 

-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
+{- |The 'setPermissions' operation sets the
+permissions for the file or directory.
+
+The operation may fail with:

 
 

-     mode  = read `unionCMode` (write `unionCMode` exec)
+* 'isPermissionError' if the user is not permitted to set
+  the permissions; or

 
 

-    withCString name $ \s ->
-      throwErrnoIfMinus1_ "setPermissions" $ c_chmod s mode
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+
+setPermissions :: FilePath -> Permissions -> IO ()
+setPermissions name (Permissions r w e s) = do
+  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
 
 -----------------------------------------------------------------------------
 -- Implementation

@@ -206,7 +243,7 @@ EIO
 The operand is not a valid directory name.
 [ENAMETOOLONG, ELOOP]
 
 The operand is not a valid directory name.
 [ENAMETOOLONG, ELOOP]
 

-* 'isDoesNotExist'  'NoSuchThing'
+* 'isDoesNotExistError' \/ 'NoSuchThing'

 The directory does not exist. 
 @[ENOENT, ENOTDIR]@
 
 The directory does not exist. 
 @[ENOENT, ENOTDIR]@
 

@@ -230,10 +267,11 @@ The operand refers to an existing non-directory object.
 
 removeDirectory :: FilePath -> IO ()
 removeDirectory path = do
 
 removeDirectory :: FilePath -> IO ()
 removeDirectory path = do

+  modifyIOError (`ioeSetFileName` path) $

     withCString path $ \s ->
        throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
 
     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
 /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

@@ -243,13 +281,13 @@ The operation may fail with:
 
 * 'HardwareFault'
 A physical I\/O error has occurred.
 
 * 'HardwareFault'
 A physical I\/O error has occurred.

-'EIO'
+@[EIO]@

 
 * 'InvalidArgument'
 The operand is not a valid file name.
 @[ENAMETOOLONG, ELOOP]@
 
 
 * 'InvalidArgument'
 The operand is not a valid file name.
 @[ENAMETOOLONG, ELOOP]@
 

-* 'isDoesNotExist' \/ 'NoSuchThing'
+* 'isDoesNotExistError' \/ 'NoSuchThing'

 The file does not exist. 
 @[ENOENT, ENOTDIR]@
 
 The file does not exist. 
 @[ENOENT, ENOTDIR]@
 

@@ -269,6 +307,7 @@ The operand refers to an existing directory.
 
 removeFile :: FilePath -> IO ()
 removeFile path = do
 
 removeFile :: FilePath -> IO ()
 removeFile path = do

+  modifyIOError (`ioeSetFileName` path) $

     withCString path $ \s ->
       throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s)
 
     withCString path $ \s ->
       throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s)
 

@@ -282,6 +321,9 @@ renaming directories in all situations (e.g. renaming to an existing
 directory, or across different physical devices), but the constraints
 must be documented.
 
 directory, or across different physical devices), but the constraints
 must be documented.
 

+On Win32 platforms, @renameDirectory@ fails if the /new/ directory already
+exists.
+

 The operation may fail with:
 
 * 'HardwareFault'
 The operation may fail with:
 
 * 'HardwareFault'

@@ -320,7 +362,7 @@ Either path refers to an existing non-directory object.
 
 renameDirectory :: FilePath -> FilePath -> IO ()
 renameDirectory opath npath =
 
 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"
    is_dir <- isDirectory st
    if (not is_dir)
        then ioException (IOError Nothing InappropriateType "renameDirectory"

@@ -377,7 +419,7 @@ Either path refers to an existing directory.
 
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath =
 
 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"
    is_dir <- isDirectory st
    if is_dir
        then ioException (IOError Nothing InappropriateType "renameFile"

@@ -388,6 +430,29 @@ renameFile opath npath =
       withCString npath $ \s2 ->
          throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
 
       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 = handle (changeFunName) $
+       (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
+               changeFunName e                             = e
+               
+               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/. 
 
 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
 in /dir/. 
 

@@ -421,6 +486,7 @@ The path refers to an existing non-directory object.
 
 getDirectoryContents :: FilePath -> IO [FilePath]
 getDirectoryContents path = do
 
 getDirectoryContents :: FilePath -> IO [FilePath]
 getDirectoryContents path = do

+  modifyIOError (`ioeSetFileName` path) $

    alloca $ \ ptr_dEnt ->
      bracket
        (withCString path $ \s -> 
    alloca $ \ ptr_dEnt ->
      bracket
        (withCString path $ \s -> 

@@ -481,8 +547,8 @@ The operating system has no notion of current directory.
 
 getCurrentDirectory :: IO FilePath
 getCurrentDirectory = do
 
 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 
   where go p bytes = do
          p' <- c_getcwd p (fromIntegral bytes)
          if p' /= nullPtr 

@@ -530,51 +596,69 @@ The path refers to an existing non-directory object.
 
 setCurrentDirectory :: FilePath -> IO ()
 setCurrentDirectory path = do
 
 setCurrentDirectory :: FilePath -> IO ()
 setCurrentDirectory path = do

+  modifyIOError (`ioeSetFileName` path) $

     withCString path $ \s -> 
        throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
        -- ToDo: add path to error
 
     withCString path $ \s -> 
        throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
        -- ToDo: add path to error
 

-{- |To clarify, 'doesDirectoryExist' returns 'True' if a file system object
-exist, and it's a directory. 'doesFileExist' returns 'True' if the file
-system object exist, but it's not a directory (i.e., for every other 
-file system object that is not a directory.) 
+{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
+exists and is a directory, and 'False' otherwise.

 -}
 
 doesDirectoryExist :: FilePath -> IO Bool
 doesDirectoryExist name = 
  catch
 -}
 
 doesDirectoryExist :: FilePath -> IO Bool
 doesDirectoryExist name = 
  catch

-   (withFileStatus name $ \st -> isDirectory st)
+   (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)

    (\ _ -> return False)
 
    (\ _ -> 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
 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)
 
    (\ _ -> 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 =
 getModificationTime :: FilePath -> IO ClockTime
 getModificationTime name =

- withFileStatus name $ \ st ->
+ withFileStatus "getModificationTime" name $ \ st ->

  modificationTime 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
     allocaBytes sizeof_stat $ \p ->
       withCString (fileNameEndClean name) $ \s -> do

-        throwErrnoIfMinus1Retry_ "withFileStatus" (c_stat s p)
+        throwErrnoIfMinus1Retry_ loc (c_stat s p)

        f 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
     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
        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
     
 isDirectory :: Ptr CStat -> IO Bool
 isDirectory stat = do

@@ -583,7 +667,7 @@ isDirectory stat = do
 
 fileNameEndClean :: String -> String
 fileNameEndClean name = 
 
 fileNameEndClean :: String -> String
 fileNameEndClean name = 

-  if i >= 0 && (ec == '\\' || ec == '/') then 
+  if i > 0 && (ec == '\\' || ec == '/') then 

      fileNameEndClean (take i name)
    else
      name
      fileNameEndClean (take i name)
    else
      name

@@ -591,27 +675,8 @@ fileNameEndClean name =
       i  = (length name) - 1
       ec = name !! i
 
       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_readdir"
-  readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
-
-foreign import ccall unsafe "__hscore_free_dirent"
-  freeDirEnt  :: Ptr CDirent -> IO ()
-
-foreign import ccall unsafe "__hscore_end_of_dir"
-  end_of_dir :: CInt
-
-foreign import ccall unsafe "__hscore_d_name"
-  d_name :: Ptr CDirent -> IO CString
+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_R_OK" r_OK :: CMode
 foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode

@@ -620,3 +685,5 @@ 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
 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