1 -- Copyright (C) 2002,2003,2005 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 {-# LANGUAGE CPP #-} 19 module Darcs.RunCommand ( run_the_command ) where 20 21 import Control.Monad ( unless, when ) 22 import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ), 23 OptDescr( Option ), 24 getOpt ) 25 import System.Exit ( ExitCode ( ExitSuccess ), exitWith ) 26 27 import Darcs.Arguments ( DarcsFlag(..), 28 help, 29 option_from_darcsoption, 30 list_options ) 31 import Darcs.ArgumentDefaults ( get_default_flags ) 32 import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ), 33 DarcsCommand, 34 command_name, 35 command_command, 36 command_prereq, 37 command_extra_arg_help, 38 command_extra_args, 39 command_argdefaults, 40 command_get_arg_possibilities, 41 command_options, command_alloptions, 42 disambiguate_commands, 43 get_command_help, get_command_mini_help, 44 get_subcommands, 45 extract_commands, 46 super_name, 47 subusage, chomp_newline ) 48 import Darcs.Commands.GZCRCs ( doCRCWarnings ) 49 import Darcs.Global ( atexit ) 50 import Darcs.Commands.Help ( command_control_list ) 51 import Darcs.External ( viewDoc ) 52 import Darcs.Global ( setDebugMode, setSshControlMasterDisabled, 53 setTimingsMode, setVerboseMode ) 54 import Darcs.Match ( checkMatchSyntax ) 55 import Progress ( setProgressMode ) 56 import Darcs.RepoPath ( getCurrentDirectory ) 57 import Darcs.Test ( run_posthook, run_prehook ) 58 import Darcs.Utils ( formatPath ) 59 import Printer ( text ) 60 import URL ( setDebugHTTP, setHTTPPipelining ) 61 62 run_the_command :: String -> [String] -> IO () 63 run_the_command cmd args = 64 either fail rtc $ disambiguate_commands command_control_list cmd args 65 where 66 rtc (CommandOnly c, as) = run_command Nothing c as 67 rtc (SuperCommandOnly c, as) = run_raw_supercommand c as 68 rtc (SuperCommandSub c s, as) = run_command (Just c) s as 69 70 -- This is the actual heavy lifter code, which is responsible for parsing the 71 -- arguments and then running the command itself. 72 73 run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO () 74 75 run_command _ _ args -- Check for "dangerous" typoes... 76 | "-all" `elem` args = -- -all indicates --all --look-for-adds! 77 fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?" 78 run_command msuper cmd args = do 79 cwd <- getCurrentDirectory 80 let options = opts1 ++ opts2 81 (opts1, opts2) = command_options cwd cmd 82 case getOpt Permute 83 (option_from_darcsoption cwd list_options++options) args of 84 (opts,extra,[]) 85 | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd 86 | ListOptions `elem` opts -> do 87 setProgressMode False 88 command_prereq cmd opts 89 file_args <- command_get_arg_possibilities cmd 90 putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args 91 | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra 92 (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs) 93 where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts 94 | otherwise = opts 95 96 consider_running :: Maybe DarcsCommand -> DarcsCommand 97 -> [DarcsFlag] -> [String] -> IO () 98 consider_running msuper cmd opts old_extra = do 99 cwd <- getCurrentDirectory 100 location <- command_prereq cmd opts 101 case location of 102 Left complaint -> fail $ "Unable to " ++ 103 formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++ 104 " here.\n\n" ++ complaint 105 Right () -> do 106 specops <- add_command_defaults cmd opts 107 extra <- (command_argdefaults cmd) specops cwd old_extra 108 when (Disable `elem` specops) $ 109 fail $ "Command "++command_name cmd++" disabled with --disable option!" 110 if command_extra_args cmd < 0 111 then runWithHooks specops extra 112 else if length extra > command_extra_args cmd 113 then fail $ "Bad argument: `"++unwords extra++"'\n"++ 114 get_command_mini_help msuper cmd 115 else if length extra < command_extra_args cmd 116 then fail $ "Missing argument: " ++ 117 nth_arg (length extra + 1) ++ 118 "\n" ++ get_command_mini_help msuper cmd 119 else runWithHooks specops extra 120 where nth_arg n = nth_of n (command_extra_arg_help cmd) 121 nth_of 1 (h:_) = h 122 nth_of n (_:hs) = nth_of (n-1) hs 123 nth_of _ [] = "UNDOCUMENTED" 124 runWithHooks os ex = do 125 here <- getCurrentDirectory 126 checkMatchSyntax os 127 -- set any global variables 128 when (Timings `elem` os) setTimingsMode 129 when (Debug `elem` os) setDebugMode 130 when (DebugHTTP `elem` os) setDebugHTTP 131 when (Verbose `elem` os) setVerboseMode 132 when (Quiet `elem` os) $ setProgressMode False 133 when (HTTPPipelining `elem` os) $ setHTTPPipelining True 134 when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False 135 unless (SSHControlMaster `elem` os) setSshControlMasterDisabled 136 unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os) 137 -- actually run the command and its hooks 138 preHookExitCode <- run_prehook os here 139 if preHookExitCode /= ExitSuccess 140 then exitWith preHookExitCode 141 else do let fixFlag = FixFilePath here cwd 142 (command_command cmd) (fixFlag : os) ex 143 postHookExitCode <- run_posthook os here 144 exitWith postHookExitCode 145 146 add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] 147 add_command_defaults cmd already = do 148 let (opts1, opts2) = command_alloptions cmd 149 defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already 150 return $ already ++ defaults 151 152 get_options_options :: [OptDescr DarcsFlag] -> String 153 get_options_options [] = "" 154 get_options_options (o:os) = 155 get_long_option o ++"\n"++ get_options_options os 156 157 get_long_option :: OptDescr DarcsFlag -> String 158 get_long_option (Option _ [] _ _) = "" 159 get_long_option (Option a (o:os) b c) = "--"++o++ 160 get_long_option (Option a os b c) 161 162 run_raw_supercommand :: DarcsCommand -> [String] -> IO () 163 run_raw_supercommand super [] = 164 fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n" 165 ++ subusage super 166 run_raw_supercommand super args = do 167 cwd <- getCurrentDirectory 168 case getOpt RequireOrder 169 (option_from_darcsoption cwd help++ 170 option_from_darcsoption cwd list_options) args of 171 (opts,_,[]) 172 | Help `elem` opts -> 173 viewDoc $ text $ get_command_help Nothing super 174 | ListOptions `elem` opts -> do 175 putStrLn "--help" 176 mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super) 177 | otherwise -> 178 if Disable `elem` opts 179 then fail $ "Command " ++ (command_name super) ++ 180 " disabled with --disable option!" 181 else fail $ "Invalid subcommand!\n\n" ++ subusage super 182 (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)