[project @ 2004-07-30 23:29:41 by ross]

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

diff --git a/System/Directory.hs b/System/Directory.hs
index 9cb985c..7d92473 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
--- Stability   :  provisional
+-- Stability   :  stable
 -- Portability :  portable
 --
 -- System-independent interface to directory manipulation.
@@ -28,6 +28,9 @@ module System.Directory
     -- * Actions on files
     , removeFile               -- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()
+#ifdef __GLASGOW_HASKELL__
+    , copyFile                  -- :: FilePath -> FilePath -> IO ()
+#endif
 
     -- * Existence tests
     , doesFileExist            -- :: FilePath -> IO Bool
@@ -62,7 +65,9 @@ import Hugs.Directory
 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
@@ -70,7 +75,6 @@ import Foreign
 import Foreign.C
 
 #ifdef __GLASGOW_HASKELL__
-import System.Posix.Internals
 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 #endif
 
@@ -161,15 +165,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
@@ -423,6 +432,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/. 
 
@@ -627,7 +658,8 @@ withFileOrSymlinkStatus loc name f = do
 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
@@ -644,13 +676,6 @@ fileNameEndClean name =
       i  = (length name) - 1
       ec = name !! i
 
-emptyCMode     :: CMode
-emptyCMode     = 0
-
-unionCMode     :: CMode -> CMode -> CMode
-unionCMode     = (+)
-
-
 foreign import ccall unsafe "__hscore_long_path_size"
   long_path_size :: Int