% Copyright (C) 20022003 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 021101301, USA.
\subsection{darcs mv}
\begin{code}
module Darcs.Commands.Mv ( mv, move ) where
import Control.Monad ( when, unless )
import Data.Maybe ( catMaybes )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ),
fixSubPaths, working_repo_dir,
list_files, allow_problematic_filenames, umask_option,
)
import Darcs.RepoPath ( toFilePath, sp2fn )
import System.FilePath.Posix ( (</>), takeFileName )
import System.Directory ( renameDirectory )
import Workaround ( renameFile )
import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,
slurp_pending, add_to_pending,
)
import Darcs.Ordered ( FL(..), unsafeFL )
import Darcs.Global ( debugMessage )
import qualified Darcs.Patch
import Darcs.Patch ( RepoPatch, Prim )
import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase,
slurp_remove, slurp_hasdir, slurp_hasfile )
import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name )
import qualified System.FilePath.Windows as WindowsFilePath
#include "impossible.h"
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''.
\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!--caseok!.
\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"
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_advanced_options = [umask_option],
command_basic_options = [allow_problematic_filenames, 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"
mv_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do
two_files <- fixSubPaths opts args
[old,new] <- return $ case two_files of
[_,_] -> two_files
[_] -> error "Cannot rename a file or directory onto itself!"
xs -> bug $ "Problem in mv_cmd: " ++ show xs
work <- slurp "."
let old_fp = toFilePath old
new_fp = toFilePath new
if slurp_hasdir (sp2fn new) work && slurp_has old_fp work
then move_to_dir repository opts [old_fp] new_fp
else do
cur <- slurp_pending repository
addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp)
withSignalsBlocked $ do
case addpatch of
Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)
Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)
move_file_or_dir work old_fp new_fp
mv_cmd opts args =
withRepoLock opts $- \repository -> do
relpaths <- map toFilePath `fmap` fixSubPaths opts args
let moved = init relpaths
finaldir = last relpaths
move_to_dir repository opts moved finaldir
move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()
move_to_dir repository opts moved finaldir =
let movefns = map takeFileName moved
movetargets = map (finaldir </>) movefns
movepatches = zipWith Darcs.Patch.move moved movetargets
in do
cur <- slurp_pending repository
work <- slurp "."
addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets
withSignalsBlocked $ do
add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches
sequence_ $ zipWith (move_file_or_dir work) moved movetargets
check_new_and_old_filenames
:: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim)
check_new_and_old_filenames opts cur work (old,new) = do
unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $
fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++
"Use --reserved-ok to allow such filenames."
maybe_add_file_thats_been_moved <-
if slurp_has old work
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"
return Nothing
else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory"
return $ Just $ Darcs.Patch.addfile old
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"
return maybe_add_file_thats_been_moved
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 do debugMessage $ unwords ["renameFile",old,new]
renameFile old new
else if slurp_hasdir (fp2fn old) work
then do debugMessage $ unwords ["renameDirectory",old,new]
renameDirectory old new
else return ()
\end{code}
% move Note: not a subsection because not to be documented.
\begin{code}
move_description :: String
move_description =
"Alias for 'mv'"
move_help :: String
move_help =
"Alias for 'mv'\n" ++ mv_help
move :: DarcsCommand
move = mv {command_name = "move",
command_help = move_help,
command_description = move_description }
\end{code}