Add copy subcommand.

CmdLine.hs

@@ -18,6 +18,7 @@ import qualified Command.Add
 import qualified Command.Unannex
 import qualified Command.Drop
 import qualified Command.Move
+import qualified Command.Copy
 import qualified Command.Get
 import qualified Command.FromKey
 import qualified Command.DropKey
@@ -41,7 +42,9 @@ subCmds =
 	, SubCommand "drop" path	Command.Drop.seek
 		"indicate content of files not currently wanted"
 	, SubCommand "move" path	Command.Move.seek
-		"transfer content of files to/from another repository"
+		"move content of files to/from another repository"
+	, SubCommand "copy" path	Command.Copy.seek
+		"copy content of files to/from another repository"
 	, SubCommand "unlock" path	Command.Unlock.seek
 		"unlock files for modification"
 	, SubCommand "edit" path	Command.Unlock.seek

Command/Move.hs

@@ -7,7 +7,7 @@
 
 module Command.Move where
 
-import Control.Monad.State (liftIO, when)
+import Control.Monad.State (liftIO)
 
 import Command
 import qualified Command.Drop
@@ -22,43 +22,55 @@ import UUID
 import Messages
 
 seek :: [SubCmdSeek]
-seek = [withFilesInGit start]
+seek = [withFilesInGit $ start True]
 
