1 % Copyright (C) 2002-2003 David Roundy 2 % 3 % This program is free software; you can redistribute it and/or modify 4 % it under the terms of the GNU General Public License as published by 5 % the Free Software Foundation; either version 2, or (at your option) 6 % any later version. 7 % 8 % This program is distributed in the hope that it will be useful, 9 % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 % GNU General Public License for more details. 12 % 13 % You should have received a copy of the GNU General Public License 14 % along with this program; see the file COPYING. If not, write to 15 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 % Boston, MA 02110-1301, USA. 17 18 \darcsCommand{move} 19 \begin{code} 20 {-# OPTIONS_GHC -cpp #-} 21 {-# LANGUAGE CPP #-} 22 23 module Darcs.Commands.Move ( move, mv ) where 24 import Control.Monad ( when, unless, zipWithM_ ) 25 import Data.Maybe ( catMaybes ) 26 import Darcs.SignalHandler ( withSignalsBlocked ) 27 28 import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) 29 import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ), 30 fixSubPaths, working_repo_dir, 31 list_files, allow_problematic_filenames, umask_option, 32 ) 33 import Darcs.RepoPath ( toFilePath, sp2fn ) 34 import System.FilePath.Posix ( (</>), takeFileName ) 35 import System.Directory ( renameDirectory ) 36 import Workaround ( renameFile ) 37 import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, 38 slurp_pending, add_to_pending, 39 ) 40 import Darcs.Ordered ( FL(..), unsafeFL ) 41 import Darcs.Global ( debugMessage ) 42 import qualified Darcs.Patch 43 import Darcs.Patch ( RepoPatch, Prim ) 44 import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase, 45 slurp_remove, slurp_hasdir, slurp_hasfile ) 46 import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name ) 47 import qualified System.FilePath.Windows as WindowsFilePath 48 49 import Darcs.Gorsvet( invalidateIndex ) 50 #include "impossible.h" 51 52 move_description :: String 53 move_description = "Move or rename files." 54 55 move_help :: String 56 move_help = 57 "Darcs cannot reliably distinguish between a file being deleted and a\n" ++ 58 "new one added, and a file being moved. Therefore Darcs always assumes\n" ++ 59 "the former, and provides the `darcs mv' command to let Darcs know when\n" ++ 60 "you want the latter. This command will also move the file in the\n" ++ 61 "working tree (unlike `darcs remove').\n" ++ 62 "\n" ++ 63 -- Note that this paragraph is very similar to one in ./Add.lhs. 64 "Darcs will not rename a file if another file in the same folder has\n" ++ 65 "the same name, except for case. The --case-ok option overrides this\n" ++ 66 "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++ 67 "files a folder to have the same name except for case (for example,\n" ++ 68 "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++ 69 "unusable on those systems!\n" 70 71 move :: DarcsCommand 72 move = DarcsCommand {command_name = "move", 73 command_help = move_help, 74 command_description = move_description, 75 command_extra_args = -1, 76 command_extra_arg_help = ["<SOURCE> ... <DESTINATION>"], 77 command_command = move_cmd, 78 command_prereq = amInRepository, 79 command_get_arg_possibilities = list_files, 80 command_argdefaults = nodefaults, 81 command_advanced_options = [umask_option], 82 command_basic_options = [allow_problematic_filenames, working_repo_dir]} 83 move_cmd :: [DarcsFlag] -> [String] -> IO () 84 move_cmd _ [] = fail "The `darcs move' command requires at least two arguments." 85 move_cmd _ [_] = fail "The `darcs move' command requires at least two arguments." 86 87 move_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do 88 two_files <- fixSubPaths opts args 89 [old,new] <- return $ case two_files of 90 [_,_] -> two_files 91 [_] -> error "Cannot rename a file or directory onto itself!" 92 xs -> bug $ "Problem in move_cmd: " ++ show xs 93 work <- slurp "." 94 let old_fp = toFilePath old 95 new_fp = toFilePath new 96 if slurp_hasdir (sp2fn new) work && slurp_has old_fp work 97 then move_to_dir repository opts [old_fp] new_fp 98 else do 99 cur <- slurp_pending repository 100 addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp) 101 invalidateIndex repository 102 withSignalsBlocked $ do 103 case addpatch of 104 Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL) 105 Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL) 106 move_file_or_dir work old_fp new_fp 107 108 move_cmd opts args = 109 withRepoLock opts $- \repository -> do 110 relpaths <- map toFilePath `fmap` fixSubPaths opts args 111 let moved = init relpaths 112 finaldir = last relpaths 113 move_to_dir repository opts moved finaldir 114 115 move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO () 116 move_to_dir repository opts moved finaldir = 117 let movefns = map takeFileName moved 118 movetargets = map (finaldir </>) movefns 119 movepatches = zipWith Darcs.Patch.move moved movetargets 120 in do 121 cur <- slurp_pending repository 122 work <- slurp "." 123 addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets 124 invalidateIndex repository 125 withSignalsBlocked $ do 126 add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches 127 zipWithM_ (move_file_or_dir work) moved movetargets 128 129 check_new_and_old_filenames 130 :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim) 131 check_new_and_old_filenames opts cur work (old,new) = do 132 unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $ 133 fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++ 134 "Use --reserved-ok to allow such filenames." 135 maybe_add_file_thats_been_moved <- 136 if slurp_has old work -- We need to move the object 137 then do unless (slurp_hasdir (super_name $ fp2fn new) work) $ 138 fail $ "The target directory " ++ 139 (fn2fp $ super_name $ fp2fn new)++ 140 " isn't known in working directory, did you forget to add it?" 141 when (it_has new work) $ fail $ already_exists "working directory" 142 return Nothing 143 else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory" 144 return $ Just $ Darcs.Patch.addfile old 145 if slurp_has old cur 146 then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $ 147 fail $ "The target directory " ++ 148 (fn2fp $ super_name $ fp2fn new)++ 149 " isn't known in working directory, did you forget to add it?" 150 when (it_has new cur) $ fail $ already_exists "repository" 151 else fail $ doesnt_exist "repository" 152 return maybe_add_file_thats_been_moved 153 where it_has f s = 154 let ms2 = slurp_remove (fp2fn old) s 155 in case ms2 of 156 Nothing -> False 157 Just s2 -> if AllowCaseOnly `elem` opts 158 then slurp_has f s2 159 else slurp_has_anycase f s2 160 already_exists what_slurpy = 161 if AllowCaseOnly `elem` opts 162 then "A file or dir named "++new++" already exists in " 163 ++ what_slurpy ++ "." 164 else "A file or dir named "++new++" (or perhaps differing"++ 165 " only in case)\nalready exists in "++ 166 what_slurpy ++ ".\n"++ 167 "Use --case-ok to allow files differing only in case." 168 doesnt_exist what_slurpy = 169 "There is no file or dir named " ++ old ++ 170 " in the "++ what_slurpy ++ "." 171 172 move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO () 173 move_file_or_dir work old new = 174 if slurp_hasfile (fp2fn old) work 175 then do debugMessage $ unwords ["renameFile",old,new] 176 renameFile old new 177 else if slurp_hasdir (fp2fn old) work 178 then do debugMessage $ unwords ["renameDirectory",old,new] 179 renameDirectory old new 180 else return () 181 182 mv :: DarcsCommand 183 mv = command_alias "mv" move 184 \end{code} 185 186