% 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; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \subsection{darcs mv} \begin{code} module Mv ( mv ) where import Monad ( when, unless ) import SignalHandler ( withSignalsBlocked ) import DarcsCommands ( DarcsCommand(..), nodefaults ) import DarcsArguments ( DarcsFlag( AllowCaseOnly ), verbose, fix_filepaths_wrt, working_repo_dir, list_files, allow_caseonly, umask_option, ) import FilePathUtils ( (///) ) import Directory ( renameDirectory ) import Workaround ( renameFile ) import Repository ( identifyRepository, withRepoLock, amInRepository, slurp_pending, add_to_pending, ) import Patch ( join_patches, move ) import SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase, slurp_remove, slurp_hasdir, slurp_hasfile ) import FileName ( fp2fn, fn2fp, super_name ) #include "impossible.h" \end{code} \begin{code} mv_description :: String mv_description = "Move/rename one or more files or directories." \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. \begin{options} --case-ok \end{options} 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 Apple's 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 move files or\n"++ "directories. Unlike remove, mv actually performs the move itself in your\n"++ "working copy.\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 = ["[FILE or DIRECTORY]..."], command_command = mv_cmd, command_prereq = amInRepository, command_get_arg_possibilities = list_files, command_argdefaults = nodefaults, command_darcsoptions = [allow_caseonly, verbose, working_repo_dir, umask_option]} 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 args@[_,_] = withRepoLock opts $ \repository -> do (old:new:_) <- fix_filepaths_wrt "." opts args work <- slurp "." if slurp_hasdir (fp2fn new) work && slurp_has old work then move_to_dir opts [old] new else do cur <- slurp_pending repository check_new_and_old_filenames opts cur work (old,new) withSignalsBlocked $ do move_file_or_dir work old new add_to_pending repository (move old new) \end{code} \begin{code} mv_cmd opts args = withRepoLock opts $ \_ -> do relpaths <- fix_filepaths_wrt "." opts args let moved = init relpaths finaldir = last relpaths 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 repository <- identifyRepository "." cur <- slurp_pending repository work <- slurp "." mapM_ (check_new_and_old_filenames opts cur work) $ zip moved movetargets withSignalsBlocked $ do sequence_ $ map2 (move_file_or_dir work) moved movetargets add_to_pending repository (join_patches 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)++ " isn't known in working directory, did you forget to add it?" 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)++ " isn't known in working directory, did you forget to add it?" when (it_has new cur) $ fail $ already_exists "repository" else fail $ doesnt_exist "repository" where it_has f s = let ms2 = slurp_remove (fp2fn old) s in case ms2 of Nothing -> False Just s2 -> if AllowCaseOnly `elem` opts then slurp_has f s2 else slurp_has_anycase f s2 already_exists what_slurpy = if AllowCaseOnly `elem` opts then "A file or dir named "++new++" already exists in " ++ what_slurpy ++ "." else "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." 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}