-{- Move a file either --to or --from a repository.
+{- Move (or copy) a file either --to or --from a repository.
  -
  - This only operates on the cached file content; it does not involve
  - moving data in the key-value backend. -}
-start :: SubCmdStartString
+start :: Bool -> SubCmdStartString
-start file = do
+start move file = do
 	fromName <- Annex.flagGet "fromrepository"
 	toName <- Annex.flagGet "torepository"
 	case (fromName, toName) of
 		("", "") -> error "specify either --from or --to"
-		("",  _) -> moveToStart file
+		("",  _) -> toStart move file
-		(_ , "") -> moveFromStart file
+		(_ , "") -> fromStart move file
 		(_ ,  _) -> error "only one of --from or --to can be specified"
 
-{- Moves the content of an annexed file to another repository,
+showAction :: Bool -> FilePath -> Annex ()
- - removing it from the current repository, and updates locationlog
+showAction True file = showStart "move" file
- - information on both.
+showAction False file = showStart "copy" file
+
+remoteHasKey :: Git.Repo -> Key -> Bool -> Annex ()
+remoteHasKey remote key present	= do
+	g <- Annex.gitRepo
+	remoteuuid <- getUUID remote
+	logfile <- liftIO $ logChange g key remoteuuid status
+	Annex.queue "add" ["--"] logfile
+	where
+		status = if present then ValuePresent else ValueMissing
+
+{- Moves (or copies) the content of an annexed file to another repository,
+ - and updates locationlog information on both.
  -
- - If the destination already has the content, it is still removed
+ - When moving, if the destination already has the content, it is
- - from the current repository.
+ - still removed from the current repository.
  -
  - Note that unlike drop, this does not honor annex.numcopies.
  - A file's content can be moved even if there are insufficient copies to
  - allow it to be dropped.
  -}
-moveToStart :: SubCmdStartString
+toStart :: Bool -> SubCmdStartString
-moveToStart file = isAnnexed file $ \(key, _) -> do
+toStart move file = isAnnexed file $ \(key, _) -> do
 	ishere <- inAnnex key
 	if not ishere
 		then return Nothing -- not here, so nothing to do
 		else do
-			showStart "move" file
+			showAction move file
-			return $ Just $ moveToPerform key
+			return $ Just $ toPerform move key
-moveToPerform :: Key -> SubCmdPerform
+toPerform :: Bool -> Key -> SubCmdPerform
-moveToPerform key = do
+toPerform move key = do
 	-- checking the remote is expensive, so not done in the start step
 	remote <- Remotes.commandLineRemote
 	isthere <- Remotes.inAnnex remote key
@@ -67,15 +79,15 @@ moveToPerform key = do
 			showNote $ show err
 			return Nothing
 		Right False -> do
-			showNote $ "moving to " ++ Git.repoDescribe remote ++ "..."
+			showNote $ "to " ++ Git.repoDescribe remote ++ "..."
 			let tmpfile = annexTmpLocation remote ++ keyFile key
 			ok <- Remotes.copyToRemote remote key tmpfile
 			if ok
-				then return $ Just $ moveToCleanup remote key tmpfile
+				then return $ Just $ toCleanup move remote key tmpfile
 				else return Nothing -- failed
 		Right True -> return $ Just $ Command.Drop.cleanup key
-moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup
+toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> SubCmdCleanup
-moveToCleanup remote key tmpfile = do
+toCleanup move remote key tmpfile = do
 	-- Tell remote to use the transferred content.
 	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
 		"--backend=" ++ backendName key,
@@ -83,52 +95,45 @@ moveToCleanup remote key tmpfile = do
 		tmpfile]
 	if ok
 		then do
-			-- Record that the key is present on the remote.
+			remoteHasKey remote key True
-			g <- Annex.gitRepo
+			if move
-			remoteuuid <- getUUID remote
+				then Command.Drop.cleanup key
-			logfile <- liftIO $ logChange g key remoteuuid ValuePresent
+				else return True
-			Annex.queue "add" ["--"] logfile
-			-- Cleanup on the local side is the same as done for the
-			-- drop subcommand.
-			Command.Drop.cleanup key
 		else return False
 
-{- Moves the content of an annexed file from another repository to the current
+{- Moves (or copies) the content of an annexed file from another repository
- - repository and updates locationlog information on both.
+ - to the current repository and updates locationlog information on both.
  -
  - If the current repository already has the content, it is still removed
- - from the other repository.
+ - from the other repository when moving.
  -}
-moveFromStart :: SubCmdStartString
+fromStart :: Bool -> SubCmdStartString
-moveFromStart file = isAnnexed file $ \(key, _) -> do
+fromStart move file = isAnnexed file $ \(key, _) -> do
 	remote <- Remotes.commandLineRemote
 	l <- Remotes.keyPossibilities key
 	if null $ filter (\r -> Remotes.same r remote) l
 		then return Nothing
 		else do
-			showStart "move" file
+			showAction move file
-			return $ Just $ moveFromPerform key
+			return $ Just $ fromPerform move key
-moveFromPerform :: Key -> SubCmdPerform
+fromPerform :: Bool -> Key -> SubCmdPerform
-moveFromPerform key = do
+fromPerform move key = do
 	remote <- Remotes.commandLineRemote
 	ishere <- inAnnex key
 	if ishere
-		then return $ Just $ moveFromCleanup remote key
+		then return $ Just $ fromCleanup move remote key
 		else do
-			showNote $ "moving from " ++ Git.repoDescribe remote ++ "..."
+			showNote $ "from " ++ Git.repoDescribe remote ++ "..."
 			ok <- getViaTmp key $ Remotes.copyFromRemote remote key
 			if ok
-				then return $ Just $ moveFromCleanup remote key
+				then return $ Just $ fromCleanup move remote key
 				else return Nothing -- fail
-moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup
+fromCleanup :: Bool -> Git.Repo -> Key -> SubCmdCleanup
-moveFromCleanup remote key = do
+fromCleanup True remote key = do
-	ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
+	ok <- Remotes.runCmd remote "git-annex" 
+		["dropkey", "--quiet", "--force",
 		"--backend=" ++ backendName key,
 		keyName key]
-	when ok $ do
+	remoteHasKey remote key False
-		-- Record locally that the key is not on the remote.
-		remoteuuid <- getUUID remote
-		g <- Annex.gitRepo
-		logfile <- liftIO $ logChange g key remoteuuid ValueMissing
-		Annex.queue "add" ["--"] logfile
 	return ok
+fromCleanup False _ _ = return True

debian/changelog

@@ -1,3 +1,9 @@
+git-annex (0.09) UNRELEASED; urgency=low
+
+  * Add copy subcommand.
+
+ -- Joey Hess <joeyh@debian.org>  Sat, 27 Nov 2010 16:58:33 -0400
+
 git-annex (0.08) unstable; urgency=low
 
   * Fix `git annex add ../foo` (when ran in a subdir of the repo).

doc/git-annex.mdwn

@@ -102,6 +102,14 @@ Many git-annex subcommands will stage changes for later `git commit` by you.
   When used with the --from option, moves the content of annexed files
   from the specified repository to the current one.
 
+* copy [path ...]
+
+  When used with the --to option, copies the content of annexed files from
+  the current repository to the specified one.
+
+  When used with the --from option, copies the content of annexed files
+  from the specified repository to the current one.
+
 * init description
 
   Initializes git-annex with a description of the git repository,