diff --git a/Distribution/ShellHarness.hs b/Distribution/ShellHarness.hs --- a/Distribution/ShellHarness.hs +++ b/Distribution/ShellHarness.hs @@ -2,8 +2,10 @@ module Distribution.ShellHarness ( runTests ) where import Prelude hiding( catch ) -import System.Directory ( getCurrentDirectory, setPermissions, - Permissions(..), getDirectoryContents, +import System.Directory ( getCurrentDirectory, + getPermissions, setPermissions, + readable, writable, executable, searchable, + getDirectoryContents, findExecutable, createDirectoryIfMissing, renameFile, removeFile ) import System.Environment ( getEnv, getEnvironment ) @@ -110,8 +112,9 @@ system $ "hpc sum --union --output=" ++ tixdir "sum.tix" ++ " " ++ unwords tixfiles forM tixfiles $ \f -> removeFile f return () - mapM_ (\x-> - setPermissions x (Permissions + mapM_ (\x-> do + p <- getPermissions x + setPermissions x (p {readable = True ,writable = True ,executable = False diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.5 +version: 2.5.1 License: GPL License-file: COPYING Author: David Roundy , @@ -124,6 +124,8 @@ else buildable: True + build-tools: ghc >= 6.10 && < 7.2 + hs-source-dirs: src include-dirs: src cpp-options: -DGADT_WITNESSES=1 @@ -137,17 +139,23 @@ -- if not mentioned other-modules: Darcs.Test.Patch.Check - extensions: - CPP - PatternGuards - UndecidableInstances - ScopedTypeVariables - -- PatternSignatures is needed for GHC 6.8 - PatternSignatures - RankNTypes - GADTs - TypeOperators + if true + extensions: + CPP + ForeignFunctionInterface + PatternGuards + UndecidableInstances + ScopedTypeVariables + -- PatternSignatures is needed for GHC 6.8 + PatternSignatures + RankNTypes + GADTs + TypeOperators + if impl(ghc>=7.0) + extensions: + NoMonoLocalBinds + if os(windows) hs-source-dirs: src/win32 include-dirs: src/win32 @@ -163,19 +171,19 @@ build-depends: base < 5, extensible-exceptions >= 0.1 && < 0.2, regex-compat >= 0.71 && < 0.94, - mtl >= 1.0 && < 1.2, + mtl >= 1.0 && < 2.1, parsec >= 2.0 && < 3.1, html == 1.0.*, - filepath == 1.1.*, + filepath >= 1.1.0.0 && < 1.3.0.0, haskeline >= 0.6.2.2 && < 0.7, hashed-storage >= 0.5.2 && < 0.6, base >= 3, bytestring >= 0.9.0 && < 0.10, - text >= 0.3, + text == 0.11.*, old-time == 1.0.*, - directory == 1.0.*, + directory >= 1.0.0.0 && < 1.2.0.0, process == 1.0.*, - containers >= 0.1 && < 0.4, + containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, random == 1.0.*, tar == 0.3.*, @@ -186,8 +194,8 @@ if !os(windows) build-depends: unix >= 1.0 && < 2.5 if flag(http) - build-depends: network == 2.2.*, - HTTP >= 3000.0 && < 4000.1 + build-depends: network >= 2.2 && < 2.4, + HTTP >= 3000.0 && < 4000.2 -- ---------------------------------------------------------------------- @@ -200,6 +208,8 @@ else buildable: True + build-tools: ghc >= 6.10 && < 7.2 + hs-source-dirs: src include-dirs: src @@ -356,6 +366,7 @@ System.Posix.Files System.Posix.IO cpp-options: -DWIN32 + c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2, regex-posix >= 0.94.4 && < 0.95 @@ -365,10 +376,10 @@ build-depends: base < 5, extensible-exceptions >= 0.1 && < 0.2, regex-compat >= 0.71 && < 0.94, - mtl >= 1.0 && < 1.2, + mtl >= 1.0 && < 2.1, parsec >= 2.0 && < 3.1, html == 1.0.*, - filepath == 1.1.*, + filepath >= 1.1.0.0 && < 1.3.0.0, haskeline >= 0.6.2.2 && < 0.7, hashed-storage >= 0.5.2 && < 0.6, tar == 0.3.* @@ -378,11 +389,11 @@ build-depends: base >= 3, bytestring >= 0.9.0 && < 0.10, - text >= 0.3, + text == 0.11.*, old-time == 1.0.*, - directory == 1.0.*, + directory >= 1.0.0.0 && < 1.2.0.0, process == 1.0.*, - containers >= 0.1 && < 0.4, + containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, random == 1.0.* @@ -408,8 +419,8 @@ cc-options: -DHAVE_CURL if flag(http) - build-depends: network == 2.2.*, - HTTP >= 3000.0 && < 4000.1 + build-depends: network >= 2.2 && < 2.4, + HTTP >= 3000.0 && < 4000.2 cpp-options: -DHAVE_HTTP x-have-http: @@ -430,29 +441,34 @@ if flag(color) x-use-color: - extensions: - CPP, - ForeignFunctionInterface, - BangPatterns, - PatternGuards, - MagicHash, - UndecidableInstances, - DeriveDataTypeable, - GADTs, - TypeOperators, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - ScopedTypeVariables, - -- PatternSignatures is needed for GHC 6.8 - PatternSignatures, - KindSignatures, - TypeSynonymInstances, - Rank2Types, - RankNTypes, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses + if true + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + -- PatternSignatures is needed for GHC 6.8 + PatternSignatures, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + if impl(ghc>=7.0) + extensions: + NoMonoLocalBinds + -- ---------------------------------------------------------------------- -- darcs itself -- ---------------------------------------------------------------------- @@ -467,6 +483,8 @@ src/umask.c src/Crypt/sha2.c + build-tools: ghc >= 6.10 && < 7.2 + -- We need optimizations, regardless of what Hackage says -- Note: "if true" works around a cabal bug with order of flag composition if true @@ -506,10 +524,10 @@ build-depends: base < 5, extensible-exceptions >= 0.1 && < 0.2, regex-compat >= 0.71 && < 0.94, - mtl >= 1.0 && < 1.2, + mtl >= 1.0 && < 2.1, parsec >= 2.0 && < 3.1, html == 1.0.*, - filepath == 1.1.*, + filepath >= 1.1.0.0 && < 1.3.0.0, haskeline >= 0.6.2.2 && < 0.7, hashed-storage >= 0.5.2 && < 0.6, tar == 0.3.* @@ -519,11 +537,11 @@ build-depends: base >= 3, bytestring >= 0.9.0 && < 0.10, - text >= 0.3, + text == 0.11.*, old-time == 1.0.*, - directory == 1.0.*, + directory >= 1.0.0.0 && < 1.2.0.0, process == 1.0.*, - containers >= 0.1 && < 0.4, + containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, random == 1.0.* @@ -535,8 +553,8 @@ cc-options: -DHAVE_CURL if flag(http) - build-depends: network == 2.2.*, - HTTP >= 3000.0 && < 4000.1 + build-depends: network >= 2.2 && < 2.4, + HTTP >= 3000.0 && < 4000.2 cpp-options: -DHAVE_HTTP x-have-http: @@ -557,29 +575,34 @@ if flag(color) x-use-color: - extensions: - CPP, - ForeignFunctionInterface, - BangPatterns, - PatternGuards, - MagicHash, - UndecidableInstances, - DeriveDataTypeable, - GADTs, - TypeOperators, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - ScopedTypeVariables, - -- PatternSignatures is needed for GHC 6.8 - PatternSignatures, - KindSignatures, - TypeSynonymInstances, - Rank2Types, - RankNTypes, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses + if true + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + -- PatternSignatures is needed for GHC 6.8 + PatternSignatures, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + if impl(ghc>=7.0) + extensions: + NoMonoLocalBinds + -- ---------------------------------------------------------------------- -- unit test driver -- ---------------------------------------------------------------------- @@ -591,13 +614,16 @@ buildable: False else buildable: True + + build-tools: ghc >= 6.10 && < 7.2 + build-depends: base < 5, extensible-exceptions >= 0.1 && < 0.2, regex-compat >= 0.71 && < 0.94, - mtl >= 1.0 && < 1.2, + mtl >= 1.0 && < 2.1, parsec >= 2.0 && < 3.1, html == 1.0.*, - filepath == 1.1.*, + filepath >= 1.1.0.0 && < 1.3.0.0, QuickCheck >= 2.1.0.0, HUnit >= 1.0, test-framework >= 0.2.2, @@ -657,11 +683,11 @@ build-depends: base >= 3, bytestring >= 0.9.0 && < 0.10, haskeline >= 0.6.2.2 && < 0.7, - text >= 0.3, + text == 0.11.*, old-time == 1.0.*, - directory == 1.0.*, + directory >= 1.0.0.0 && < 1.2.0.0, process == 1.0.*, - containers >= 0.1 && < 0.4, + containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, hashed-storage >= 0.5.2 && < 0.6, random == 1.0.* @@ -678,32 +704,37 @@ cpp-options: -DHAVE_TERMINFO if flag(http) - build-depends: network == 2.2.*, - HTTP >= 3000.0 && < 4000.1 + build-depends: network >= 2.2 && < 2.4, + HTTP >= 3000.0 && < 4000.2 if flag(color) x-use-color: - extensions: - CPP, - ForeignFunctionInterface, - BangPatterns, - PatternGuards, - MagicHash, - UndecidableInstances, - DeriveDataTypeable, - GADTs, - TypeOperators, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - ScopedTypeVariables, - -- PatternSignatures is needed for GHC 6.8 - PatternSignatures, - KindSignatures, - TypeSynonymInstances, - Rank2Types, - RankNTypes, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses - OverlappingInstances + if true + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + -- PatternSignatures is needed for GHC 6.8 + PatternSignatures, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + OverlappingInstances + + if impl(ghc>=7.0) + extensions: + NoMonoLocalBinds diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n[TAG 2.5\nReinier Lamers **20101024151805\n Ignore-this: 1561ce30bfb1950a440c03371e0e2f20\n] \n" +Just "\nContext:\n\n[TAG 2.5.1\nGanesh Sittampalam **20110210233529\n Ignore-this: 9e4daeb4ceaf1c2743235c68564c519b\n] \n" diff --git a/src/Darcs/Arguments.lhs b/src/Darcs/Arguments.lhs --- a/src/Darcs/Arguments.lhs +++ b/src/Darcs/Arguments.lhs @@ -271,8 +271,8 @@ getContent NonVerify = NoContent getContent NonForce = NoContent getContent DryRun = NoContent -getContent SetDefault = NoContent -getContent NoSetDefault = NoContent +getContent (SetDefault _) = NoContent +getContent (NoSetDefault _) = NoContent getContent FancyMoveAdd = NoContent getContent NoFancyMoveAdd = NoContent getContent Disable = NoContent @@ -347,6 +347,7 @@ _ -> False isin :: DarcsAtomicOption -> [DarcsFlag] -> Bool +(DarcsInternalOption f) `isin` fs = f `elem` fs (DarcsNoArgOption _ _ f _) `isin` fs = f `elem` fs (DarcsArgOption _ _ f _ _) `isin` fs = any (`isa` f) fs (DarcsAbsPathOption _ _ f _ _) `isin` fs = any (`isAnAbsolute` f) fs @@ -390,6 +391,11 @@ -- ^ @DarcsNoArgOption shortSwitches longSwitches mkFlag optDescr@ -- The constructon fon options with no arguments. + | DarcsInternalOption DarcsFlag + -- ^ @DarcsInternalOption@ + -- An option just for internal use (e.g. defaulting), not directly available to the user. + + data DarcsOption = DarcsSingleOption DarcsAtomicOption | DarcsMultipleChoiceOption [DarcsAtomicOption] @@ -423,6 +429,7 @@ | otherwise = x : clear xs clear [] = [] flags (DarcsNoArgOption _ _ fl _:xs) = fl : flags xs + flags (DarcsInternalOption fl:xs) = fl : flags xs flags (_:xs) = flags xs flags [] = [] nubOptions (_:options) opts = nubOptions options opts @@ -433,15 +440,16 @@ getSetter (DarcsMutuallyExclusive _ f) = Just f getSetter _ = Nothing -optionFromDarcsAtomicOption :: AbsolutePath -> DarcsAtomicOption -> OptDescr DarcsFlag -optionFromDarcsAtomicOption _ (DarcsNoArgOption a b c h) = Option a b (NoArg c) h -optionFromDarcsAtomicOption _ (DarcsArgOption a b c n h) = Option a b (ReqArg c n) h +optionFromDarcsAtomicOption :: AbsolutePath -> DarcsAtomicOption -> Maybe (OptDescr DarcsFlag) +optionFromDarcsAtomicOption wd (DarcsInternalOption _) = Nothing +optionFromDarcsAtomicOption _ (DarcsNoArgOption a b c h) = Just $ Option a b (NoArg c) h +optionFromDarcsAtomicOption _ (DarcsArgOption a b c n h) = Just $ Option a b (ReqArg c n) h optionFromDarcsAtomicOption wd (DarcsAbsPathOrStdOption a b c n h) = - Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h + Just $ Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h optionFromDarcsAtomicOption wd (DarcsAbsPathOption a b c n h) = - Option a b (ReqArg (c . makeAbsolute wd) n) h + Just $ Option a b (ReqArg (c . makeAbsolute wd) n) h optionFromDarcsAtomicOption wd (DarcsOptAbsPathOption a b d c n h) = - Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h + Just $ Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h atomicOptions :: DarcsOption -> [DarcsAtomicOption] atomicOptions (DarcsSingleOption x) = [x] @@ -449,7 +457,7 @@ atomicOptions (DarcsMutuallyExclusive xs _) = xs optionFromDarcsOption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag] -optionFromDarcsOption wd = map (optionFromDarcsAtomicOption wd) . atomicOptions +optionFromDarcsOption wd = mapMaybe (optionFromDarcsAtomicOption wd) . atomicOptions -- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of -- option, flattening any DarcsMultipleChoiceOption in the list. @@ -1098,13 +1106,17 @@ setDefault :: Bool -> DarcsOption setDefault wantYes - | wantYes = mkMutuallyExclusive [] yes [no] - | otherwise = mkMutuallyExclusive [yes] no [] + | wantYes = mkMutuallyExclusive [yes,no] defaultyes [] + | otherwise = mkMutuallyExclusive [yes,no] defaultno [] where - yes = ( DarcsNoArgOption [] ["set-default"], SetDefault - , "set default repository" ) - no = ( DarcsNoArgOption [] ["no-set-default"], NoSetDefault - , "don't set default repository" ) + yes = ( DarcsNoArgOption [] ["set-default"], SetDefault True + , "set default repository" ++ defaultText wantYes ) + no = ( DarcsNoArgOption [] ["no-set-default"], NoSetDefault True + , "don't set default repository" ++ defaultText (not wantYes) ) + defaultyes = ( \f _ -> DarcsInternalOption f, SetDefault False, "" ) + defaultno = ( \f _ -> DarcsInternalOption f, NoSetDefault False, "" ) + defaultText True = " [DEFAULT]" + defaultText False = "" verify = DarcsMultipleChoiceOption [DarcsAbsPathOption [] ["verify"] Verify "PUBRING" @@ -1397,6 +1409,7 @@ optionListLatex (DarcsMutuallyExclusive os _) = unlines (map optionLatex os) optionLatex :: DarcsAtomicOption -> String +optionLatex (DarcsInternalOption _) = "" optionLatex (DarcsNoArgOption a b _ h) = showShortOptions a ++ showLongOptions b ++ latexHelp h ++ "\\\\" optionLatex (DarcsArgOption a b _ arg h) = diff --git a/src/Darcs/Commands.lhs b/src/Darcs/Commands.lhs --- a/src/Darcs/Commands.lhs +++ b/src/Darcs/Commands.lhs @@ -17,7 +17,7 @@ \begin{code} module Darcs.Commands ( CommandControl( CommandData, HiddenCommand, GroupName ), - DarcsCommand( DarcsCommand, commandName, + DarcsCommand( DarcsCommand, commandProgramName, commandName, commandHelp, commandDescription, commandBasicOptions, commandAdvancedOptions, commandCommand, @@ -128,7 +128,7 @@ | GroupName String data DarcsCommand = - DarcsCommand {commandName, commandHelp, commandDescription :: String, + DarcsCommand {commandProgramName, commandName, commandHelp, commandDescription :: String, commandExtraArgs :: Int, commandExtraArgHelp :: [String], commandCommand :: [DarcsFlag] -> [String] -> IO (), @@ -137,7 +137,7 @@ commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String], commandBasicOptions :: [DarcsOption], commandAdvancedOptions :: [DarcsOption]} - | SuperCommand {commandName, commandHelp, commandDescription :: String, + | SuperCommand {commandProgramName, commandName, commandHelp, commandDescription :: String, commandPrereq :: [DarcsFlag] -> IO (Either String ()), commandSubCommands :: [CommandControl]} @@ -171,9 +171,9 @@ commandAlias :: String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand commandAlias n msuper c = c { commandName = n - , commandDescription = "Alias for `darcs " ++ cmdName ++ "'." - , commandHelp = "The `darcs " ++ n ++ "' command is an alias for " ++ - "`darcs " ++ cmdName ++ "'.\n" ++ + , commandDescription = "Alias for `" ++ commandProgramName c ++ " " ++ cmdName ++ "'." + , commandHelp = "The `" ++ commandProgramName c ++ " " ++ n ++ "' command is an alias for " ++ + "`" ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n" ++ commandHelp c } where @@ -201,7 +201,7 @@ subusage :: DarcsCommand -> String subusage super = (usageInfo - ("Usage: darcs "++commandName super++" SUBCOMMAND ... " ++ + ("Usage: " ++ commandProgramName super ++ " "++commandName super++" SUBCOMMAND ... " ++ "\n\n"++ commandDescription super++ "\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:") (optionFromDarcsOption rootDirectory help)) @@ -228,7 +228,7 @@ getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String getCommandMiniHelp msuper cmd = getCommandHelpCore msuper cmd ++ - "\n\nSee darcs help " + "\n\nSee " ++ commandProgramName cmd ++ " help " ++ (maybe "" (\c -> commandName c ++ " ") msuper) ++ commandName cmd ++ " for details." @@ -256,11 +256,11 @@ getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> String getCommandHelpCore msuper cmd = - "Usage: darcs "++superName msuper++commandName cmd++ + "Usage: " ++ commandProgramName cmd ++ " "++superName msuper++commandName cmd++ " [OPTION]... " ++ unwords args_help ++ "\n"++ commandDescription cmd where args_help = case cmd of - (DarcsCommand _ _ _ _ _ _ _ _ _ _ _) -> + (DarcsCommand {}) -> commandExtraArgHelp cmd _ -> [] diff --git a/src/Darcs/Commands/Add.lhs b/src/Darcs/Commands/Add.lhs --- a/src/Darcs/Commands/Add.lhs +++ b/src/Darcs/Commands/Add.lhs @@ -69,7 +69,8 @@ "Adding symbolic links (symlinks) is not supported.\n\n" add :: DarcsCommand -add = DarcsCommand {commandName = "add", +add = DarcsCommand {commandProgramName = "darcs", + commandName = "add", commandHelp = addHelp ++ addHelp' ++ addHelp'', commandDescription = addDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/AmendRecord.lhs b/src/Darcs/Commands/AmendRecord.lhs --- a/src/Darcs/Commands/AmendRecord.lhs +++ b/src/Darcs/Commands/AmendRecord.lhs @@ -103,7 +103,8 @@ "On Windows use C:/Documents And Settings/user/Application Data/darcs/defaults\n" amendrecord :: DarcsCommand -amendrecord = DarcsCommand {commandName = "amend-record", +amendrecord = DarcsCommand {commandProgramName = "darcs", + commandName = "amend-record", commandHelp = amendrecordHelp, commandDescription = amendrecordDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Annotate.lhs b/src/Darcs/Commands/Annotate.lhs --- a/src/Darcs/Commands/Annotate.lhs +++ b/src/Darcs/Commands/Annotate.lhs @@ -83,7 +83,8 @@ "option can be used to generate output for machine postprocessing.\n" annotate :: DarcsCommand -annotate = DarcsCommand {commandName = "annotate", +annotate = DarcsCommand {commandProgramName = "darcs", + commandName = "annotate", commandHelp = annotateHelp, commandDescription = annotateDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Apply.lhs b/src/Darcs/Commands/Apply.lhs --- a/src/Darcs/Commands/Apply.lhs +++ b/src/Darcs/Commands/Apply.lhs @@ -122,7 +122,8 @@ stdindefault _ [] = return ["-"] stdindefault _ x = return x apply :: DarcsCommand -apply = DarcsCommand {commandName = "apply", +apply = DarcsCommand {commandProgramName = "darcs", + commandName = "apply", commandHelp = applyHelp ++ "\n" ++ applyHelp', commandDescription = applyDescription, commandExtraArgs = 1, diff --git a/src/Darcs/Commands/Changes.lhs b/src/Darcs/Commands/Changes.lhs --- a/src/Darcs/Commands/Changes.lhs +++ b/src/Darcs/Commands/Changes.lhs @@ -85,7 +85,8 @@ "\n" ++ changesHelp'' changes :: DarcsCommand -changes = DarcsCommand {commandName = "changes", +changes = DarcsCommand {commandProgramName = "darcs", + commandName = "changes", commandHelp = changesHelp, commandDescription = changesDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Check.lhs b/src/Darcs/Commands/Check.lhs --- a/src/Darcs/Commands/Check.lhs +++ b/src/Darcs/Commands/Check.lhs @@ -62,7 +62,8 @@ "by `darcs check'. Use the --no-test option to disable this.\n" check :: DarcsCommand -check = DarcsCommand {commandName = "check", +check = DarcsCommand {commandProgramName = "darcs", + commandName = "check", commandHelp = checkHelp, commandDescription = checkDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Convert.lhs b/src/Darcs/Commands/Convert.lhs --- a/src/Darcs/Commands/Convert.lhs +++ b/src/Darcs/Commands/Convert.lhs @@ -116,7 +116,8 @@ "than once.)\n" convert :: DarcsCommand -convert = DarcsCommand {commandName = "convert", +convert = DarcsCommand {commandProgramName = "darcs", + commandName = "convert", commandHelp = convertHelp, commandDescription = convertDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Diff.lhs b/src/Darcs/Commands/Diff.lhs --- a/src/Darcs/Commands/Diff.lhs +++ b/src/Darcs/Commands/Diff.lhs @@ -75,7 +75,8 @@ "formatted as the output of a diff command\n" diffCommand :: DarcsCommand -diffCommand = DarcsCommand {commandName = "diff", +diffCommand = DarcsCommand {commandProgramName = "darcs", + commandName = "diff", commandHelp = diffHelp, commandDescription = diffDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Dist.lhs b/src/Darcs/Commands/Dist.lhs --- a/src/Darcs/Commands/Dist.lhs +++ b/src/Darcs/Commands/Dist.lhs @@ -31,12 +31,7 @@ import Prelude hiding ( writeFile ) import Data.ByteString.Lazy ( writeFile ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp, - commandDescription, commandExtraArgs, - commandExtraArgHelp, commandCommand, - commandPrereq, commandGetArgPossibilities, - commandArgdefaults, - commandAdvancedOptions, commandBasicOptions), +import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distnameOption, workingRepoDir, matchOne, storeInMemory, @@ -85,7 +80,8 @@ -} dist :: DarcsCommand -dist = DarcsCommand {commandName = "dist", +dist = DarcsCommand {commandProgramName = "darcs", + commandName = "dist", commandHelp = distHelp, commandDescription = distDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/GZCRCs.lhs b/src/Darcs/Commands/GZCRCs.lhs --- a/src/Darcs/Commands/GZCRCs.lhs +++ b/src/Darcs/Commands/GZCRCs.lhs @@ -119,7 +119,8 @@ when verbose $ hPutStrLn stderr $ unlines ("The following corrupt files were found:":files) gzcrcs :: DarcsCommand -gzcrcs = DarcsCommand {commandName = "gzcrcs", +gzcrcs = DarcsCommand {commandProgramName = "darcs", + commandName = "gzcrcs", commandHelp = gzcrcsHelp, commandDescription = gzcrcsDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Get.lhs b/src/Darcs/Commands/Get.lhs --- a/src/Darcs/Commands/Get.lhs +++ b/src/Darcs/Commands/Get.lhs @@ -117,7 +117,8 @@ "is required.\n" get :: DarcsCommand -get = DarcsCommand {commandName = "get", +get = DarcsCommand {commandProgramName = "darcs", + commandName = "get", commandHelp = getHelp, commandDescription = getDescription, commandExtraArgs = -1, @@ -200,11 +201,15 @@ debugMessage "Identifying and copying repository..." copyRepoHashed repository | hashUs -> do - putInfo opts $ text "Converting old-fashioned repository to hashed format..." - $$ text "*******************************************************************************" - $$ text "Fetching a hashed repository would be faster. Perhaps you could persuade" - $$ text "the maintainer to run darcs optimize --upgrade with darcs 2.4.0 or higher?" - $$ text "*******************************************************************************" + putInfo opts $ text "***********************************************************************" + $$ text " _______ Sorry for the wait! The repository you are fetching is" + $$ text " | | using the DEPRECATED 'old-fashioned' format. I'm getting a" + $$ text " | O O | hashed copy instead, but this may take a while." + $$ text " | ___ |" + $$ text " | / \\ | We recommend that the maintainer upgrade the remote copy" + $$ text " |_______| as well. See http://wiki.darcs.net/OF for more information." + $$ text "" + $$ text "***********************************************************************" copyRepoHashed repository | hashThem -> do putInfo opts $ text "Fetching a hashed repository as an old-fashioned one..." diff --git a/src/Darcs/Commands/Help.lhs b/src/Darcs/Commands/Help.lhs --- a/src/Darcs/Commands/Help.lhs +++ b/src/Darcs/Commands/Help.lhs @@ -53,7 +53,8 @@ "`darcs help foo' prints detailed help about the darcs command foo.\n" help :: DarcsCommand -help = DarcsCommand {commandName = "help", +help = DarcsCommand {commandProgramName = "darcs", + commandName = "help", commandHelp = helpHelp, commandDescription = helpDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Init.lhs b/src/Darcs/Commands/Init.lhs --- a/src/Darcs/Commands/Init.lhs +++ b/src/Darcs/Commands/Init.lhs @@ -70,7 +70,8 @@ "Initialize is commonly abbreviated to `init'.\n" initialize :: DarcsCommand -initialize = DarcsCommand {commandName = "initialize", +initialize = DarcsCommand {commandProgramName = "darcs", + commandName = "initialize", commandHelp = initializeHelp, commandDescription = initializeDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/MarkConflicts.lhs b/src/Darcs/Commands/MarkConflicts.lhs --- a/src/Darcs/Commands/MarkConflicts.lhs +++ b/src/Darcs/Commands/MarkConflicts.lhs @@ -64,7 +64,8 @@ "alias still exists for backwards-compatibility.\n" markconflicts :: DarcsCommand -markconflicts = DarcsCommand {commandName = "mark-conflicts", +markconflicts = DarcsCommand {commandProgramName = "darcs", + commandName = "mark-conflicts", commandHelp = markconflictsHelp, commandDescription = markconflictsDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Move.lhs b/src/Darcs/Commands/Move.lhs --- a/src/Darcs/Commands/Move.lhs +++ b/src/Darcs/Commands/Move.lhs @@ -74,7 +74,8 @@ "unusable on those systems!\n" move :: DarcsCommand -move = DarcsCommand {commandName = "move", +move = DarcsCommand {commandProgramName = "darcs", + commandName = "move", commandHelp = moveHelp, commandDescription = moveDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Optimize.lhs b/src/Darcs/Commands/Optimize.lhs --- a/src/Darcs/Commands/Optimize.lhs +++ b/src/Darcs/Commands/Optimize.lhs @@ -122,7 +122,8 @@ "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n" optimize :: DarcsCommand -optimize = DarcsCommand {commandName = "optimize", +optimize = DarcsCommand {commandProgramName = "darcs", + commandName = "optimize", commandHelp = optimizeHelp, commandDescription = optimizeDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Pull.lhs b/src/Darcs/Commands/Pull.lhs --- a/src/Darcs/Commands/Pull.lhs +++ b/src/Darcs/Commands/Pull.lhs @@ -111,7 +111,8 @@ fetch :: DarcsCommand fetch = DarcsCommand { - commandName = "fetch", + commandProgramName = "darcs", + commandName = "fetch", commandHelp = fetchHelp, commandDescription = fetchDescription, commandExtraArgs = -1, @@ -134,7 +135,8 @@ allowUnrelatedRepos]} pull :: DarcsCommand -pull = DarcsCommand {commandName = "pull", +pull = DarcsCommand {commandProgramName = "darcs", + commandName = "pull", commandHelp = pullHelp, commandDescription = pullDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Push.lhs b/src/Darcs/Commands/Push.lhs --- a/src/Darcs/Commands/Push.lhs +++ b/src/Darcs/Commands/Push.lhs @@ -75,7 +75,8 @@ "current repository into another repository.\n" push :: DarcsCommand -push = DarcsCommand {commandName = "push", +push = DarcsCommand {commandProgramName = "darcs", + commandName = "push", commandHelp = pushHelp, commandDescription = pushDescription, commandExtraArgs = 1, diff --git a/src/Darcs/Commands/Put.lhs b/src/Darcs/Commands/Put.lhs --- a/src/Darcs/Commands/Put.lhs +++ b/src/Darcs/Commands/Put.lhs @@ -55,7 +55,8 @@ "appropriate. See those commands for an explanation of each option.\n" put ::DarcsCommand -put = DarcsCommand {commandName = "put", +put = DarcsCommand {commandProgramName = "darcs", + commandName = "put", commandHelp = putHelp, commandDescription = putDescription, commandExtraArgs = 1, diff --git a/src/Darcs/Commands/Record.lhs b/src/Darcs/Commands/Record.lhs --- a/src/Darcs/Commands/Record.lhs +++ b/src/Darcs/Commands/Record.lhs @@ -91,7 +91,8 @@ "\n" ++ recordHelp'' record :: DarcsCommand -record = DarcsCommand {commandName = "record", +record = DarcsCommand {commandProgramName = "darcs", + commandName = "record", commandHelp = recordHelp, commandDescription = recordDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Remove.lhs b/src/Darcs/Commands/Remove.lhs --- a/src/Darcs/Commands/Remove.lhs +++ b/src/Darcs/Commands/Remove.lhs @@ -65,7 +65,8 @@ "the patch) will ALWAYS affect the working tree of that repository.\n" remove :: DarcsCommand -remove = DarcsCommand {commandName = "remove", +remove = DarcsCommand {commandProgramName = "darcs", + commandName = "remove", commandHelp = removeHelp, commandDescription = removeDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Repair.lhs b/src/Darcs/Commands/Repair.lhs --- a/src/Darcs/Commands/Repair.lhs +++ b/src/Darcs/Commands/Repair.lhs @@ -40,7 +40,8 @@ "which is where most corruption occurs.\n" repair :: DarcsCommand -repair = DarcsCommand {commandName = "repair", +repair = DarcsCommand {commandProgramName = "darcs", + commandName = "repair", commandHelp = repairHelp, commandDescription = repairDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Replace.lhs b/src/Darcs/Commands/Replace.lhs --- a/src/Darcs/Commands/Replace.lhs +++ b/src/Darcs/Commands/Replace.lhs @@ -26,11 +26,7 @@ import Control.Monad ( unless, filterM ) import Control.Applicative( (<$>) ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp, - commandDescription, commandExtraArgs, - commandExtraArgHelp, commandCommand, commandPrereq, - commandGetArgPossibilities, commandArgdefaults, - commandAdvancedOptions, commandBasicOptions), +import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), listRegisteredFiles, ignoretimes, umaskOption, tokens, forceReplace, @@ -146,7 +142,8 @@ \begin{code} replace :: DarcsCommand -replace = DarcsCommand {commandName = "replace", +replace = DarcsCommand {commandProgramName = "darcs", + commandName = "replace", commandHelp = replaceHelp, commandDescription = replaceDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Revert.lhs b/src/Darcs/Commands/Revert.lhs --- a/src/Darcs/Commands/Revert.lhs +++ b/src/Darcs/Commands/Revert.lhs @@ -65,7 +65,8 @@ "revert' ran.\n" revert :: DarcsCommand -revert = DarcsCommand {commandName = "revert", +revert = DarcsCommand {commandProgramName = "darcs", + commandName = "revert", commandHelp = revertHelp, commandDescription = revertDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Rollback.lhs b/src/Darcs/Commands/Rollback.lhs --- a/src/Darcs/Commands/Rollback.lhs +++ b/src/Darcs/Commands/Rollback.lhs @@ -79,7 +79,8 @@ "of its changes.\n" rollback :: DarcsCommand -rollback = DarcsCommand {commandName = "rollback", +rollback = DarcsCommand {commandProgramName = "darcs", + commandName = "rollback", commandHelp = rollbackHelp, commandDescription = rollbackDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/Send.lhs b/src/Darcs/Commands/Send.lhs --- a/src/Darcs/Commands/Send.lhs +++ b/src/Darcs/Commands/Send.lhs @@ -115,7 +115,8 @@ \begin{code} send :: DarcsCommand -send = DarcsCommand {commandName = "send", +send = DarcsCommand {commandProgramName = "darcs", + commandName = "send", commandHelp = sendHelp, commandDescription = sendDescription, commandExtraArgs = 1, @@ -152,12 +153,12 @@ here <- getCurrentDirectory when (repodir == toFilePath here) $ fail ("Can't send to current repository! Did you mean send --context?") - repo <- identifyRepositoryFor repository repodir - them <- readRepo repo old_default <- getPreflist "defaultrepo" - setDefaultrepo repodir input_opts when (old_default == [repodir] && not (Quiet `elem` input_opts)) $ putStrLn $ "Creating patch to "++formatPath repodir++"..." + repo <- identifyRepositoryFor repository repodir + them <- readRepo repo + setDefaultrepo repodir input_opts wtds <- decideOnBehavior input_opts repo sendToThem repository input_opts wtds repodir them where the_context [] = return Nothing diff --git a/src/Darcs/Commands/SetPref.lhs b/src/Darcs/Commands/SetPref.lhs --- a/src/Darcs/Commands/SetPref.lhs +++ b/src/Darcs/Commands/SetPref.lhs @@ -73,7 +73,8 @@ "low-priority bug, because preferences are seldom set.\n" setpref :: DarcsCommand -setpref = DarcsCommand {commandName = "setpref", +setpref = DarcsCommand {commandProgramName = "darcs", + commandName = "setpref", commandHelp = setprefHelp, commandDescription = setprefDescription, commandExtraArgs = 2, diff --git a/src/Darcs/Commands/Show.lhs b/src/Darcs/Commands/Show.lhs --- a/src/Darcs/Commands/Show.lhs +++ b/src/Darcs/Commands/Show.lhs @@ -43,7 +43,8 @@ "Currently this is a deprecated alias.\n" showCommand :: DarcsCommand -showCommand = SuperCommand {commandName = "show", +showCommand = SuperCommand {commandProgramName = "darcs", + commandName = "show", commandHelp = showHelp, commandDescription = showDescription, commandPrereq = amInRepository, diff --git a/src/Darcs/Commands/ShowAuthors.lhs b/src/Darcs/Commands/ShowAuthors.lhs --- a/src/Darcs/Commands/ShowAuthors.lhs +++ b/src/Darcs/Commands/ShowAuthors.lhs @@ -89,6 +89,7 @@ showAuthors :: DarcsCommand showAuthors = DarcsCommand { + commandProgramName = "darcs", commandName = "authors", commandHelp = showAuthorsHelp, commandDescription = showAuthorsDescription, diff --git a/src/Darcs/Commands/ShowBug.lhs b/src/Darcs/Commands/ShowBug.lhs --- a/src/Darcs/Commands/ShowBug.lhs +++ b/src/Darcs/Commands/ShowBug.lhs @@ -36,7 +36,8 @@ ++"a bug in darcs.\n" showBug :: DarcsCommand -showBug = DarcsCommand {commandName = "bug", +showBug = DarcsCommand {commandProgramName = "darcs", + commandName = "bug", commandHelp = showBugHelp, commandDescription = showBugDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/ShowContents.lhs b/src/Darcs/Commands/ShowContents.lhs --- a/src/Darcs/Commands/ShowContents.lhs +++ b/src/Darcs/Commands/ShowContents.lhs @@ -48,7 +48,8 @@ "version of the file(s).\n" showContents :: DarcsCommand -showContents = DarcsCommand {commandName = "contents", +showContents = DarcsCommand {commandProgramName = "darcs", + commandName = "contents", commandHelp = showContentsHelp, commandDescription = showContentsDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/ShowFiles.lhs b/src/Darcs/Commands/ShowFiles.lhs --- a/src/Darcs/Commands/ShowFiles.lhs +++ b/src/Darcs/Commands/ShowFiles.lhs @@ -67,6 +67,7 @@ showFiles :: DarcsCommand showFiles = DarcsCommand { + commandProgramName = "darcs", commandName = "files", commandHelp = showFilesHelp, commandDescription = showFilesDescription, diff --git a/src/Darcs/Commands/ShowIndex.lhs b/src/Darcs/Commands/ShowIndex.lhs --- a/src/Darcs/Commands/ShowIndex.lhs +++ b/src/Darcs/Commands/ShowIndex.lhs @@ -44,6 +44,7 @@ showIndex :: DarcsCommand showIndex = DarcsCommand { + commandProgramName = "darcs", commandName = "index", commandDescription = "Dump contents of working tree index.", commandHelp = diff --git a/src/Darcs/Commands/ShowRepo.lhs b/src/Darcs/Commands/ShowRepo.lhs --- a/src/Darcs/Commands/ShowRepo.lhs +++ b/src/Darcs/Commands/ShowRepo.lhs @@ -56,7 +56,8 @@ showRepoDescription = "Show repository summary information" showRepo :: DarcsCommand -showRepo = DarcsCommand { commandName = "repo", +showRepo = DarcsCommand { commandProgramName = "darcs", + commandName = "repo", commandHelp = showRepoHelp, commandDescription = showRepoDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/ShowTags.lhs b/src/Darcs/Commands/ShowTags.lhs --- a/src/Darcs/Commands/ShowTags.lhs +++ b/src/Darcs/Commands/ShowTags.lhs @@ -42,6 +42,7 @@ showTags :: DarcsCommand showTags = DarcsCommand { + commandProgramName = "darcs", commandName = "tags", commandHelp = showTagsHelp, commandDescription = showTagsDescription, diff --git a/src/Darcs/Commands/Tag.lhs b/src/Darcs/Commands/Tag.lhs --- a/src/Darcs/Commands/Tag.lhs +++ b/src/Darcs/Commands/Tag.lhs @@ -21,12 +21,7 @@ import System.Directory ( removeFile ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp, - commandDescription, commandExtraArgs, - commandExtraArgHelp, commandCommand, commandPrereq, - commandGetArgPossibilities, commandArgdefaults, - commandAdvancedOptions, commandBasicOptions), - nodefaults ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( nocompress, umaskOption, patchnameOption, author, pipeInteractive, askLongComment, workingRepoDir, getAuthor ) @@ -71,7 +66,8 @@ "described in `darcs record'.\n" tag :: DarcsCommand -tag = DarcsCommand {commandName = "tag", +tag = DarcsCommand {commandProgramName = "darcs", + commandName = "tag", commandHelp = tagHelp, commandDescription = tagDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/TrackDown.lhs b/src/Darcs/Commands/TrackDown.lhs --- a/src/Darcs/Commands/TrackDown.lhs +++ b/src/Darcs/Commands/TrackDown.lhs @@ -60,7 +60,8 @@ "found at random." trackdown :: DarcsCommand -trackdown = DarcsCommand {commandName = "trackdown", +trackdown = DarcsCommand {commandProgramName = "darcs", + commandName = "trackdown", commandHelp = trackdownHelp, commandDescription = trackdownDescription, commandExtraArgs = -1, diff --git a/src/Darcs/Commands/TransferMode.lhs b/src/Darcs/Commands/TransferMode.lhs --- a/src/Darcs/Commands/TransferMode.lhs +++ b/src/Darcs/Commands/TransferMode.lhs @@ -52,7 +52,8 @@ "hundreds of times!\n" transferMode :: DarcsCommand -transferMode = DarcsCommand {commandName = "transfer-mode", +transferMode = DarcsCommand {commandProgramName = "darcs", + commandName = "transfer-mode", commandHelp = transferModeHelp, commandDescription = transferModeDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Unrecord.lhs b/src/Darcs/Commands/Unrecord.lhs --- a/src/Darcs/Commands/Unrecord.lhs +++ b/src/Darcs/Commands/Unrecord.lhs @@ -147,7 +147,8 @@ "another user may have already pulled the patch.\n" unrecord :: DarcsCommand -unrecord = DarcsCommand {commandName = "unrecord", +unrecord = DarcsCommand {commandProgramName = "darcs", + commandName = "unrecord", commandHelp = unrecordHelp, commandDescription = unrecordDescription, commandExtraArgs = 0, @@ -272,7 +273,8 @@ \begin{code} obliterate :: DarcsCommand -obliterate = DarcsCommand {commandName = "obliterate", +obliterate = DarcsCommand {commandProgramName = "darcs", + commandName = "obliterate", commandHelp = obliterateHelp, commandDescription = obliterateDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/Unrevert.lhs b/src/Darcs/Commands/Unrevert.lhs --- a/src/Darcs/Commands/Unrevert.lhs +++ b/src/Darcs/Commands/Unrevert.lhs @@ -71,7 +71,8 @@ "interactive command that will DEFINITELY prevent unreversion.\n" unrevert :: DarcsCommand -unrevert = DarcsCommand {commandName = "unrevert", +unrevert = DarcsCommand {commandProgramName = "darcs", + commandName = "unrevert", commandHelp = unrevertHelp, commandDescription = unrevertDescription, commandExtraArgs = 0, diff --git a/src/Darcs/Commands/WhatsNew.lhs b/src/Darcs/Commands/WhatsNew.lhs --- a/src/Darcs/Commands/WhatsNew.lhs +++ b/src/Darcs/Commands/WhatsNew.lhs @@ -91,7 +91,8 @@ "there are no unrecorded changes.\n" whatsnew :: DarcsCommand -whatsnew = DarcsCommand {commandName = "whatsnew", +whatsnew = DarcsCommand {commandProgramName = "darcs", + commandName = "whatsnew", commandHelp = whatsnewHelp, commandDescription = whatsnewDescription, commandExtraArgs = -1, diff --git a/src/Darcs/CommandsAux.hs b/src/Darcs/CommandsAux.hs --- a/src/Darcs/CommandsAux.hs +++ b/src/Darcs/CommandsAux.hs @@ -21,6 +21,7 @@ #include "gadts.h" module Darcs.CommandsAux ( checkPaths, maliciousPatches, hasMaliciousPath, + isMaliciousPath, isMaliciousSubPath, ) where import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) ) import Darcs.Patch ( Patchy, listTouchedFiles ) @@ -28,7 +29,7 @@ import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 ) import Darcs.Global ( darcsdir ) import Data.List ( intersect ) -import System.FilePath ( splitDirectories ) +import System.FilePath ( splitDirectories, isRelative ) -- * File paths {- @@ -102,7 +103,17 @@ -} isMaliciousPath :: String -> Bool isMaliciousPath fp = - not (isExplicitlyRelative fp) || + not (isExplicitlyRelative fp) || isGenerallyMalicious fp + +-- | Warning : this is less rigorous than isMaliciousPath +-- but it's to allow for subpath representations that +-- don't start with ./ +isMaliciousSubPath :: String -> Bool +isMaliciousSubPath fp = + not (isRelative fp) || isGenerallyMalicious fp + +isGenerallyMalicious :: String -> Bool +isGenerallyMalicious fp = splitDirectories fp `contains_any` [ "..", darcsdir ] where contains_any a b = not . null $ intersect a b diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs --- a/src/Darcs/Flags.hs +++ b/src/Darcs/Flags.hs @@ -83,7 +83,15 @@ | OnePattern PatchMatch | SeveralPattern PatchMatch | AfterPattern PatchMatch | UpToPattern PatchMatch | NonApply | NonVerify | NonForce - | DryRun | SetDefault | NoSetDefault + | DryRun + + -- The Bool parameters are a bit of a hack so that we can tell + -- whether the user explicitly set the option or not. + -- A more general mechanism would be better. + -- True = explicitly set by user (on command-line or in prefs/defaults), + -- False = defaulted by darcs + | SetDefault Bool | NoSetDefault Bool + | FancyMoveAdd | NoFancyMoveAdd | Disable | SetScriptsExecutable | DontSetScriptsExecutable | Bisect | UseHashedInventory | UseOldFashionedInventory diff --git a/src/Darcs/Patch/Choices.hs b/src/Darcs/Patch/Choices.hs --- a/src/Darcs/Patch/Choices.hs +++ b/src/Darcs/Patch/Choices.hs @@ -62,7 +62,8 @@ substitute ) where -import Control.Monad.State( State(..) ) +import Control.Monad.Identity ( Identity ) +import Control.Monad.State( StateT(..) ) import Darcs.Patch import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL ) @@ -252,8 +253,8 @@ settleB bubble = mapFL_FL (\tp -> PC tp True) $ reverseRL bubble patchSlot' :: Patchy p => - TaggedPatch p C(a b) -> State (PatchChoices p C(x y)) Slot -patchSlot' = State . patchSlot + TaggedPatch p C(a b) -> StateT (PatchChoices p C(x y)) Identity Slot +patchSlot' tp = StateT (return . patchSlot tp) forceMatchingFirst :: forall p C(a b). Patchy p => ( FORALL(x y) TaggedPatch p C(x y) -> Bool) diff --git a/src/Darcs/Patch/Commute.lhs b/src/Darcs/Patch/Commute.lhs --- a/src/Darcs/Patch/Commute.lhs +++ b/src/Darcs/Patch/Commute.lhs @@ -765,8 +765,9 @@ nchs = sort $ map (makeChunk l) newfs filename = getAFilename pss old = makeChunk l oldf - new = [top] ++ concat (intersperse [middle] nchs) ++ [bottom] + new = [top] ++ old ++ [initial] ++ concat (intersperse [middle] nchs) ++ [bottom] top = BC.pack $ "v v v v v v v" ++ eol_c + initial= BC.pack $ "=============" ++ eol_c middle = BC.pack $ "*************" ++ eol_c bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c eol_c = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old diff --git a/src/Darcs/Patch/Split.hs b/src/Darcs/Patch/Split.hs --- a/src/Darcs/Patch/Split.hs +++ b/src/Darcs/Patch/Split.hs @@ -133,6 +133,7 @@ , " - To split removed text, copy back the part you want to retain" , "" ] + hunk :: [B.ByteString] -> [B.ByteString] -> FL Prim C(a b) hunk b a = canonize (FP fn (Hunk n b a)) mkSep s = BC.append sep (BC.pack s) breakSep xs = case break (sep `BC.isPrefixOf`) xs of diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -54,7 +54,8 @@ import Darcs.Repository.Internal (Repository(..), RepoType(..), ($-), - maybeIdentifyRepository, identifyRepositoryFor, IdentifyRepo(..), + maybeIdentifyRepository, identifyRepositoryFor, identifyDarcsRepository, + IdentifyRepo(..), findRepository, amInRepository, amNotInRepository, makePatchLazy, withRecorded, @@ -102,7 +103,8 @@ , reverseRL ,lengthRL, (+>+), (:\/:)(..) ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), RepoFormat, - createRepoFormat, formatHas, writeRepoFormat ) + createRepoFormat, formatHas, writeRepoFormat, + readfromAndWritetoProblem) import Darcs.Repository.Prefs ( writeDefaultPrefs ) import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking ) import Darcs.Patch.Depends ( getPatchesBeyondTag, areUnrelatedRepos, findUncommon ) @@ -170,7 +172,11 @@ copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO () copyInventory fromRepo@(Repo fromDir opts fromFormat (DarcsRepository _ fromCache)) = do toRepo@(Repo toDir opts' toFormat (DarcsRepository toPristine toCache)) <- - identifyRepositoryFor fromRepo "." + identifyDarcsRepository opts "." + let (_ :: Repository p C(r u t)) = toRepo --The witnesses are wrong, but cannot escape + case readfromAndWritetoProblem fromFormat toFormat of + Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e + Nothing -> return () toCache2 <- unionRemoteCaches toCache fromCache fromDir let toRepo2 :: Repository p C(r u t) toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2 diff --git a/src/Darcs/Repository/HashedIO.hs b/src/Darcs/Repository/HashedIO.hs --- a/src/Darcs/Repository/HashedIO.hs +++ b/src/Darcs/Repository/HashedIO.hs @@ -21,7 +21,9 @@ module Darcs.Repository.HashedIO ( HashedIO, copyHashed, copyPartialsHashed, - cleanHashdir ) where + cleanHashdir, + RW(RW) -- only exported to make warning go away + ) where import Darcs.Global ( darcsdir ) import qualified Data.Set as Set @@ -31,15 +33,13 @@ import Control.Applicative ( (<$>) ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO ( hPutStrLn, stderr ) import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, writeFileUsingCache, peekInCache, speculateFileUsingCache, okayHash, cleanCachesWithHint, HashedDir(..), hashedDir ) -import Darcs.Patch ( Patchy, apply ) import Darcs.RepoPath ( FilePathLike, toFilePath ) import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) -import Darcs.Flags ( DarcsFlag, Compression( .. ) ) +import Darcs.Flags ( Compression( .. ) ) import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage, tediousSize, finishedOneIO ) @@ -50,11 +50,10 @@ import qualified Data.ByteString as B (ByteString, length, empty) import qualified Data.ByteString.Char8 as BC (unpack, pack) -import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed, - writeDarcsHashed, readDarcsHashedDir, darcsLocation, +import Storage.Hashed.Darcs( readDarcsHashedDir, darcsLocation, decodeDarcsHash, decodeDarcsSize ) -import Storage.Hashed.Tree( treeHash, ItemType(..) ) -import Storage.Hashed.Hash( encodeBase16, Hash(..) ) +import Storage.Hashed.Tree( ItemType(..) ) +import Darcs.CommandsAux -- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir, -- fetching it from 'Cache' @c@ if needed. @@ -255,7 +254,10 @@ cp (F,n,h) = do ps <- readhash h lift $ finishedOneIO k (fn2fp n) lift $ writeAtomicFilePS (fn2fp n) ps - cp (D,n,h) = do lift $ createDirectoryIfMissing False (fn2fp n) + cp (D,n,h) = if isMaliciousSubPath (fn2fp n) + then fail ("Caught malicious path: " ++ fn2fp n) + else do + lift $ createDirectoryIfMissing False (fn2fp n) lift $ finishedOneIO k (fn2fp n) lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h @@ -287,8 +289,8 @@ listone h = do let size = decodeDarcsSize $ BC.pack h hash = decodeDarcsHash $ BC.pack h x <- readDarcsHashedDir hashdir (size, hash) - let subs = [ fst $ darcsLocation "" (s, h) | (TreeType, _, s, h) <- x ] - hashes = h : [ fst $ darcsLocation "" (s, h) | (_, _, s, h) <- x ] + let subs = [ fst $ darcsLocation "" (s, h') | (TreeType, _, s, h') <- x ] + hashes = h : [ fst $ darcsLocation "" (s, h') | (_, _, s, h') <- x ] (hashes++) . concat <$> mapM listone subs hs <- set . concat <$> mapM listone hashroots fs <- set . filter okayHash <$> getDirectoryContents hashdir diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs --- a/src/Darcs/Repository/Internal.hs +++ b/src/Darcs/Repository/Internal.hs @@ -22,7 +22,7 @@ #include "gadts.h" module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-), - maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, + maybeIdentifyRepository, identifyDarcsRepository, identifyRepositoryFor, IdentifyRepo(..), findRepository, amInRepository, amNotInRepository, revertRepositoryChanges, @@ -195,6 +195,7 @@ | NonRepository String -- ^ safest guess | GoodRepository (Repository p C(r u t)) +-- | Tries to identify the repository in a given directory maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t)) maybeIdentifyRepository opts "." = do darcs <- doesDirectoryExist darcsdir @@ -219,17 +220,22 @@ Nothing -> do cs <- getCaches opts url return $ GoodRepository $ Repo url opts rf (DarcsRepository nopristine cs) -identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t)) -identifyDarcs1Repository opts url = +-- | identifyDarcsRepository identifies the repo at 'url'. Warning: +-- you have to know what kind of patches are found in that repo. +identifyDarcsRepository :: forall p C(r u t). [DarcsFlag] -> String + -> IO (Repository p C(r u t)) +identifyDarcsRepository opts url = do er <- maybeIdentifyRepository opts url case er of BadRepository s -> fail s NonRepository s -> fail s GoodRepository r -> return r +-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url', +-- but fails if it is not compatible for reading from and writing to. identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t)) identifyRepositoryFor (Repo _ opts rf _) url = - do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url + do Repo absurl _ rf_ t <- identifyDarcsRepository opts url let t' = case t of DarcsRepository x c -> DarcsRepository x c case readfromAndWritetoProblem rf_ rf of Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e @@ -441,7 +447,7 @@ checkUnrecordedConflicts :: forall p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False checkUnrecordedConflicts opts pc = - do repository <- identifyDarcs1Repository opts "." + do repository <- identifyDarcsRepository opts "." cuc repository where cuc :: Repository Patch C(r u t) -> IO Bool cuc r = do Sealed mpend <- readPending r :: IO (Sealed (FL Prim C(t))) @@ -659,7 +665,7 @@ withRepositoryDirectory :: forall a. [DarcsFlag] -> String -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepositoryDirectory opts1 url job = - do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url + do Repo dir opts rf rt <- identifyDarcsRepository opts1 url let rt' = case rt of DarcsRepository t c -> DarcsRepository t c if formatHas Darcs2 rf then do debugMessage $ "Identified darcs-2 repo: " ++ dir diff --git a/src/Darcs/Repository/Prefs.lhs b/src/Darcs/Repository/Prefs.lhs --- a/src/Darcs/Repository/Prefs.lhs +++ b/src/Darcs/Repository/Prefs.lhs @@ -448,25 +448,26 @@ setDefaultrepo :: String -> [DarcsFlag] -> IO () setDefaultrepo r opts = do olddef <- getPreflist "defaultrepo" - let doit = NoSetDefault `notElem` opts && greenLight + let doit = null noSetDefault && greenLight greenLight = wetRun && not rIsTmp && (olddef /= [r] || olddef == []) if doit then setPreflist "defaultrepo" [r] - else when greenLight $ putStr . unlines $ + else when (True `notElem` noSetDefault && greenLight) $ putStr . unlines $ -- the nuance here is that we should only notify when the -- reason we're not setting default is the --no-set-default -- flag, not the various automatic show stoppers - [ "Note: if you want to change the default remote repository to" - , r ++ "," - , "quit now and issue the same command with the --set-default flag." + [ "HINT: if you want to change the default remote repository to" + , " " ++ r ++ "," + , " quit now and issue the same command with the --set-default flag." ] addToPreflist "repos" r `catchall` return () -- we don't care if this fails! where wetRun = DryRun `notElem` opts rIsTmp = r `elem` [x | RemoteRepo x <- opts] + noSetDefault = [x | NoSetDefault x <- opts] \end{code} \paragraph{email} diff --git a/src/Darcs/SelectChanges.hs b/src/Darcs/SelectChanges.hs --- a/src/Darcs/SelectChanges.hs +++ b/src/Darcs/SelectChanges.hs @@ -30,9 +30,10 @@ import Data.Maybe ( catMaybes, isJust, fromJust ) import Data.Char ( toUpper ) import Control.Monad ( when, (>=>) ) +import Control.Monad.Identity ( Identity(..) ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Reader ( ReaderT, Reader, asks, runReader, runReaderT ) -import Control.Monad.State ( State(..), StateT, modify, gets, execStateT ) +import Control.Monad.State ( StateT, modify, gets, runStateT, execStateT ) import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import English ( Noun(..), englishNum ) @@ -313,7 +314,7 @@ o <- asks opts if not $ isInteractive o then return $ promote autoChoices - else flip refineChoices autoChoices $ textSelect whch + else refineChoices (textSelect whch) autoChoices where forward = not $ backward whch promote = if forward then makeEverythingSooner @@ -390,11 +391,11 @@ -- | Runs a function on the underlying @PatchChoices@ object liftChoices :: forall p a C(x y) . Patchy p => - State (PatchChoices p C(x y)) a + StateT (PatchChoices p C(x y)) Identity a -> InteractiveSelectionM p C(x y) a liftChoices act = do ch <- gets choices - let (result, ch') = runState act ch + let (result, ch') = runIdentity $ runStateT act ch modify $ \isc -> isc {choices = ch} return result diff --git a/src/Darcs/Test/Patch/Info.hs b/src/Darcs/Test/Patch/Info.hs --- a/src/Darcs/Test/Patch/Info.hs +++ b/src/Darcs/Test/Patch/Info.hs @@ -27,7 +27,7 @@ import qualified Data.ByteString.Char8 as BC ( unpack ) import Data.List ( sort ) import Data.Maybe ( isNothing ) -import Data.Text as T ( findBy, any ) +import Data.Text as T ( find, any ) import Data.Text.Encoding ( decodeUtf8With ) import Data.Text.Encoding.Error ( lenientDecode ) import Foreign ( unsafePerformIO ) @@ -121,7 +121,7 @@ \patchInfo -> encodingOK (_piAuthor patchInfo) && encodingOK (_piName patchInfo) && all encodingOK (_piLog patchInfo) - where encodingOK = isNothing . T.findBy (=='\xfffd') . decodeUtf8With lenientDecode + where encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode -- | Test that metadata in patches are decoded as UTF-8 or locale depending on -- whether they're valid UTF-8. diff --git a/src/Darcs/Test/Patch/QuickCheck.hs b/src/Darcs/Test/Patch/QuickCheck.hs --- a/src/Darcs/Test/Patch/QuickCheck.hs +++ b/src/Darcs/Test/Patch/QuickCheck.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-} -{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, ViewPatterns #-} #include "gadts.h" module Darcs.Test.Patch.QuickCheck ( WithStartState, RepoModel, Tree, @@ -308,18 +308,17 @@ propFail n xs = sizeTree xs < n instance ArbitraryState s p => ArbitraryState s (WithState s p) where - arbitraryState rm = do xandrm' <- arbitraryState rm - flip unseal xandrm' $ \(WithEndState x rm') -> - return $ seal $ WithEndState (WithState rm x rm') rm' + arbitraryState rm = do Sealed (WithEndState x rm') <- arbitraryState rm + return $ seal $ WithEndState (WithState rm x rm') rm' instance ArbitraryState s p => ArbitraryState s (FL p) where arbitraryState rm1 = sized $ \n -> do k <- choose (0, n) arbitraryList k rm1 where arbitraryList :: FORALL(x) Int -> s C(x) -> Gen (Sealed (WithEndState (FL p C(x)) s)) arbitraryList 0 rm = return $ seal $ WithEndState NilFL rm - arbitraryList (n+1) rm = do Sealed (WithEndState x rm') <- arbitraryState rm - Sealed (WithEndState xs rm'') <- arbitraryList n rm' - return $ seal $ WithEndState (x :>: xs) rm'' + arbitraryList n rm = do Sealed (WithEndState x rm') <- arbitraryState rm + Sealed (WithEndState xs rm'') <- arbitraryList (n-1) rm' + return $ seal $ WithEndState (x :>: xs) rm'' arbitraryList _ _ = impossible data Tree p C(x) where @@ -355,9 +354,8 @@ flattenTree :: (Commute p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z)) flattenTree NilTree = seal $ G2 $ return NilFL flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t -flattenTree (ParTree t1 t2) = flip unseal (flattenTree t1) $ \gpss1 -> - flip unseal (flattenTree t2) $ \gpss2 -> - seal $ G2 $ +flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2)) + = seal $ G2 $ do ps1 <- unG2 gpss1 ps2 <- unG2 gpss2 ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2) @@ -441,7 +439,7 @@ | otherwise = (Hunk n (take pos' old ++ drop (pos'+1) old) new, Nothing) where pos' = pos - n shrinkPos _ _ = bug "foo1 in ShrinkablePos" - shrinkPatch (Hunk (n+1) [] []) = [(Hunk n [] [], Nothing)] + shrinkPatch (Hunk n [] []) | n > 0 = [(Hunk (n-1) [] [], Nothing)] shrinkPatch (Hunk n old new) = do i <- [0 .. length new - 1] return (Hunk n old (take i new ++ drop (i+1) new), Just (n + i)) @@ -508,10 +506,8 @@ flattenOne :: (FromPrim p, Commute p) => Tree Prim C(x) -> Sealed (FL p C(x)) flattenOne NilTree = seal NilFL -flattenOne (SeqTree p t) = flip unseal (flattenOne t) $ \ps -> seal (fromPrim p :>: ps) -flattenOne (ParTree t1 t2) = - flip unseal (flattenOne t1) $ \ps1 -> - flip unseal (flattenOne t2) $ \ps2 -> +flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps) +flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) = --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$ -- greenText "ps2" $$ showPatch ps2) $ case merge (ps1 :\/: ps2) of diff --git a/tests/external.sh b/tests/external.sh --- a/tests/external.sh +++ b/tests/external.sh @@ -31,7 +31,7 @@ cd .. darcs get temp1 > log not grep fakessh log -not darcs get http://example.com/foo +not darcs get http://darcs.net/nonexistent not grep fakessh log cd .. rm -rf temp1 diff --git a/tests/failing-issue2017-missing-tag.sh b/tests/failing-issue2017-missing-tag.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue2017-missing-tag.sh @@ -0,0 +1,85 @@ +#!/usr/bin/env bash +## Test for issue2017 - apply should gracefully handle tag missing +## from context (complain, not crash) +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init --repo R # Create our test repos. + +cd R +echo 'Example content.' > f +darcs record -lam 'Add f' +cd .. + +# variant 0 - this passes trivially +darcs get R R0 +darcs get R0 S0 +darcs tag 's' --repo S0 +darcs get S0 T0 +cd T0 +echo 'More content.' > f +darcs record -lam 'Modify f' +darcs send -o foo.dpatch -a +cd .. +not darcs apply --repo R0 T0/foo.dpatch > log 2>&1 +not grep bug log +grep missing log + +# variant 1 - tag in shared context +darcs get R R1 +darcs tag '1' --repo R1 +darcs get R1 S1 +darcs tag 's1' --repo S1 +darcs get S1 T1 +cd T1 +echo 'More content.' > f +darcs record -lam 'Modify f' +darcs send -o foo.dpatch -a +cd .. +# sanity check: should be able to cherry pick +darcs get R1 R1b +cd R1b +[ `darcs changes --count` -eq 2 ] +darcs pull ../T1 --match 'touch f' --all +[ `darcs changes --count` -eq 3 ] +cd .. +# the test: can't apply this due to incorrect context +not darcs apply --repo R1 T1/foo.dpatch > log 2>&1 +not grep 'bug' log +grep missing log + +# variant 2 - tag created after the fact +darcs get R R2 +darcs get R2 S2 +darcs tag 's2' --repo S2 +darcs get S2 T2 +cd T2 +echo 'More content.' > f +darcs record -lam 'Modify f' +darcs send -o foo.dpatch -a +cd .. +darcs tag '2' --repo R2 # only tag after +not darcs apply --repo R2 T2/foo.dpatch > log 2>&1 +not grep 'bug' log +grep missing log diff --git a/tests/failing-issue612_repo_not_writable.sh b/tests/failing-issue612_repo_not_writable.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue612_repo_not_writable.sh @@ -0,0 +1,39 @@ +#!/usr/bin/env bash + +# Test that darcs fails appropriately when the target repo inventory file is not writable. +# See issue612 + +. lib + +abort_windows + +if grep old-fashioned .darcs/defaults; then + exit 200 +fi + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +touch t.t +darcs add t.t +darcs record -am "initial add" +if [ -e _darcs/inventories ]; then + chmod 0555 _darcs/inventories/* + chmod 0555 _darcs/inventories +fi +if [ -e _darcs/inventory ]; then + chmod 0555 _darcs/inventory +fi +cd .. + +darcs get temp1 temp2 +cd temp2 +# this block may fail so we'd better make sure we clean up after +# ourselves to avoid a permissions mess for other tests +trap "cd ..; chmod -R 0755 temp1; rm -rf temp1 temp2" EXIT +echo new >> t.t +darcs record -am "new patch" +not darcs push -a ../temp1 2> log +grep failed log + diff --git a/tests/hunk-editor.sh b/tests/hunk-editor.sh new file mode 100644 --- /dev/null +++ b/tests/hunk-editor.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +## Test for hunk editor +## +## Copyright (C) 2011 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. + +darcs init --repo R + +cd R + +echo 'version1' > file +darcs record -lam "version1" + +echo 'version2' > file +(echo e ; echo y ; echo n) | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" + +cat > expected < _darcs/format < +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +TESTDATA=repos # remove this line in HEAD + +. lib # Load some portability helpers. +tar zxf $TESTDATA/badrepo.tgz +not darcs get badrepo diff --git a/tests/issue612_repo_not_writeable.sh b/tests/issue612_repo_not_writeable.sh deleted file mode 100644 --- a/tests/issue612_repo_not_writeable.sh +++ /dev/null @@ -1,42 +0,0 @@ -#!/usr/bin/env bash - -# Test that darcs fails appropriately when the target repo inventory file is not writable. -# See issue612 - -. lib - -abort_windows - -if grep old-fashioned .darcs/defaults; then - echo This test does not work with old-fashioned inventories - exit 0 -fi - -rm -rf temp1 temp2 -mkdir temp1 -cd temp1 -darcs init -touch t.t -darcs add t.t -darcs record -am "initial add" -if [ -e _darcs/inventories ]; then - chmod 0555 _darcs/inventories/* - chmod 0555 _darcs/inventories -fi -if [ -e _darcs/inventory ]; then - chmod 0555 _darcs/inventory -fi -cd .. - -darcs get temp1 temp2 -cd temp2 -echo new >> t.t -darcs record -am "new patch" -not darcs push -a ../r1 2> log -grep failed log -cd .. - -chmod -R 0755 temp1 -rm -rf temp1 temp2 - - diff --git a/tests/lib b/tests/lib --- a/tests/lib +++ b/tests/lib @@ -13,7 +13,7 @@ } pwd() { - ghc --make "$TESTS_WD/hspwd.hs" + ghc --make "$TESTS_WD/hspwd.hs" > /dev/null "$TESTS_WD/hspwd" } diff --git a/tests/repoformat.sh b/tests/repoformat.sh --- a/tests/repoformat.sh +++ b/tests/repoformat.sh @@ -2,13 +2,117 @@ . lib -rm -rf temp1 temp2 -mkdir temp1 -cd temp1 +rm -rf garbage future +mkdir garbage +cd garbage darcs init echo gobbledygook > _darcs/format cd .. -not darcs get temp1 temp2 2> log +mkdir future +cd future +darcs init +touch titi +darcs add titi +darcs record -am titi +cat > _darcs/format < log grep -i "can't understand repository format" log -rm -rf temp1 temp2 log +rm -rf temp1 log + +# pull from garbage repo +mkdir temp1 +cd temp1 +darcs init +not darcs pull ../garbage 2> log +grep -i "can't understand repository format" log +cd .. +rm -rf temp1 + +# apply in garbage repo +mkdir temp1 +cd temp1 +darcs init +darcs changes --context > empty-context +darcs tag -m "just a patch" +darcs send -a --context=empty-context -o ../bundle.dpatch . +cd ../garbage +not darcs apply ../bundle.dpatch 2> log +grep -i "can't understand repository format" log +cd .. +rm -rf temp1 bundle.dpatch + +# add in garbage repo +cd garbage +touch toto +not darcs add toto 2> log +grep -i "can't understand repository format" log +cd .. + +rm -rf garbage + + +## future repo: we don't understand one +# alternative of a line of format +# only look at future vs darcs2 + +if grep 'old-fashioned' .darcs/defaults; then + exit 200 +fi + +if grep hashed .darcs/defaults; then + exit 200 +fi + +# get future repo: ok +# --to-match is needed because of bug### +darcs get future temp1 --to-match "name titi" +cd temp1 +darcs changes +touch toto +darcs add toto +darcs record -am 'blah' +cd .. +rm -rf temp1 + +# pull from future repo: ok +mkdir temp1 +cd temp1 +darcs init +darcs pull ../future -a +darcs cha | grep titi +cd .. +rm -rf temp1 + +# apply in future repo: !ok +mkdir temp1 +cd temp1 +darcs init +darcs changes --context > empty-context +darcs tag -m "just a patch" +darcs send -a --context=empty-context -o ../bundle.dpatch . +cd ../future +not darcs apply ../bundle.dpatch 2> log +cat log +grep -i "can't write repository format" log +cd .. +rm -rf temp1 bundle.dpatch + +# record in future repo: !ok +cd future +touch toto +not darcs add toto 2> log +grep -i "can't write repository format" log +cd .. + +rm -rf future #No future! diff --git a/tests/repos/badrepo.tgz b/tests/repos/badrepo.tgz new file mode 100644 Binary files /dev/null and b/tests/repos/badrepo.tgz differ diff --git a/tests/set-default-hint.sh b/tests/set-default-hint.sh new file mode 100644 --- /dev/null +++ b/tests/set-default-hint.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash +## Test that set-default hint messages are produced at the right times +## +## Copyright (C) 2011 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R1 R2 R3 # Another script may have left a mess. + +darcs init --repo R1 +darcs get R1 R2 +darcs get R1 R3 + +HINTSTRING="issue the same command with the --set-default flag" + +cd R3 +for command in pull push send +do + # R1 should be the default for R3 + darcs $command ../R1 | not grep "$HINTSTRING" + darcs $command ../R2 | grep "$HINTSTRING" + + # can disable message on the command-line + darcs $command --no-set-default ../R2 | not grep "$HINTSTRING" + + # or using defaults + echo "$command no-set-default" >> ../.darcs/defaults + darcs $command ../R2 | not grep "$HINTSTRING" + + darcs $command --set-default ../R2 | not grep "$HINTSTRING" + darcs $command --set-default ../R1 | not grep "$HINTSTRING" +done