% Copyright (C) 2002-2003 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; if not, write to the Free Software Foundation, % Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. \section{darcs mv} \begin{code} module Mv ( mv ) where import Monad ( when, unless ) import Control.Exception ( block ) import DarcsCommands ( DarcsCommand(..), nodefaults ) import DarcsArguments ( DarcsFlag( AllowCaseOnly ), verbose, fix_filepath, (///), working_repo_dir, list_files, allow_caseonly, ) import Directory ( renameDirectory ) import Workaround ( renameFile ) import Repository ( slurp_pending, write_pending, am_in_repo, read_pending ) import Patch ( join_patches, flatten, move ) import SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_hasdir, slurp_hasfile, slurp_has_anycase ) import FileName ( fp2fn, fn2fp, super_name ) import Lock ( withLock ) #include "impossible.h" \end{code} \begin{code} mv_description :: String mv_description = "Move a file or directory to a different location or name.\n" \end{code} \options{mv} \haskell{mv_help} This is why ``mv'' isn't called ``move'', since it is really almost equivalent to the unix command ``mv''. I could add an equivalent command named ``move'' for those who like vowels. Darcs mv will by default refuse to rename a file if there already exists a file having the same name apart from case. This is because doing so could create a repository that could not be used on file systems that are case insensitive (such as Apples HFS+). You can override this by with the flag \verb!--case-ok!. \begin{code} mv_help :: String mv_help = "Darcs mv needs to be called whenever you want to rename or move a file or\n"++ "directory. Unlike remove, mv actually performs the move itself in your\n"++ "working directory.\n" \end{code} \begin{code} mv :: DarcsCommand mv = DarcsCommand {command_name = "mv", command_help = mv_help, command_description = mv_description, command_extra_args = -1, command_extra_arg_help = [" ..."], command_command = mv_cmd, command_prereq = am_in_repo, command_get_arg_possibilities = list_files, command_argdefaults = nodefaults, command_darcsoptions = [allow_caseonly, verbose, working_repo_dir]} mv_cmd :: [DarcsFlag] -> [String] -> IO () mv_cmd _ [] = fail "You must specify at least two arguments for mv" mv_cmd _ [_] = fail "You must specify at least two arguments for mv" \end{code} \begin{code} mv_cmd opts [relold,relnew] = let old = fix_filepath opts relold new = fix_filepath opts relnew in withLock "./_darcs/lock" $ do work <- slurp "." if slurp_hasdir (fp2fn new) work && slurp_has old work then move_to_dir opts [old] new else do cur <- slurp_pending "." pend <- read_pending check_new_and_old_filenames opts cur work (old,new) block $ do move_file_or_dir work old new case pend of Nothing -> write_pending $ move old new Just op -> write_pending $ join_patches $ flatten $ join_patches [op, move old new] \end{code} \begin{code} mv_cmd opts relpaths = let moved = reverse $ map (fix_filepath opts) $ tail $ reverse relpaths finaldir = fix_filepath opts $ head $ reverse relpaths in withLock "./_darcs/lock" $ move_to_dir opts moved finaldir move_to_dir :: [DarcsFlag] -> [FilePath] -> FilePath -> IO () move_to_dir opts moved finaldir = let movefns = map (reverse.takeWhile (/='/').reverse) moved movetargets = map (finaldir///) movefns movepatches = map2 move moved movetargets in do cur <- slurp_pending "." work <- slurp "." pend <- read_pending mapM_ (check_new_and_old_filenames opts cur work) $ zip moved movetargets block $ do sequence_ $ map2 (move_file_or_dir work) moved movetargets case pend of Nothing -> write_pending $ join_patches movepatches Just op -> write_pending $ join_patches $ flatten $ join_patches (op: movepatches) check_new_and_old_filenames :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO () check_new_and_old_filenames opts cur work (old,new) = do if slurp_has old work -- We need to move the object then do unless (slurp_hasdir (super_name $ fp2fn new) work) $ fail $ "The target directory " ++ (fn2fp $ super_name $ fp2fn new)++ " doesn't exist in working directory." when (it_has new work) $ fail $ already_exists "working directory" else unless (slurp_has new work) $ fail $ doesnt_exist "working directory" if slurp_has old cur then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $ fail $ "The target directory " ++ (fn2fp $ super_name $ fp2fn new)++ " doesn't exist in working directory." when (it_has new cur) $ fail $ already_exists "repository" else fail $ doesnt_exist "repository" where it_has = if AllowCaseOnly `elem` opts then slurp_has else slurp_has_anycase already_exists what_slurpy = if AllowCaseOnly `elem` opts then "A file or dir named "++new++" (or perhaps differing"++ " only in case)\nalready exists in "++ what_slurpy ++ ".\n"++ "Use --case-ok to allow files differing only in case." else "A file or dir named "++new++" already exists in " ++ what_slurpy ++ "." doesnt_exist what_slurpy = "There is no file or dir named " ++ old ++ " in the "++ what_slurpy ++ "." move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO () move_file_or_dir work old new = if slurp_hasfile (fp2fn old) work then renameFile old new else if slurp_hasdir (fp2fn old) work then renameDirectory old new else return () map2 :: (a -> b -> c) -> [a] -> [b] -> [c] map2 _ [] [] = [] map2 f (a:as) (b:bs) = f a b : map2 f as bs map2 _ _ _ = bug "map2 in mv given lists of differing lengths!" \end{code}