src/Darcs/Commands/Mv.lhs

   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 \subsection{darcs mv}
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 module Darcs.Commands.Mv ( mv, move ) where
  24 import Control.Monad ( when, unless )
  25 import Data.Maybe ( catMaybes )
  26 import Darcs.SignalHandler ( withSignalsBlocked )
  27
  28 import Darcs.Commands ( DarcsCommand(..), nodefaults )
  29 import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ),
  30                          fixSubPaths, working_repo_dir,
  31                         list_files, allow_problematic_filenames, umask_option,
  32                       )
  33 import Darcs.FilePathUtils ( (///) )
  34 import Darcs.RepoPath ( toFilePath, sp2fn )
  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 #include "impossible.h"
  49 \end{code}
  50
  51 \begin{code}
  52 mv_description :: String
  53 mv_description =
  54  "Move/rename one or more files or directories."
  55 \end{code}
  56
  57 \options{mv}
  58
  59 \haskell{mv_help} This is why ``mv'' isn't called ``move'', since it is
  60 really almost equivalent to the unix command ``mv''.
  61
  62 \begin{options}
  63 --case-ok
  64 \end{options}
  65
  66 Darcs mv will by default refuse to rename a file if there already exists a
  67 file having the same name apart from case.  This is because doing so could
  68 create a repository that could not be used on file systems that are case
  69 insensitive (such as Apple's HFS+).  You can override this by with the flag
  70 \verb!--case-ok!.
  71
  72 \begin{code}
  73 mv_help :: String
  74 mv_help =
  75  "Darcs mv needs to be called whenever you want to move files or\n"++
  76  "directories. Unlike remove, mv actually performs the move itself in your\n"++
  77  "working copy.\n"
  78 \end{code}
  79
  80 \begin{code}
  81 mv :: DarcsCommand
  82 mv = DarcsCommand {command_name = "mv",
  83                    command_help = mv_help,
  84                    command_description = mv_description,
  85                    command_extra_args = -1,
  86                    command_extra_arg_help = ["[FILE or DIRECTORY]..."],
  87                    command_command = mv_cmd,
  88                    command_prereq = amInRepository,
  89                    command_get_arg_possibilities = list_files,
  90                    command_argdefaults = nodefaults,
  91                    command_advanced_options = [umask_option],
  92                    command_basic_options = [allow_problematic_filenames, working_repo_dir]}
  93 mv_cmd :: [DarcsFlag] -> [String] -> IO ()
  94 mv_cmd _ [] = fail "You must specify at least two arguments for mv"
  95 mv_cmd _ [_] = fail "You must specify at least two arguments for mv"
  96 \end{code}
  97
  98 \begin{code}
  99 mv_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do
 100   two_files <- fixSubPaths opts args
 101   [old,new] <- return $ case two_files of
 102                         [_,_] -> two_files
 103                         [_] -> error "Cannot rename a file or directory onto itself!"
 104                         xs -> bug $ "Problem in mv_cmd: " ++ show xs
 105   work <- slurp "."
 106   let old_fp = toFilePath old
 107       new_fp = toFilePath new
 108   if slurp_hasdir (sp2fn new) work && slurp_has old_fp work
 109    then move_to_dir repository opts [old_fp] new_fp
 110    else do
 111     cur <- slurp_pending repository
 112     addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp)
 113     withSignalsBlocked $ do
 114       case addpatch of
 115         Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)
 116         Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)
 117       move_file_or_dir work old_fp new_fp
 118 \end{code}
 119
 120 \begin{code}
 121 mv_cmd opts args =
 122    withRepoLock opts $- \repository -> do
 123      relpaths <- map toFilePath `fmap` fixSubPaths opts args
 124      let moved = init relpaths
 125          finaldir = last relpaths
 126      move_to_dir repository opts moved finaldir
 127
 128 move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()
 129 move_to_dir repository opts moved finaldir =
 130   let movefns = map (reverse.takeWhile (/='/').reverse) moved
 131       movetargets = map (finaldir///) movefns
 132       movepatches = zipWith Darcs.Patch.move moved movetargets
 133   in do
 134     cur <- slurp_pending repository
 135     work <- slurp "."
 136     addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets
 137     withSignalsBlocked $ do
 138       add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches
 139       sequence_ $ zipWith (move_file_or_dir work) moved movetargets
 140
 141 check_new_and_old_filenames
 142     :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim)
 143 check_new_and_old_filenames opts cur work (old,new) = do
 144   unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $
 145      fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++
 146             "Use --reserved-ok to allow such filenames."
 147   maybe_add_file_thats_been_moved <-
 148      if slurp_has old work -- We need to move the object
 149      then do unless (slurp_hasdir (super_name $ fp2fn new) work) $
 150                     fail $ "The target directory " ++
 151                              (fn2fp $ super_name $ fp2fn new)++
 152                              " isn't known in working directory, did you forget to add it?"
 153              when (it_has new work) $ fail $ already_exists "working directory"
 154              return Nothing
 155      else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory"
 156              return $ Just $ Darcs.Patch.addfile old
 157   if slurp_has old cur
 158      then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $
 159                     fail $ "The target directory " ++
 160                              (fn2fp $ super_name $ fp2fn new)++
 161                              " isn't known in working directory, did you forget to add it?"
 162              when (it_has new cur) $ fail $ already_exists "repository"
 163      else fail $ doesnt_exist "repository"
 164   return maybe_add_file_thats_been_moved
 165     where it_has f s =
 166             let ms2 = slurp_remove (fp2fn old) s
 167             in case ms2 of
 168                Nothing -> False
 169                Just s2 -> if AllowCaseOnly `elem` opts
 170                           then slurp_has f s2
 171                           else slurp_has_anycase f s2
 172           already_exists what_slurpy =
 173               if AllowCaseOnly `elem` opts
 174               then "A file or dir named "++new++" already exists in "
 175                        ++ what_slurpy ++ "."
 176               else "A file or dir named "++new++" (or perhaps differing"++
 177                        " only in case)\nalready exists in "++
 178                        what_slurpy ++ ".\n"++
 179                    "Use --case-ok to allow files differing only in case."
 180           doesnt_exist what_slurpy =
 181               "There is no file or dir named " ++ old ++
 182               " in the "++ what_slurpy ++ "."
 183
 184 move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO ()
 185 move_file_or_dir work old new =
 186     if slurp_hasfile (fp2fn old) work
 187        then do debugMessage $ unwords ["renameFile",old,new]
 188                renameFile old new
 189        else if slurp_hasdir (fp2fn old) work
 190             then do debugMessage $ unwords ["renameDirectory",old,new]
 191                     renameDirectory old new
 192             else return ()
 193 \end{code}
 194
 195
 196 % move - Note: not a subsection because not to be documented.
 197
 198 \begin{code}
 199 move_description :: String
 200 move_description =
 201  "Alias for 'mv'"
 202
 203 move_help :: String
 204 move_help =
 205  "Alias for 'mv'\n" ++ mv_help
 206
 207 move :: DarcsCommand
 208 move = mv {command_name = "move",
 209            command_help = move_help,
 210            command_description = move_description }
 211 \end{code}
 212
 213