-- Copyright (C) 2002,2003,2005 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. module Darcs.RunCommand ( run_the_command ) where import Control.Monad ( unless, when ) import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ), OptDescr( Option ), getOpt ) import System.Exit ( ExitCode ( ExitSuccess ), exitWith ) import Darcs.Arguments ( DarcsFlag(..), help, option_from_darcsoption, list_options ) import Darcs.ArgumentDefaults ( get_default_flags ) import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ), DarcsCommand, command_name, command_command, command_prereq, command_extra_arg_help, command_extra_args, command_argdefaults, command_get_arg_possibilities, command_options, command_alloptions, disambiguate_commands, get_command_help, get_command_mini_help, get_subcommands, extract_commands, super_name, subusage, chomp_newline ) import Darcs.Commands.Help ( command_control_list ) import Darcs.External ( viewDoc ) import Darcs.Global ( setDebugMode, setSshControlMasterDisabled, setTimingsMode, setVerboseMode ) import Darcs.Match ( checkMatchSyntax ) import Darcs.Progress ( setProgressMode ) import Darcs.RepoPath ( getCurrentDirectory ) import Darcs.Test ( run_posthook, run_prehook ) import Darcs.Utils ( formatPath ) import Printer ( text ) import URL ( setDebugHTTP, setHTTPPipelining ) run_the_command :: String -> [String] -> IO () run_the_command cmd args = either fail rtc $ disambiguate_commands command_control_list cmd args where rtc (CommandOnly c, as) = run_command Nothing c as rtc (SuperCommandOnly c, as) = run_raw_supercommand c as rtc (SuperCommandSub c s, as) = run_command (Just c) s as -- This is the actual heavy lifter code, which is responsible for parsing the -- arguments and then running the command itself. run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO () run_command _ _ args -- Check for "dangerous" typoes... | "-all" `elem` args = -- -all indicates --all --look-for-adds! fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?" run_command msuper cmd args = do cwd <- getCurrentDirectory let options = opts1 ++ opts2 (opts1, opts2) = command_options cwd cmd case getOpt Permute (option_from_darcsoption cwd list_options++options) args of (opts,extra,[]) | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd | ListOptions `elem` opts -> do setProgressMode False command_prereq cmd opts file_args <- command_get_arg_possibilities cmd putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs) where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts | otherwise = opts consider_running :: Maybe DarcsCommand -> DarcsCommand -> [DarcsFlag] -> [String] -> IO () consider_running msuper cmd opts old_extra = do cwd <- getCurrentDirectory location <- command_prereq cmd opts case location of Left complaint -> fail $ "Unable to " ++ formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++ " here.\n\n" ++ complaint Right () -> do specops <- add_command_defaults cmd opts extra <- (command_argdefaults cmd) specops cwd old_extra when (Disable `elem` specops) $ fail $ "Command "++command_name cmd++" disabled with --disable option!" if command_extra_args cmd < 0 then runWithHooks specops extra else if length extra > command_extra_args cmd then fail $ "Bad argument: `"++unwords extra++"'\n"++ get_command_mini_help msuper cmd else if length extra < command_extra_args cmd then fail $ "Missing argument: " ++ nth_arg (length extra + 1) ++ "\n" ++ get_command_mini_help msuper cmd else runWithHooks specops extra where nth_arg n = nth_of n (command_extra_arg_help cmd) nth_of 1 (h:_) = h nth_of n (_:hs) = nth_of (n-1) hs nth_of _ [] = "UNDOCUMENTED" runWithHooks os ex = do here <- getCurrentDirectory checkMatchSyntax os -- set any global variables when (Timings `elem` os) setTimingsMode when (Debug `elem` os) setDebugMode when (DebugHTTP `elem` os) setDebugHTTP when (Verbose `elem` os) setVerboseMode when (Quiet `elem` os) $ setProgressMode False when (HTTPPipelining `elem` os) $ setHTTPPipelining True when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False unless (SSHControlMaster `elem` os) setSshControlMasterDisabled -- actually run the command and its hooks preHookExitCode <- run_prehook os here if preHookExitCode /= ExitSuccess then exitWith preHookExitCode else do let fixFlag = FixFilePath here cwd (command_command cmd) (fixFlag : os) ex postHookExitCode <- run_posthook os here exitWith postHookExitCode add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] add_command_defaults cmd already = do let (opts1, opts2) = command_alloptions cmd defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already return $ already ++ defaults get_options_options :: [OptDescr DarcsFlag] -> String get_options_options [] = "" get_options_options (o:os) = get_long_option o ++"\n"++ get_options_options os get_long_option :: OptDescr DarcsFlag -> String get_long_option (Option _ [] _ _) = "" get_long_option (Option a (o:os) b c) = "--"++o++ get_long_option (Option a os b c) run_raw_supercommand :: DarcsCommand -> [String] -> IO () run_raw_supercommand super [] = fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n" ++ subusage super run_raw_supercommand super args = do cwd <- getCurrentDirectory case getOpt RequireOrder (option_from_darcsoption cwd help++ option_from_darcsoption cwd list_options) args of (opts,_,[]) | Help `elem` opts -> viewDoc $ text $ get_command_help Nothing super | ListOptions `elem` opts -> do putStrLn "--help" mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super) | otherwise -> if Disable `elem` opts then fail $ "Command " ++ (command_name super) ++ " disabled with --disable option!" else fail $ "Invalid subcommand!\n\n" ++ subusage super (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)