Only use cp -a if it is supported, falling back to cp -p or plain cp.

* cp --reflink=auto is used if supported, and will make git annex unlock
  much faster on filesystems like btrfs that support copy of write.

Command/Unlock.hs

@@ -8,7 +8,7 @@
 module Command.Unlock where
 
 import Control.Monad.State (liftIO)
-import System.Directory
+import System.Directory hiding (copyFile)
 
 import Command
 import qualified Annex
@@ -17,6 +17,7 @@ import Messages
 import Locations
 import Utility
 import Core
+import CopyFile
 
 seek :: [SubCmdSeek]
 seek = [withFilesInGit start]
@@ -34,9 +35,9 @@ perform dest key = do
 	let src = annexLocation g key
 	liftIO $ removeFile dest
 	showNote "copying..."
-	ok <- liftIO $ boolSystem "cp" ["-p", src, dest]
+	ok <- liftIO $ copyFile src dest
         if ok
                 then do
 			liftIO $ allowWrite dest
 			return $ Just $ return True
-                else error "cp failed!"
+                else error "copy failed!"

CopyFile.hs

@@ -0,0 +1,24 @@
+{- git-annex file copying
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CopyFile (copyFile) where
+
+import Utility
+import qualified SysConfig
+
+{- The cp command is used, because I hate reinventing the wheel,
+ - and because this allows easy access to features like cp --reflink. -}
+copyFile :: FilePath -> FilePath -> IO Bool
+copyFile src dest = boolSystem "cp" opts
+	where
+		opts = if (SysConfig.cp_reflink_auto)
+			then ["--reflink=auto", src, dest]
+			else if (SysConfig.cp_a)
+				then ["-a", src, dest]
+				else if (SysConfig.cp_p)
+					then ["-p", src, dest]
+					else [src, dest]

Makefile

@@ -2,7 +2,7 @@ all: git-annex docs
 
 ghcmake=ghc -Wall -odir build -hidir build -O2 --make 
 
-SysConfig.hs:
+SysConfig.hs: configure.hs
 	$(ghcmake) configure
 	./configure
 

Remotes.hs

@@ -23,7 +23,7 @@ import Control.Monad.State (liftIO)
 import Control.Monad (filterM)
 import qualified Data.Map as Map
 import Data.String.Utils
-import System.Directory
+import System.Directory hiding (copyFile)
 import System.Posix.Directory
 import List
 import Monad (when, unless)
@@ -37,6 +37,7 @@ import UUID
 import Utility
 import qualified Core
 import Messages
+import CopyFile
 
 {- Human visible list of remotes. -}
 list :: [Git.Repo] -> String
@@ -204,7 +205,7 @@ copyFromRemote r key file = do
 			then getssh
 			else error "copying from non-ssh repo not supported"
 	where
-		getlocal = liftIO $ boolSystem "cp" ["-a", keyloc, file]
+		getlocal = liftIO $ copyFile keyloc file
 		getssh = scp r [sshLocation r keyloc, file]
 		keyloc = annexLocation r key
 
@@ -219,7 +220,7 @@ copyToRemote r key file = do
 			then putssh keyloc
 			else error "copying to non-ssh repo not supported"
 	where
-		putlocal src = liftIO $ boolSystem "cp" ["-a", src, file]
+		putlocal src = liftIO $ copyFile src file
 		putssh src = scp r [src, sshLocation r file]
 
 sshLocation :: Git.Repo -> FilePath -> FilePath

configure.hs

@@ -1,5 +1,4 @@
-{- Checks system configuration and generates SysConfig.hs.
+{- Checks system configuration and generates SysConfig.hs. -}
- -}
 
 import System.IO
 import System.Cmd
@@ -12,8 +11,9 @@ data Config = Config String Bool
 
 tests :: [TestDesc]
 tests = [
-	  TestDesc "cp -a" "cp_a" cp_a
+	  TestDesc "cp -a" "cp_a" $ testCp "-a"
-	, TestDesc "cp --reflink" "cp_reflink" cp_reflink
+	, TestDesc "cp -p" "cp_p" $ testCp "-p"
+	, TestDesc "cp --reflink=auto" "cp_reflink_auto" $ testCp "--reflink=auto"
 	]
 
 tmpDir :: String
@@ -25,11 +25,9 @@ testFile = tmpDir ++ "/testfile"
 quiet :: String -> String
 quiet s = s ++ " 2>/dev/null"
 
-cp_a :: Test
+testCp :: String -> Test
-cp_a = testCmd $ quiet $ "cp -a " ++ testFile ++ " " ++ testFile ++ ".new"
+testCp option = testCmd $ quiet $ "cp " ++ option ++ " " ++ testFile ++ 
-
+			" " ++ testFile ++ ".new"
-cp_reflink :: Test
-cp_reflink = testCmd $ quiet $ "cp --reflink=auto " ++ testFile ++ " " ++ testFile ++ ".new"
 
 testCmd :: String -> Test
 testCmd c = do
@@ -51,6 +49,7 @@ writeSysConfig config = do
 		header = [
 			  "{- Automatically generated by configure. -}"
 			, "module SysConfig where"
+			, ""
 			]
 		footer = []
 		vars [] = []
@@ -58,6 +57,7 @@ writeSysConfig config = do
 		showvar (Config name val) = [
 			  name ++ " :: Bool"
 			, name ++ " = " ++ show val
+			, ""
 			]
 
 runTests :: [TestDesc] -> IO [Config]

debian/changelog

@@ -2,8 +2,10 @@ git-annex (0.08) UNRELEASED; urgency=low
 
   * Fix `git annex add ../foo` (when ran in a subdir of the repo).
   * Add configure step to build process.
-  * configure: Check to see if cp -a can be used.
+  * Only use cp -a if it is supported, falling back to cp -p or plain cp
-  * configure: Check to see if cp --reflink=auto can be used.
+    as needed for portability.
+  * cp --reflink=auto is used if supported, and will make git annex unlock
+    much faster on filesystems like btrfs that support copy of write.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 17 Nov 2010 13:54:49 -0400
 

doc/todo/use_cp_reflink.mdwn

@@ -3,3 +3,5 @@ The unlock command needs to copy a file, and it would be great to use this:
 
 O(1) overhead on BTRFS. Needs coreutils 7.6; and remember that git-annex
 may be used on systems without coreutils..
+
+[[done]]