darcs 2.8.3 → 2.8.4
raw patch · 52 files changed
+866/−144 lines, 52 filesdep +FindBindep +Win32dep +utf8-stringdep ~basedep ~bytestringdep ~containerssetup-changedbinary-added
Dependencies added: FindBin, Win32, utf8-string
Dependency ranges changed: base, bytestring, containers, directory, haskeline, network, tar, unix
Files
- NEWS +6/−0
- Setup.lhs +108/−9
- darcs.cabal +88/−31
- release/distributed-context +1/−1
- release/distributed-version +1/−1
- src/ByteStringUtils.hs +6/−10
- src/Darcs/ColorPrinter.hs +4/−2
- src/Darcs/Commands/Add.hs +3/−1
- src/Darcs/Commands/Annotate.hs +5/−9
- src/Darcs/Commands/Changes.hs +3/−2
- src/Darcs/Commands/Check.hs +5/−1
- src/Darcs/Commands/Get.hs +4/−1
- src/Darcs/Commands/MarkConflicts.hs +6/−2
- src/Darcs/Commands/Record.hs +5/−2
- src/Darcs/Commands/Replace.hs +5/−2
- src/Darcs/Commands/Revert.hs +5/−1
- src/Darcs/Commands/Rollback.hs +4/−1
- src/Darcs/Commands/Send.hs +5/−1
- src/Darcs/Commands/ShowAuthors.hs +4/−1
- src/Darcs/Commands/Test.hs +3/−0
- src/Darcs/Commands/TrackDown.hs +4/−3
- src/Darcs/Commands/Unrecord.hs +5/−1
- src/Darcs/Commands/Unrevert.hs +5/−1
- src/Darcs/Compat.hs +2/−1
- src/Darcs/External.hs +8/−5
- src/Darcs/Match.hs +6/−3
- src/Darcs/MonadProgress.hs +2/−0
- src/Darcs/Repository.hs +23/−0
- src/Darcs/Repository/HashedRepo.hs +5/−2
- src/Darcs/Repository/Internal.hs +5/−1
- src/Darcs/Repository/Old.hs +7/−2
- src/Darcs/Repository/Prefs.hs +4/−0
- src/Darcs/Repository/Repair.hs +4/−2
- src/Darcs/Repository/State.hs +3/−2
- src/Darcs/Utils.hs +2/−1
- src/Encoding.hs +46/−0
- src/Encoding/IConv.hsc +184/−0
- src/Encoding/Win32.hs +80/−0
- src/URL/Curl.hs +2/−1
- src/URL/HTTP.hs +5/−2
- src/Workaround.hs +6/−3
- src/h_iconv.c +18/−0
- src/h_iconv.h +9/−0
- src/test.hs +34/−8
- src/win32/System/Posix.hs +2/−1
- src/win32/System/Posix/Files.hsc +2/−1
- tests/data/metadata-encoding.tgz binary
- tests/harness.sh +3/−3
- tests/issue2199-get-dirty-tag.sh +50/−0
- tests/issue2286-metadata-encoding.sh +34/−0
- tests/lib +27/−19
- tests/utf8.sh +8/−4
NEWS view
@@ -1,3 +1,9 @@+ * GHC 7.6 support+ * Bump some dependencies: base, network, unix, containers, bytestring, tar+ * Resolved issue2199: get --tag can include extra patches+ * Remove the --xml-output option to annotate: it stopped having any effect some time ago++ Darcs 2.8.3, 4 November 2012 * Darcs API: #ifdef some FFI imports so ghci works with -f-curl
Setup.lhs view
@@ -2,18 +2,23 @@ {-# LANGUAGE CPP #-} -- copyright (c) 2008 Duncan Coutts -- portions copyright (c) 2008 David Roundy+-- portions copyright (c) 2007-2009 Judah Jacobson import Prelude hiding ( catch ) import qualified Prelude +import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.ModuleName( toFilePath ) import Distribution.PackageDescription ( PackageDescription(executables), Executable(buildInfo, exeName) , BuildInfo(customFieldsBI), emptyBuildInfo- , updatePackageDescription, cppOptions, ccOptions- , library, libBuildInfo, otherModules )+ , FlagName(FlagName)+ , updatePackageDescription+ , cppOptions, ccOptions, ldOptions+ , library, libBuildInfo, otherModules+ , extraLibs, extraLibDirs, includeDirs ) import Distribution.Package ( packageVersion, packageName, PackageName(..) ) import Distribution.Version@@ -22,16 +27,19 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), absoluteInstallDirs, externalPackageDeps ) import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))+import Distribution.Simple.PackageIndex ( topologicalOrder )+import Distribution.Simple.Program ( gccProgram, rawSystemProgramStdoutConf ) import Distribution.Simple.Setup (buildVerbosity, copyDest, copyVerbosity, fromFlag,- haddockVerbosity, installVerbosity, sDistVerbosity)+ haddockVerbosity, installVerbosity, sDistVerbosity,+ configVerbosity, ConfigFlags, configConfigurationsFlags) import Distribution.Simple.BuildPaths ( autogenModulesDir, exeExtension ) import Distribution.System ( OS(Windows), buildOS ) import Distribution.Simple.Utils (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,- rewriteFile)+ rewriteFile, withTempFile) import Distribution.Verbosity ( Verbosity ) import Distribution.Text@@ -39,13 +47,19 @@ import Distribution.Package (Package) import Control.Monad ( zipWithM_, when, unless, filterM )-import Control.Exception ( bracket )+import Control.Exception ( bracket, handle, IOException ) import System.Directory (copyFile, createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents,- removeDirectoryRecursive, removeFile, setCurrentDirectory)-import System.IO (openFile, IOMode (..))+ removeDirectoryRecursive, removeFile, setCurrentDirectory,+ getTemporaryDirectory+ )+import System.Exit ( ExitCode(ExitSuccess) )+import System.IO+ ( openFile, IOMode (..), stdout+ , hPutStr, hFlush, hClose+ ) import System.Process (runProcess) import System.IO.Error ( isDoesNotExistError ) import Data.List( isPrefixOf, isSuffixOf, sort, partition )@@ -121,6 +135,20 @@ sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] } sDistHook simpleUserHooks pkg' lbi hooks flags+ ,+ confHook =+ if buildOS == Windows+ then confHook simpleUserHooks+ else+ \genericDescript flags -> do+ lbi <- confHook simpleUserHooks genericDescript flags+ let pkgDescr = localPkgDescr lbi+ let Just lib = library pkgDescr+ let bi = libBuildInfo lib+ bi' <- maybeSetLibiconv flags bi lbi+ return lbi {localPkgDescr = pkgDescr {+ library = Just lib {+ libBuildInfo = bi'}}} } -- | For @./Setup build@ and @./Setup haddock@, do some unusual@@ -200,7 +228,7 @@ versionPatches verbosity darcsVersion = do numPatchesDarcs <- do out <- rawSystemStdout verbosity "darcs"- ["changes", "--from-tag", display darcsVersion, "--count"]+ ["changes", "-a", "--from-tag", display darcsVersion, "--count"] case reads (out) of ((n,_):_) -> return $ Just ((n :: Int) - 1) _ -> return Nothing@@ -238,7 +266,7 @@ contextDarcs <- do inrepo <- doesDirectoryExist "_darcs" unless inrepo $ fail "Not a repository."- out <- rawSystemStdout verbosity "darcs" ["changes", "--context"]+ out <- rawSystemStdout verbosity "darcs" ["changes", "-a", "--context"] return $ Just out `catchAny` \_ -> return Nothing @@ -258,5 +286,76 @@ ((s,_):_) -> return s _ -> return Nothing else return Nothing++-- Test whether compiling a c program that links against libiconv needs -liconv.+maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo+maybeSetLibiconv flags bi lbi = do+ let biWithIconv = addIconv bi+ let verb = fromFlag (configVerbosity flags)+ if hasFlagSet flags (FlagName "libiconv")+ then do+ putStrLn "Using -liconv."+ return biWithIconv+ else do+ putStr "checking whether to use -liconv... "+ hFlush stdout+ worksWithout <- tryCompile iconv_prog bi lbi verb+ if worksWithout+ then do+ putStrLn "not needed."+ return bi+ else do+ worksWith <- tryCompile iconv_prog biWithIconv lbi verb+ if worksWith+ then do+ putStrLn "using -liconv."+ return biWithIconv+ else error "Unable to link against the iconv library."++hasFlagSet :: ConfigFlags -> FlagName -> Bool+hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)++tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool+tryCompile program bi lbi verb = handle processExit $ handle processException $ do+ tempDir <- getTemporaryDirectory+ withTempFile tempDir ".c" $ \fname cH ->+ withTempFile tempDir "" $ \execName oH -> do+ hPutStr cH program+ hClose cH+ hClose oH+ -- TODO take verbosity from the args.+ rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi)+ (fname : "-o" : execName : args)+ return True+ where+ processException :: IOException -> IO Bool+ processException e = return False+ processExit = return . (==ExitSuccess)+ -- Mimicing Distribution.Simple.Configure+ deps = topologicalOrder (installedPkgs lbi)+ args = concat+ [ ccOptions bi+ , cppOptions bi+ , ldOptions bi+ -- --extra-include-dirs and --extra-lib-dirs are included+ -- in the below fields.+ -- Also sometimes a dependency like rts points to a nonstandard+ -- include/lib directory where iconv can be found. + , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)+ , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)+ , map ("-l" ++) (extraLibs bi)+ ]++addIconv :: BuildInfo -> BuildInfo+addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}++iconv_prog :: String+iconv_prog = unlines $+ [ "#include <iconv.h>"+ , "int main(void) {"+ , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"+ , " return 0;"+ , "}"+ ] \end{code}
darcs.cabal view
@@ -1,5 +1,5 @@ Name: darcs-version: 2.8.3+version: 2.8.4 License: GPL License-file: COPYING Author: David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>@@ -129,6 +129,14 @@ the behaviour of filenames that requires API calls in base 4.5 to workaround. So base 4.4 is not supported at all. +-- Note that the Setup script checks whether -liconv is necessary. This flag+-- lets us override that decision. When it is True, we use -liconv. When it+-- is False, we run tests to decide.+flag libiconv+ Description: Explicitly link against the libiconv library.+ Default: False++ -- ---------------------------------------------------------------------- -- darcs library -- ----------------------------------------------------------------------@@ -139,7 +147,7 @@ else buildable: True - build-tools: ghc >= 6.10 && < 7.6+ build-tools: ghc >= 6.10 && < 7.8 hs-source-dirs: src include-dirs: src@@ -312,6 +320,7 @@ Darcs.Witnesses.Unsafe Darcs.Witnesses.WZipper DateMatcher+ Encoding English Exec ByteStringUtils@@ -342,22 +351,28 @@ hs-source-dirs: src/win32 include-dirs: src/win32 other-modules: CtrlC+ Encoding.Win32 System.Posix System.Posix.Files System.Posix.IO cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2,+ Win32 >= 2.0, regex-posix >= 0.95.1+ else+ other-modules: Encoding.IConv+ c-sources: src/h_iconv.c+ build-depends: utf8-string >= 0.3.6 && < 0.4 if os(solaris) cc-options: -DHAVE_SIGINFO_H if os(windows)- build-depends: base >= 4 && < 4.6+ build-depends: base >= 4 && < 4.7 else if flag(force-char8-encoding)- build-depends: base >= 4.5 && < 4.6+ build-depends: base >= 4.5 && < 4.7 cpp-options: -DFORCE_CHAR8_ENCODING else build-depends: base >= 4 && < 4.4@@ -368,20 +383,24 @@ parsec >= 2.0 && < 3.2, html == 1.0.*, filepath >= 1.1.0.0 && < 1.5.0.0,- haskeline >= 0.6.3 && < 0.7,+ haskeline >= 0.6.3 && < 0.8, hashed-storage >= 0.5.6 && < 0.6, vector >= 0.7,- tar == 0.3.*+ tar >= 0.3 && < 0.5 + if impl(ghc<7.0)+ -- haskeline 0.6.4.7 doesn't build with ghc 6.12+ build-depends: haskeline <= 0.6.4.6+ if !os(windows)- build-depends: unix >= 1.0 && < 2.6+ build-depends: unix >= 1.0 && < 2.7 - build-depends: bytestring >= 0.9.0 && < 0.10,+ build-depends: bytestring >= 0.9.0 && < 0.11, text >= 0.11.0.6 && < 0.12.0.0, old-time >= 1.0 && < 1.2,- directory >= 1.0.0.0 && < 1.2.0.0,+ directory >= 1.0.0.0 && < 1.3.0.0, process >= 1.0.0.0 && < 1.2.0.0,- containers >= 0.1 && < 0.5,+ containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, random == 1.0.* @@ -411,7 +430,7 @@ cc-options: -DHAVE_CURL if flag(http)- build-depends: network >= 2.2 && < 2.4,+ build-depends: network >= 2.2 && < 2.5, HTTP >= 4000.0.8 && < 4000.3 cpp-options: -DHAVE_HTTP x-have-http:@@ -452,6 +471,12 @@ extensions: NoMonoLocalBinds + if impl(ghc>=7.6)+ -- in ghc < 7.6 we need to import Prelude hiding (catch)+ -- in ghc >= 7.6 catch isn't in Prelude+ ghc-options: -fno-warn-dodgy-imports++ -- ---------------------------------------------------------------------- -- darcs itself -- ----------------------------------------------------------------------@@ -461,7 +486,7 @@ buildable: False else buildable: True- build-tools: ghc >= 6.10 && < 7.6+ build-tools: ghc >= 6.10 && < 7.8 main-is: darcs.hs hs-source-dirs: src@@ -509,16 +534,23 @@ cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2,+ Win32 >= 2.0, regex-posix >= 0.95.1+ else+ c-sources: src/h_iconv.c+ build-depends: utf8-string >= 0.3.6 && < 0.4+ -- need to list this explicitly to get cabal to run hsc2hs+ other-modules: Encoding.IConv + if os(solaris) cc-options: -DHAVE_SIGINFO_H if os(windows)- build-depends: base >= 4 && < 4.6+ build-depends: base >= 4 && < 4.7 else if flag(force-char8-encoding)- build-depends: base >= 4.5 && < 4.6+ build-depends: base >= 4.5 && < 4.7 cpp-options: -DFORCE_CHAR8_ENCODING else build-depends: base >= 4 && < 4.4@@ -529,20 +561,24 @@ parsec >= 2.0 && < 3.2, html == 1.0.*, filepath >= 1.1.0.0 && < 1.5.0.0,- haskeline >= 0.6.3 && < 0.7,+ haskeline >= 0.6.3 && < 0.8, hashed-storage >= 0.5.6 && < 0.6, vector >= 0.7,- tar == 0.3.*+ tar >= 0.3 && < 0.5 + if impl(ghc<7.0)+ -- haskeline 0.6.4.7 doesn't build with ghc 6.12+ build-depends: haskeline <= 0.6.4.6+ if !os(windows)- build-depends: unix >= 1.0 && < 2.6+ build-depends: unix >= 1.0 && < 2.7 - build-depends: bytestring >= 0.9.0 && < 0.10,+ build-depends: bytestring >= 0.9.0 && < 0.11, text >= 0.11.0.6 && < 0.12.0.0, old-time >= 1.0 && < 1.2,- directory >= 1.0.0.0 && < 1.2.0.0,+ directory >= 1.0.0.0 && < 1.3.0.0, process >= 1.0.0.0 && < 1.2.0.0,- containers >= 0.1 && < 0.5,+ containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, random == 1.0.* @@ -554,7 +590,7 @@ cc-options: -DHAVE_CURL if flag(http)- build-depends: network >= 2.2 && < 2.4,+ build-depends: network >= 2.2 && < 2.5, HTTP >= 4000.0.8 && < 4000.3 cpp-options: -DHAVE_HTTP x-have-http:@@ -595,6 +631,11 @@ extensions: NoMonoLocalBinds + if impl(ghc>=7.6)+ -- in ghc < 7.6 we need to import Prelude hiding (catch)+ -- in ghc >= 7.6 catch isn't in Prelude+ ghc-options: -fno-warn-dodgy-imports+ -- ---------------------------------------------------------------------- -- unit test driver -- ----------------------------------------------------------------------@@ -602,7 +643,7 @@ Executable darcs-test main-is: test.hs - build-tools: ghc >= 6.10 && < 7.6+ build-tools: ghc >= 6.10 && < 7.8 if !flag(test)@@ -616,6 +657,7 @@ parsec >= 2.0 && < 3.2, html == 1.0.*, filepath >= 1.1.0.0 && < 1.5.0.0,+ FindBin >= 0.0 && < 0.1, QuickCheck >= 2.3, HUnit >= 1.0, cmdlib >= 0.2.1 && < 0.4,@@ -702,36 +744,46 @@ cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2,+ Win32 >= 2.0, regex-posix >= 0.95.1+ else+ c-sources: src/h_iconv.c+ build-depends: utf8-string >= 0.3.6 && < 0.4+ -- need to list this explicitly to get cabal to run hsc2hs+ other-modules: Encoding.IConv if os(solaris) cc-options: -DHAVE_SIGINFO_H if os(windows)- build-depends: base >= 4 && < 4.6+ build-depends: base >= 4 && < 4.7 else if flag(force-char8-encoding)- build-depends: base >= 4.5 && < 4.6+ build-depends: base >= 4.5 && < 4.7 cpp-options: -DFORCE_CHAR8_ENCODING else build-depends: base >= 4 && < 4.4 if !os(windows)- build-depends: unix >= 1.0 && < 2.6+ build-depends: unix >= 1.0 && < 2.7 - build-depends: bytestring >= 0.9.0 && < 0.10,- haskeline >= 0.6.3 && < 0.7,+ build-depends: bytestring >= 0.9.0 && < 0.11,+ haskeline >= 0.6.3 && < 0.8, text >= 0.11.0.6 && < 0.12.0.0, old-time >= 1.0 && < 1.2,- directory >= 1.0.0.0 && < 1.2.0.0,+ directory >= 1.0.0.0 && < 1.3.0.0, process >= 1.0.0.0 && < 1.2.0.0,- containers >= 0.1 && < 0.5,+ containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, hashed-storage >= 0.5.6 && < 0.6, vector >= 0.7,- tar == 0.3.*,+ tar >= 0.3 && < 0.5, random == 1.0.* + if impl(ghc<7.0)+ -- haskeline 0.6.4.7 doesn't build with ghc 6.12+ build-depends: haskeline <= 0.6.4.6+ if flag(mmap) && !os(windows) build-depends: mmap >= 0.5 && < 0.6 cpp-options: -DHAVE_MMAP@@ -744,7 +796,7 @@ cpp-options: -DHAVE_TERMINFO if flag(http)- build-depends: network >= 2.2 && < 2.4,+ build-depends: network >= 2.2 && < 2.5, HTTP >= 4000.0.8 && < 4000.3 if flag(color)@@ -768,3 +820,8 @@ if impl(ghc>=7.0) extensions: NoMonoLocalBinds++ if impl(ghc>=7.6)+ -- in ghc < 7.6 we need to import Prelude hiding (catch)+ -- in ghc >= 7.6 catch isn't in Prelude+ ghc-options: -fno-warn-dodgy-imports
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.8.3\nGanesh Sittampalam <ganesh@earth.li>**20121104174910\n Ignore-this: 3198f6deecf3d1b44df6e05a2657d9ca\n] \n"+Just "\nContext:\n\n[TAG 2.8.4\nGanesh Sittampalam <ganesh@earth.li>**20130127231845\n Ignore-this: d032f69540341ecfd5858fce7aee1457\n] \n\n[Resolve issue2155: Expurgate the non-functional annotate --xml-output option\nDave Love <fx@gnu.org>**20130127231835\n Ignore-this: eb03207031e75687968091d56fb008f8\n backported from HEAD by Ganesh Sittampalam <ganesh@earth.li>\n] \n\n[Resolve issue2155: Expurgate the non-functional annotate --xml-output option\nDave Love <fx@gnu.org>**20130120121739\n Ignore-this: 8a9ce6409a50b71cd0d2fdabbc181b1a\n backported from HEAD by Ganesh Sittampalam <ganesh@earth.li>\n] \n\n[note dependency bumps in NEWS\nGanesh Sittampalam <ganesh@earth.li>**20130120170310\n Ignore-this: 48cf181c89ec1b69fc6e9e701734ff19\n] \n\n[bump version to 2.8.4\nGanesh Sittampalam <ganesh@earth.li>**20130120154856\n Ignore-this: 2f2542e9825b66cda3a0a17275b5e311\n] \n\n[resolve issue2199: getMatchingTag needs to commute for dirty tags\nGanesh Sittampalam <ganesh@earth.li>**20121218191024\n Ignore-this: 947252cd8e084b793044aff564f0462d\n backported from HEAD\n] \n\n[accept issue2199: darcs get --tag gets too much\nGanesh Sittampalam <ganesh@earth.li>**20120528164525\n Ignore-this: 8c138a80c294e6181a3ef9250593fa31\n] \n\n[constrain haskeline version on old GHC\nGanesh Sittampalam <ganesh@earth.li>**20130119234432\n Ignore-this: 8af00cc3d3c1ad223a8b35712c06bae\n] \n\n[Add option -a to darcs changes in Setup.lhs\nBen Franksen <ben.franksen@online.de>**20120811195807\n Ignore-this: f23d2e558f7248fec8d07b0391d9a7e8\n \n Some (potential) contributors (like me) have 'changes interactive'\n in their ~/.darcs/defaults and then wonder why their build hangs.\n] \n\n[add copyright notices for the imported haskeline code\nGanesh Sittampalam <ganesh@earth.li>**20130119163610\n Ignore-this: afcdc8048f8b3233fa17d3ab0c9c311f\n licence/copyright taken from haskeline 0.6.4.7:\n BSD3, copyright Judah Jacobson\n] \n\n[import encoding code from haskeline: switch over\nGanesh Sittampalam <ganesh@earth.li>**20130118231907\n Ignore-this: b423a92ba93e74520d0578ac21aceab3\n] \n\n[import encoding code from haskeline: source files\nGanesh Sittampalam <ganesh@earth.li>**20130118225947\n Ignore-this: c2d1e228fa4cce3e66e90a14fa2f3200\n] \n\n[import encoding code from haskeline: cabal file changes\nGanesh Sittampalam <ganesh@earth.li>**20130118070642\n Ignore-this: d2ed13887d0c547cb7498bd5a2aef46f\n] \n\n[import encoding code from haskeline: Setup.lhs changes\nGanesh Sittampalam <ganesh@earth.li>**20130115181040\n Ignore-this: 31ccdca76001bff769464fb7a8e574e9\n] \n\n[ROLLBACK: conditionally use bytestring-handle\nGanesh Sittampalam <ganesh@earth.li>**20130111213829\n Ignore-this: d3c18b61f765bdfcb574b4977185197b\n It doesn't skip invalid byte sequences when decoding so breaks on \n repositories with non-UTF8 encoded metadata.\n] \n\n[bump network dependency\nGanesh Sittampalam <ganesh@earth.li>**20130111184607\n Ignore-this: 54e55fa09793008d55572b6acad1a7b8\n] \n\n[add some comments about \"nearby\" darcs, and print out the one that was found\nGanesh Sittampalam <ganesh@earth.li>**20130111211817\n Ignore-this: 57385f3248fc539435ed9de069a40bd5\n backported from HEAD\n] \n\n[make darcs-test look \"nearby\" for a darcs exe to use\nGanesh Sittampalam <ganesh@earth.li>**20130111211445\n Ignore-this: d952cf330c0d9510c5c973dd41b191e0\n backported from HEAD\n] \n\n[need different path separator on Windows\nGanesh Sittampalam <ganesh@earth.li>**20121219191221\n Ignore-this: 42c7ba1e46f5b6b600d23838e5a162cb\n] \n\n[test for issue2286: make sure we can read repos with non-UTF8 metadata\nGanesh Sittampalam <ganesh@earth.li>**20130102222735\n Ignore-this: adc6165d5d5d991383ebf0e6547f7bf4\n] \n\n[We can use chcp to switch encodings on Windows\nGanesh Sittampalam <ganesh@earth.li>**20130101122254\n Ignore-this: bc115467e31e144694a33e43dca3fb6c\n This means that the tests that require different encodings can run.\n] \n\n[Find latin9 locale on OS X too\nMichael Hendricks <michael@ndrix.org>**20120420202408\n Ignore-this: c87db3b97312234ed2380d2ca11a8ca0\n \n Most Linux systems describe latin9 as \"iso885915\". OS X\n describes it with \"ISO8859-15\". The new regex catches both.\n] \n\n[windows test fix: replace shell script with a Haskell program\nGanesh Sittampalam <ganesh@earth.li>**20121231224332\n Ignore-this: de01ab8647e7d62c18d8c266d514b054\n] \n\n[unsetting DARCS_TEST_PREFS_DIR in utf8 test doesn't seem to be necessary\nGanesh Sittampalam <ganesh@earth.li>**20130101120246\n Ignore-this: ed74710d8b358b920d742e86a7f008d8\n \n It was causing problems on Windows because getAppUserDataDirectory\n still returns the normal user directory.\n \n It also means that the repository type choice isn't picked up.\n] \n\n[improve diagnostics when utf8 test fails\nGanesh Sittampalam <ganesh@earth.li>**20121231224600\n Ignore-this: 63db587bc36f8826c66dc6913a4fdb2d\n] \n\n[need to do case-insensitive comparison on Windows\nGanesh Sittampalam <ganesh@earth.li>**20121228214823\n Ignore-this: ef309d4aef22e87d5c3da3222926af0e\n] \n\n[update NEWS\nGanesh Sittampalam <ganesh@earth.li>**20121216202654\n Ignore-this: aef3e47204a4157504f90554ffc3a327\n] \n\n[conditionally use bytestring-handle instead of haskeline for encoding\nGanesh Sittampalam <ganesh@earth.li>**20121216201745\n Ignore-this: fd758796b689d090d01e003e660e405\n This is transitional because we need to support GHC 6.10: we can switch\n over to bytestring-handle unconditionally on HEAD.\n] \n\n[bump deps for GHC 7.6/latest hackage\nGanesh Sittampalam <ganesh@earth.li>**20121216201543\n Ignore-this: 77829b074a4bff635a421879bdd04be0\n] \n\n[conditionally support tar 0.4\nGanesh Sittampalam <ganesh@earth.li>**20121216201014\n Ignore-this: 8eff0330e6af196727bdd736ef31db25\n] \n\n[recent test-framework seems to require Typeable\nGanesh Sittampalam <ganesh@earth.li>**20121216175601\n Ignore-this: a8cce6b69984bfc2335b5c19688950b3\n] \n\n[stop using Prelude.catch\nGanesh Sittampalam <ganesh@earth.li>**20121216163240\n Ignore-this: b4bfc48775b3337f8f7ebe275be1a058\n \n backported from HEAD\n] \n\n[import constructors of C types to deal with a GHC change\nGanesh Sittampalam <ganesh@earth.li>**20120401132500\n Ignore-this: ab7cf2fb5e9a2494c14fe7394200da9b\n] \n\n[TAG 2.8.3\nGanesh Sittampalam <ganesh@earth.li>**20121104174910\n Ignore-this: 3198f6deecf3d1b44df6e05a2657d9ca\n] \n"
release/distributed-version view
@@ -1,1 +1,1 @@-Just 0+Just 1
src/ByteStringUtils.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-} -----------------------------------------------------------------------------@@ -70,12 +71,12 @@ #endif import System.IO import System.IO.Unsafe ( unsafePerformIO )-import System.Console.Haskeline ( InputT, runInputTBehavior, defaultSettings, useFileHandle )-import System.Console.Haskeline.Encoding ( decode, encode ) +import Encoding ( decode, encode )+ import Foreign.Storable ( peekElemOff, peek ) import Foreign.Marshal.Array ( advancePtr )-import Foreign.C.Types ( CInt )+import Foreign.C.Types ( CInt(..) ) import Data.Bits ( rotateL ) import Data.Char ( ord, isSpace )@@ -517,11 +518,6 @@ end = the_s + l findit n the_s --- we use a custom Behavior because otherwise on Windows haskeline tries to--- do hGetEcho on stdin which fails if stdin is e.g. /dev/null-unsafeRunInput :: InputT IO a -> a-unsafeRunInput = unsafePerformIO . runInputTBehavior (useFileHandle stdin) defaultSettings- -- | Test if a ByteString is made of ascii characters isAscii :: B.ByteString -> Bool isAscii = B.all (\w -> w < 128)@@ -531,7 +527,7 @@ -- and above also supply locale conversion with functions with a pure type. -- Unrecognized byte sequences in the input are skipped. decodeLocale :: B.ByteString -> String-decodeLocale = unsafeRunInput . decode+decodeLocale = unsafePerformIO . decode -- | Encode a String to a ByteString with latin1 (i.e., the values of the -- characters become the values of the bytes; if a character value is greater@@ -541,7 +537,7 @@ -- | Encode a String to a ByteString according to the current locale encodeLocale :: String -> B.ByteString-encodeLocale = unsafeRunInput . encode+encodeLocale = unsafePerformIO . encode -- | Take a @String@ that represents byte values and re-decode it acording to -- the current locale.
src/Darcs/ColorPrinter.hs view
@@ -1,6 +1,8 @@ {-# OPTIONS -fno-warn-orphans #-} module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where +import Prelude hiding ( catch )+import Control.Exception ( catch, IOException ) import Debug.Trace ( trace ) import System.IO ( stderr ) import Darcs.External (getTermNColors)@@ -93,8 +95,8 @@ } where getEnvBool s = safeGetEnv s >>= return.(/= "0")- safeGetEnv s = getEnv s `catch` \_ -> return "0"- getEnvString s = getEnv s `catch` \_ -> return ""+ safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0"+ getEnvString s = getEnv s `catch` \(_ :: IOException) -> return "" -- printers
src/Darcs/Commands/Add.hs view
@@ -33,7 +33,9 @@ #include "gadts.h" #include "impossible.h" +import Prelude hiding ( catch ) +import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, liftM ) import Data.List ( (\\), nub ) import Data.Maybe ( isNothing, maybeToList )@@ -269,7 +271,7 @@ "' ... couldn't add parent directory '" ++ parentdir ++ "' to repository" return (cur, Nothing, Nothing)- `catch` \e -> do+ `catch` \(e :: IOException) -> do putWarning opts . text $ msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e return (cur, Nothing, Nothing)
src/Darcs/Commands/Annotate.hs view
@@ -24,7 +24,7 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, summary, unified, machineReadable,- xmloutput, creatorhash,+ creatorhash, fixSubPaths, listRegisteredFiles, matchOne,@@ -34,7 +34,7 @@ import Darcs.Repository.State ( readRecorded ) import Darcs.Repository ( Repository, amInHashedRepository, withRepository, RepoJob(..), readRepo ) import Darcs.Patch.Set ( newset2RL )-import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, xmlSummary, invertRL )+import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL ) import Darcs.Patch.Apply( ApplyState ) import qualified Darcs.Patch ( summary ) import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )@@ -44,7 +44,7 @@ import Darcs.Patch.FileName( fp2fn ) import System.FilePath( (</>) ) import Darcs.RepoPath( toFilePath )-import Darcs.Patch.Info ( humanFriendly, toXml, showPatchInfo )+import Darcs.Patch.Info ( humanFriendly, showPatchInfo ) import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch, getOnePatchset, getNonrangeMatchS ) import Darcs.Lock ( withTempDir ) import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal )@@ -70,7 +70,7 @@ "The --summary option will result in a summarized patch annotation,\n" ++ "similar to `darcs whatsnew'. It has no effect on file annotations.\n" ++ "\n" ++- "By default, output is in a human-readable format. The --xml-output\n" +++ "By default, output is in a human-readable format. The --machine-readable\n" ++ "option can be used to generate output for machine postprocessing.\n" annotate :: DarcsCommand@@ -87,7 +87,6 @@ commandAdvancedOptions = [], commandBasicOptions = [summary,unified, machineReadable,- xmloutput, matchOne, creatorhash, workingRepoDir]} @@ -112,12 +111,9 @@ contextualPrintPatch c p else printPatch p where showpi | MachineReadable `elem` opts = showPatchInfo- | XMLOutput `elem` opts = toXml | otherwise = humanFriendly show_summary :: RepoPatch p => Named p C(x y) -> Doc- show_summary = if XMLOutput `elem` opts- then xmlSummary- else Darcs.Patch.summary+ show_summary = Darcs.Patch.summary annotate' opts [""] repository = annotate' opts [] repository annotate' opts args@[_] repository = do
src/Darcs/Commands/Changes.hs view
@@ -20,12 +20,13 @@ #include "gadts.h" module Darcs.Commands.Changes ( changes, log ) where-import Prelude hiding ( log )+import Prelude hiding ( log, catch ) import Unsafe.Coerce (unsafeCoerce) import Data.List ( intersect, sort, nub, find ) import Data.Maybe ( fromMaybe, fromJust, isJust ) import Control.Arrow ( second )+import Control.Exception ( catch, IOException ) import Control.Monad.State.Strict import Control.Applicative ((<$>)) @@ -126,7 +127,7 @@ Sealed unrec <- case files of Nothing -> return $ Sealed NilFL Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown) repository files- `catch` \_ -> return (Sealed NilFL) -- this is triggered when repository is remote+ `catch` \(_ :: IOException) -> return (Sealed NilFL) -- this is triggered when repository is remote let normfp = fn2fp . normPath . fp2fn undoUnrecordedOnFPs = effectOnFilePaths (invert unrec) recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files
src/Darcs/Commands/Check.hs view
@@ -16,8 +16,12 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.Check ( check, repair ) where++import Prelude hiding ( catch )+ import Control.Monad ( when, unless ) import Control.Applicative( (<$>) )+import Control.Exception ( catch, IOException ) import System.Exit ( ExitCode(..), exitWith ) import System.Directory( renameFile ) @@ -105,7 +109,7 @@ where brokenPristine newpris = do putInfo opts $ text "Looks like we have a difference..."- mc' <- (fmap Just $ readRecorded repository) `catch` (\_ -> return Nothing)+ mc' <- (fmap Just $ readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing) case mc' of Nothing -> do putInfo opts $ text "cannot compute that difference, try repair" putInfo opts $ text "" $$ text "Inconsistent repository"
src/Darcs/Commands/Get.hs view
@@ -19,9 +19,12 @@ module Darcs.Commands.Get ( get, clone ) where +import Prelude hiding ( catch )+ import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, createDirectory ) import Workaround ( getCurrentDirectory )+import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo )@@ -259,7 +262,7 @@ do _ <- tentativelyRemovePatches repository (compression opts) us' tentativelyAddToPending repository opts $ invert $ effect us' finalizeRepositoryChanges repository- apply (invert $ effect ps) `catch` \e ->+ apply (invert $ effect ps) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) makeScriptsExecutable opts (invert $ effect ps)
src/Darcs/Commands/MarkConflicts.hs view
@@ -18,9 +18,13 @@ {-# LANGUAGE CPP #-} module Darcs.Commands.MarkConflicts ( markconflicts ) where++import Prelude hiding ( catch )+ import System.Exit ( ExitCode(..), exitWith ) import Darcs.SignalHandler ( withSignalsBlocked ) import Control.Monad ( unless )+import Control.Exception ( catch, IOException ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag, ignoretimes, workingRepoDir, umaskOption )@@ -96,12 +100,12 @@ " in the working directory.") confirmed <- promptYorn "Are you sure? " unless confirmed $ exitWith ExitSuccess- applyToWorking repository opts (invert pend') `catch` \e ->+ applyToWorking repository opts (invert pend') `catch` \(e :: IOException) -> bug ("Can't undo pending changes!" ++ show e) repository' <- undoUnrec pend withSignalsBlocked $ do addToPending repository' res- _ <- applyToWorking repository' opts res `catch` \e ->+ _ <- applyToWorking repository' opts res `catch` \(e :: IOException) -> bug ("Problem marking conflicts in mark-conflicts!" ++ show e) return () putStrLn "Finished marking conflicts."
src/Darcs/Commands/Record.hs view
@@ -20,9 +20,12 @@ module Darcs.Commands.Record ( record, commit, getDate, getLog, askAboutDepends ) where++import Prelude hiding ( catch )+ import qualified Ratified( hGetContents ) import Control.Applicative ( (<$>) )-import Control.Exception.Extensible ( handleJust )+import Control.Exception.Extensible ( handleJust, catch, IOException ) import Control.Monad ( when, unless ) import System.IO ( stdin ) import Data.List ( sort, isPrefixOf, union )@@ -289,7 +292,7 @@ return (p, thelog, Nothing) gl (LogFile f:fs) = do -- round 1 (patchname)- mlp <- lines `fmap` readLocaleFile f `catch` (\_ -> return [])+ mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return []) firstname <- case (patchname_specified, mlp) of (FlagPatchName p, []) -> return p (_, p:_) -> return p -- logfile trumps prior!
src/Darcs/Commands/Replace.hs view
@@ -19,9 +19,12 @@ module Darcs.Commands.Replace ( replace, defaultToks ) where +import Prelude hiding ( catch )+ import Data.Maybe ( isJust ) import Control.Monad ( unless, filterM ) import Control.Applicative( (<$>) )+import Control.Exception ( catch, IOException ) import Darcs.Commands ( DarcsCommand(..), nodefaults )@@ -141,7 +144,7 @@ files <- filterM (exists work) fs Sealed pswork <- mapSeal concatFL . toFL <$> mapM (repl toks cur work) files addToPending repository pswork- _ <- applyToWorking repository opts pswork `catch` \e ->+ _ <- applyToWorking repository opts pswork `catch` \(e :: IOException) -> fail $ "Can't do replace on working!\n" ++ "Perhaps one of the files already contains '"++ new++"'?\n" ++ show e@@ -190,7 +193,7 @@ maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p C(x y) -> Tree IO -> IO (Maybe (Tree IO)) maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree)- (\_ -> return Nothing)+ (\(_ :: IOException) -> return Nothing) defaultToks :: String defaultToks = "A-Za-z_0-9"
src/Darcs/Commands/Revert.hs view
@@ -16,8 +16,12 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.Revert ( revert ) where++import Prelude hiding ( catch )+ import System.Exit ( ExitCode(..), exitWith ) import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Data.List ( sort ) @@ -112,7 +116,7 @@ Just (p':>_) -> writeUnrevert repository p' rec NilFL Nothing -> writeUnrevert repository (norevert+>+p) rec NilFL when (Debug `elem` opts) $ putStrLn "About to apply to the working directory."- _ <- applyToWorking repository opts (invert p) `catch` \e ->+ _ <- applyToWorking repository opts (invert p) `catch` \(e :: IOException) -> fail ("Unable to apply inverse patch!" ++ show e) return ()) :: IO () putStrLn "Finished reverting."
src/Darcs/Commands/Rollback.hs view
@@ -19,7 +19,10 @@ module Darcs.Commands.Rollback ( rollback ) where +import Prelude hiding ( catch )+ import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode(..) ) import Data.List ( sort )@@ -183,7 +186,7 @@ tentativelyAddToPending repo opts pw withGutsOf repo $ do finalizeRepositoryChanges repo- _ <- applyToWorking repo opts pw `catch` \e ->+ _ <- applyToWorking repo opts pw `catch` \(e :: IOException) -> fail ("error applying rolled back patch to working directory\n" ++ show e) debugMessage "Finished applying unrecorded rollback patch"
src/Darcs/Commands/Send.hs view
@@ -18,12 +18,16 @@ {-# LANGUAGE CPP, TypeOperators #-} module Darcs.Commands.Send ( send ) where++import Prelude hiding ( catch )+ import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) #ifndef HAVE_MAPI import System.Exit ( ExitCode( ExitFailure ) ) #endif import System.IO.Error ( ioeGetErrorString ) import System.IO ( hClose )+import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, forM_ ) import Storage.Hashed.Tree ( Tree ) import Data.List ( intercalate, isPrefixOf, stripPrefix )@@ -282,7 +286,7 @@ (\url -> do putInfo opts . text $ "Posting patch to " ++ url postUrl url (BC.unpack nbody) "message/rfc822")- `catch` const sendmail+ `catch` (\(_ :: IOException) -> sendmail) cleanup opts mailfile generateEmailToString :: [WhatToDo] -> String
src/Darcs/Commands/ShowAuthors.hs view
@@ -17,8 +17,11 @@ module Darcs.Commands.ShowAuthors ( showAuthors ) where +import Prelude hiding ( catch )+ import qualified Ratified( readFile ) import Control.Arrow ((&&&), (***))+import Control.Exception ( catch, IOException ) import Data.List ( isInfixOf, sortBy, groupBy, group, sort) import Data.Ord (comparing) import Data.Char ( toLower, isSpace )@@ -141,7 +144,7 @@ compiledAuthorSpellings opts = do let as_file = ".authorspellings" contents <- (Ratified.readFile -- never unlinked from within darcs- as_file `catch` (\_ -> return ""))+ as_file `catch` (\(_ :: IOException) -> return "")) let parse_results = map (parse sentence as_file) $ lines contents clean 1 parse_results where
src/Darcs/Commands/Test.hs view
@@ -16,6 +16,9 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.Test ( test ) where++import Prelude hiding ( catch )+ import System.Exit ( exitWith ) import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )
src/Darcs/Commands/TrackDown.hs view
@@ -16,10 +16,11 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.TrackDown ( trackdown ) where-import Prelude hiding ( init )+import Prelude hiding ( init, catch ) import System.Exit ( ExitCode(..) ) import System.Cmd ( system ) import System.IO ( hFlush, stdout )+import Control.Exception ( catch, IOException ) import Control.Monad( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults )@@ -107,7 +108,7 @@ test_result <- test if test_result == ExitSuccess then putStrLn "Success!"- else do apply (invert p) `catch` \e -> fail ("Bad patch:\n" ++ show e)+ else do apply (invert p) `catch` \(e :: IOException) -> fail ("Bad patch:\n" ++ show e) makeScriptsExecutable opts (invert p) putStrLn "Trying without the patch:" putDocLn $ description $ invert p@@ -189,5 +190,5 @@ unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches) safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => p C(x y) -> IO ()-safeApply p = apply p `catch` (\msg -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg))+safeApply p = apply p `catch` (\(msg :: IOException) -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg))
src/Darcs/Commands/Unrecord.hs view
@@ -18,6 +18,10 @@ {-# LANGUAGE CPP #-} module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where++import Prelude hiding ( catch )++import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) import Data.Maybe( isJust )@@ -218,7 +222,7 @@ tentativelyAddToPending repository opts $ invert $ effect removed finalizeRepositoryChanges repository debugMessage "Applying patches to working directory..."- _ <- applyToWorking repository opts (invert p_after_pending) `catch` \e ->+ _ <- applyToWorking repository opts (invert p_after_pending) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) return () putStrLn $ "Finished " ++ presentParticiple cmdname ++ "."
src/Darcs/Commands/Unrevert.hs view
@@ -20,6 +20,10 @@ #include "gadts.h" module Darcs.Commands.Unrevert ( unrevert, writeUnrevert ) where++import Prelude hiding ( catch )++import Control.Exception ( catch, IOException ) import System.Exit ( ExitCode(..), exitWith ) import Storage.Hashed.Tree( Tree ) @@ -98,7 +102,7 @@ tentativelyAddToPending repository opts p withSignalsBlocked $ do finalizeRepositoryChanges repository- _ <- applyToWorking repository opts p `catch` \e ->+ _ <- applyToWorking repository opts p `catch` \(e :: IOException) -> fail ("Error applying unrevert to working directory...\n" ++ show e) debugMessage "I'm about to writeUnrevert."
src/Darcs/Compat.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Compat (stdoutIsAPipe, mkStdoutTemp, canonFilename,@@ -15,7 +16,7 @@ #endif import Control.Monad ( unless )-import Foreign.C.Types ( CInt )+import Foreign.C.Types ( CInt(..) ) import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno, eEXIST, getErrno ) import System.Directory ( getCurrentDirectory )
src/Darcs/External.hs view
@@ -17,6 +17,8 @@ sendmailPath, diffProgram, darcsProgram ) where +import Prelude hiding ( catch )+ import qualified Ratified import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( when, zipWithM_, filterM, liftM2 )@@ -34,7 +36,8 @@ findExecutable ) import System.Process ( runProcess, runInteractiveProcess, waitForProcess ) import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )-import Control.Exception.Extensible ( bracket, try, finally, SomeException )+import Control.Exception.Extensible+ ( bracket, try, finally, catch, IOException, SomeException ) import Data.Char ( toUpper ) #if defined (HAVE_MAPI) import Foreign.C ( CString, withCString )@@ -102,7 +105,7 @@ -- |Get the name of the darcs executable (as supplied by @getProgName@) darcsProgram :: IO String darcsProgram = getProgName--- Another option: getEnv "DARCS" `catch` \_ -> getProgName+-- Another option: getEnv "DARCS" `catch` \(_ :: IOException) -> getProgName backupByRenaming :: FilePath -> IO () backupByRenaming = backupBy rename@@ -200,7 +203,7 @@ mk_dest fp = dest </> fp zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') else fail ("cloneTreeExcept: Bad source " ++ source)- `catch` fail ("cloneTreeExcept: Bad source " ++ source)+ `catch` (\(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source)) cloneSubTree :: FilePath -> FilePath -> IO () cloneSubTree source dest =@@ -226,7 +229,7 @@ maybeURLCmd what url = do let prot = map toUpper $ takeWhile (/= ':') url fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))- `catch` \_ -> return Nothing+ `catch` \(_ :: IOException) -> return Nothing speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable #if defined(HAVE_CURL) || defined(HAVE_HTTP)@@ -318,7 +321,7 @@ newline = B.singleton 10 haveSendmail :: IO Bool-haveSendmail = (sendmailPath >> return True) `catch` (\_ -> return False)+haveSendmail = (sendmailPath >> return True) `catch` (\(_ :: IOException) -> return False) -- | Send an email, optionally containing a patch bundle -- (more precisely, its description and the bundle itself)
src/Darcs/Match.hs view
@@ -69,8 +69,8 @@ import Darcs.Patch.Set ( Origin ) #endif import Darcs.Repository.ApplyPatches ( applyPatches )-import Darcs.Patch.Depends ( getPatchesBeyondTag )-import Darcs.Witnesses.Ordered ( RL(..), consRLSealed )+import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag )+import Darcs.Witnesses.Ordered ( RL(..), consRLSealed, (:>)(..) ) import ByteStringUtils ( mmapFilePS ) @@ -388,7 +388,10 @@ getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m getMatchingTag m (PatchSet NilRL (Tagged t _ ps :<: ts)) = getMatchingTag m (PatchSet (t:<:ps) ts) getMatchingTag m (PatchSet (p:<:ps) ts)- | applyMatcher m p = seal $ PatchSet (p:<:ps) ts+ | applyMatcher m p =+ -- found a non-clean tag, need to commute out the things that it doesn't depend on+ case splitOnTag (info p) (PatchSet (p:<:ps) ts) of+ patchSet :> _ -> seal patchSet | otherwise = getMatchingTag m (PatchSet ps ts) -- | @matchExists m ps@ tells whether there is a patch matching
src/Darcs/MonadProgress.hs view
@@ -25,9 +25,11 @@ , silentlyRunProgressActions ) where +import Prelude hiding ( catch ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) import Printer ( hPutDocLn, Doc ) import Darcs.ColorPrinter () -- for instance Show Doc+import Control.Exception ( catch ) import System.IO ( stderr ) import qualified Storage.Hashed.Monad as HSM
src/Darcs/Repository.hs view
@@ -45,7 +45,14 @@ , readIndex, invalidateIndex ) where +import Prelude hiding ( catch )+ import System.Exit ( ExitCode(..), exitWith )+#if MIN_VERSION_tar(0,4,0)+import Control.Exception ( Exception, throwIO, catch )+#else+import Control.Exception ( catch )+#endif import Data.List ( isPrefixOf) import Data.Maybe( catMaybes, isJust, listToMaybe ) @@ -302,19 +309,35 @@ removeMetaFiles = mapM_ (removeFile . (darcsdir </>)) . filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir +#if MIN_VERSION_tar(0,4,0)+unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO ()+#else unpackBasic :: Cache -> Tar.Entries -> IO ()+#endif unpackBasic c x = do withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x removeMetaFiles +#if MIN_VERSION_tar(0,4,0)+unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO ()+#else unpackPatches :: Cache -> [String] -> Tar.Entries -> IO ()+#endif unpackPatches c ps x = do withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x removeMetaFiles +#if MIN_VERSION_tar(0,4,0)+unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO ()+#else unpackTar :: Cache -> IO () -> Tar.Entries -> IO ()+#endif unpackTar _ _ Tar.Done = return ()+#if MIN_VERSION_tar(0,4,0)+unpackTar _ _ (Tar.Fail e)= throwIO e+#else unpackTar _ _ (Tar.Fail e)= fail e+#endif unpackTar c mh (Tar.Next x xs) = case Tar.entryContent x of Tar.NormalFile x' _ -> do let p = Tar.entryPath x
src/Darcs/Repository/HashedRepo.hs view
@@ -31,6 +31,8 @@ readRepoFromInventoryList, readPatchIds ) where +import Prelude hiding ( catch )+ import System.Directory ( createDirectoryIfMissing ) import System.FilePath.Posix( (</>) ) import System.IO.Unsafe ( unsafeInterleaveIO )@@ -38,6 +40,7 @@ import Data.List ( delete ) import Control.Monad ( unless ) import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException ) import Workaround ( renameFile ) import Darcs.Flags ( Compression, RemoteDarcs )@@ -99,7 +102,7 @@ return $ BC.unpack . encodeBase16 $ treeHash t applyHashed :: (ApplyState q ~ Tree, Patchy q) => String -> q C(x y) -> IO String-applyHashed h p = applyHashed' hash p `catch` \_ -> do+applyHashed h p = applyHashed' hash p `catch` \(_ :: IOException) -> do hPutStrLn stderr warn inv <- gzReadFilePS invpath let oldroot = BC.pack $ inv2pris inv@@ -142,7 +145,7 @@ readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String) readHashedPristineRoot (Repo d _ _ _) = withCurrentDirectory d $ do- i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing)+ i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\(_ :: IOException) -> return Nothing) return $ inv2pris `fmap` i cleanPristine :: Repository p C(r u t) -> IO ()
src/Darcs/Repository/Internal.hs view
@@ -49,6 +49,8 @@ makeNewPending, seekRepo ) where +import Prelude hiding ( catch )+ import Printer ( putDocLn, (<+>), text, ($$), redText, putDocLnWith, (<>), ($$)) import Darcs.ColorPrinter (fancyPrinters) @@ -71,6 +73,8 @@ createDirectoryIfMissing, doesFileExist ) import Control.Monad ( when, unless, filterM ) import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException )+ import Workaround ( getCurrentDirectory, renameFile, setExecutable ) import qualified Data.ByteString as B ( readFile, isPrefixOf )@@ -350,7 +354,7 @@ cur <- readRecorded repo Sealed p <- readNewPendingLL repo -- :: IO (Sealed (FL (PrimOf p) C(t))) -- Warning: A do-notation statement discarded a result of type Tree.Tree IO.- _ <- catch (applyToTree p cur) $ \err -> do+ _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do let buggyname = pendingName tp ++ "_buggy" renameFile newname buggyname bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)
src/Darcs/Repository/Old.hs view
@@ -22,6 +22,8 @@ module Darcs.Repository.Old ( readOldRepo, revertTentativeChanges, oldRepoFailMsg ) where +import Prelude hiding ( catch )+ import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr )@@ -48,6 +50,8 @@ import Darcs.Global ( darcsdir ) import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) +import Control.Exception ( catch, IOException )+ #include "impossible.h" readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p C(Origin))@@ -93,7 +97,8 @@ Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ read_ts parse mt Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) Sealed tag00 <- parse tag0 `catch`- \e -> return $ seal $+ \(e :: IOException) ->+ return $ seal $ patchInfoAndPatch tag0 $ unavailable $ show e return $ seal $ Tagged tag00 Nothing ps :<: ts parse2 :: RepoPatch p => PatchInfo -> FilePath@@ -112,7 +117,7 @@ read_patches parse (i:is) = lift2Sealed (:<:) (read_patches parse is)- (parse i `catch` \e ->+ (parse i `catch` \(e :: IOException) -> return $ seal $ patchInfoAndPatch i $ unavailable $ show e) lift2Sealed :: (FORALL(y z) q C(y z) -> pp C(y) -> r C(z)) -> IO (Sealed pp) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed r)
src/Darcs/Repository/Prefs.hs view
@@ -34,7 +34,11 @@ globalPrefsDirDoc, ) where ++import Prelude hiding ( catch )+ import System.IO.Error ( isDoesNotExistError )+import Control.Exception ( catch ) import Control.Monad ( unless, when ) import Text.Regex ( Regex, mkRegex, matchRegex, ) import Data.Char ( toUpper )
src/Darcs/Repository/Repair.hs view
@@ -5,10 +5,12 @@ RepositoryConsistency(..) ) where +import Prelude hiding ( catch )+ import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) import Control.Applicative( (<$>) )-import Control.Exception ( finally )+import Control.Exception ( catch, finally, IOException ) import Data.Maybe ( catMaybes ) import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing, getCurrentDirectory,@@ -134,7 +136,7 @@ checkUniqueness putVerbose putInfo repo createDirectoryIfMissing False whereToReplay putVerbose $ text "Reading recorded state..."- pris <- readRecorded repo `catch` \_ -> return emptyTree+ pris <- readRecorded repo `catch` \(_ :: IOException) -> return emptyTree putVerbose $ text "Applying patches..." patches <- readRepo repo debugMessage "Fixing any broken patches..."
src/Darcs/Repository/State.hs view
@@ -32,9 +32,10 @@ -- * Index. , readIndex, invalidateIndex, UseIndex(..), ScanKnown(..) ) where -import Prelude hiding ( filter )+import Prelude hiding ( filter, catch ) import Control.Monad( when ) import Control.Applicative( (<$>) )+import Control.Exception ( catch, IOException ) import Data.Maybe( isJust ) import Data.List( union ) import Text.Regex( matchRegex )@@ -257,7 +258,7 @@ readPending repo = do Sealed pending <- readPendingLL repo pristine <- readRecorded repo- catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do+ catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ (err :: IOException) -> do putStrLn $ "Yikes, pending has conflicts! " ++ show err putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy" renameFile "_darcs/patches/pending"
src/Darcs/Utils.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} -- |@@ -76,7 +77,7 @@ import Foreign.C.String ( CString, withCString, peekCString ) import Foreign.C.Error ( throwErrno )-import Foreign.C.Types ( CInt )+import Foreign.C.Types ( CInt(..) ) #ifdef FORCE_CHAR8_ENCODING import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 )
+ src/Encoding.hs view
@@ -0,0 +1,46 @@+-- Copyright 2007-2009, Judah Jacobson.+-- All Rights Reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:++-- - Redistribution of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.++-- - Redistribution in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.++-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+{-# LANGUAGE CPP #-}+module Encoding+ ( encode,decode+ ) where++import Data.ByteString ( ByteString )++#ifdef WIN32+import qualified Encoding.Win32 as Backend ( encode, decode )+#else+import qualified Encoding.IConv as Backend ( encode, decode )+#endif++-- functions redefined to add haddock (there might well be a better way!)++-- | Encode a Unicode 'String' into a 'ByteString' suitable for the current+-- console.+encode :: String -> IO ByteString+encode = Backend.encode++-- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'.+decode :: ByteString -> IO String+decode = Backend.decode
+ src/Encoding/IConv.hsc view
@@ -0,0 +1,184 @@+-- Copyright 2007-2009, Judah Jacobson.+-- All Rights Reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:++-- - Redistribution of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.++-- - Redistribution in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.++-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+{-# LANGUAGE ForeignFunctionInterface #-}+module Encoding.IConv+ ( encode, decode+ ) where++import Foreign.C+ ( CString, CSize(..), CInt(..)+ , peekCAString, withCAString+ , Errno(..), getErrno, throwErrno, eINVAL, e2BIG+ )+import Foreign+ ( Ptr, castPtr, nullPtr, plusPtr+ , peek, maybePeek+ , with, maybeWith+ , ForeignPtr, withForeignPtr, newForeignPtr+ , FunPtr+ , Int32, Word8+ )+import Control.Exception ( bracket )+import Data.ByteString ( ByteString, useAsCStringLen, append )+import Data.ByteString.Internal ( createAndTrim' )+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8+import Data.Maybe ( fromMaybe )++#include <locale.h>+#include <langinfo.h>+#include "h_iconv.h"++getLocaleCodeset :: IO String+getLocaleCodeset = bracket (setLocale (Just "")) setLocale (const getCodeset)++encode :: String -> IO ByteString+encode str = getLocaleCodeset >>= \codeset -> openEncoder codeset >>= ($ str)++decode :: ByteString -> IO String+decode str = getLocaleCodeset >>= \codeset -> openDecoder codeset >>= ($ str)++openEncoder :: String -> IO (String -> IO ByteString)+openEncoder codeset = do+ encodeT <- iconvOpen codeset "UTF-8"+ return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString++openDecoder :: String -> IO (ByteString -> IO String)+openDecoder codeset = do+ decodeT <- iconvOpen "UTF-8" codeset+ return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT++dropUTF8Char :: ByteString -> ByteString+dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons++replacement :: Word8+replacement = toEnum (fromEnum '?')++-- handle errors by dropping unuseable chars.+simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString+simpleIConv dropper t bs = do+ (cs,result) <- iconv t bs+ case result of+ Invalid rest -> continueOnError cs rest+ Incomplete rest -> continueOnError cs rest+ _ -> return cs+ where+ continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`))+ $ simpleIConv dropper t (dropper rest)++---------------------+-- Setting the locale++foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString++setLocale :: Maybe String -> IO (Maybe String)+setLocale oldLocale = (maybeWith withCAString) oldLocale $ \loc_p -> do+ c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString++-----------------+-- Getting the encoding++type NLItem = #type nl_item++foreign import ccall nl_langinfo :: NLItem -> IO CString++getCodeset :: IO String+getCodeset = do+ str <- nl_langinfo (#const CODESET) >>= peekCAString+ -- check for codesets which may be returned by Solaris, but not understood+ -- by GNU iconv.+ if str `elem` ["","646"]+ then return "ISO-8859-1"+ else return str++----------------+-- Iconv++-- TODO: This may not work on platforms where iconv_t is not a pointer.+type IConvT = ForeignPtr ()+type IConvTPtr = Ptr ()++foreign import ccall "haskeline_iconv_open" iconv_open+ :: CString -> CString -> IO IConvTPtr++iconvOpen :: String -> String -> IO IConvT+iconvOpen destName srcName = withCAString destName $ \dest ->+ withCAString srcName $ \src -> do+ res <- iconv_open dest src+ if res == nullPtr `plusPtr` (-1)+ then throwErrno $ "iconvOpen "+ ++ show (srcName,destName)+ -- list the two it couldn't convert between?+ else newForeignPtr iconv_close res++-- really this returns a CInt, but it's easiest to just ignore that, I think.+foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())++foreign import ccall "haskeline_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize+ -> Ptr CString -> Ptr CSize -> IO CSize++data Result = Successful+ | Invalid ByteString+ | Incomplete ByteString+ deriving Show++iconv :: IConvT -> ByteString -> IO (ByteString,Result)+iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) ->+ with inPtr $ \inBuff ->+ with (toEnum inBuffLen) $ \inBytesLeft -> do+ out <- loop inBuffLen (castPtr inBuff) inBytesLeft+ return out+ where+ -- TODO: maybe a better algorithm for increasing the buffer size?+ -- and also maybe a different starting buffer size?+ biggerBuffer = (+1)+ loop outSize inBuff inBytesLeft = do+ (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft+ inLeft <- fmap fromEnum $ peek inBytesLeft+ let rest = B.drop (B.length inStr - inLeft) inStr+ case errno of+ Nothing -> return (bs,Successful)+ Just err + | err == e2BIG -> do -- output buffer too small+ (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft+ -- TODO: is this efficient enough?+ return (bs `append` bs', result)+ | err == eINVAL -> return (bs,Incomplete rest)+ | otherwise -> return (bs, Invalid rest)++partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno)+partialIconv cd outSize inBuff inBytesLeft =+ withForeignPtr cd $ \cd_p ->+ createAndTrim' outSize $ \outPtr ->+ with outPtr $ \outBuff ->+ with (toEnum outSize) $ \outBytesLeft -> do+ -- ignore the return value; checking the errno is more reliable.+ _ <- c_iconv cd_p inBuff inBytesLeft (castPtr outBuff) outBytesLeft+ outLeft <- fmap fromEnum $ peek outBytesLeft+ inLeft <- peek inBytesLeft+ errno <- if inLeft > 0+ then fmap Just getErrno+ else return Nothing+ return (0,outSize - outLeft,errno)+
+ src/Encoding/Win32.hs view
@@ -0,0 +1,80 @@+-- Copyright 2007-2009, Judah Jacobson.+-- All Rights Reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:++-- - Redistribution of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.++-- - Redistribution in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.++-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+{-# LANGUAGE ForeignFunctionInterface #-}+module Encoding.Win32+ ( encode, decode+ ) where++import Data.ByteString.Internal ( createAndTrim )+import qualified Data.ByteString as B+ ( ByteString, useAsCStringLen )+import Foreign ( castPtr, allocaArray0 )+import Foreign.C+ ( CInt(..), peekCWStringLen, withCWStringLen )+import System.Win32+ ( CodePage, nullPtr, getConsoleCP, getACP+ , LPCSTR, LPWSTR, LPCWSTR, LPBOOL, DWORD )++encode :: String -> IO B.ByteString+encode str = getCodePage >>= flip unicodeToCodePage str++decode :: B.ByteString -> IO String+decode str = getCodePage >>= flip codePageToUnicode str++------------------------+-- Multi-byte conversion++foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte+ :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt+ -> LPCSTR -> LPBOOL -> IO CInt++unicodeToCodePage :: CodePage -> String -> IO B.ByteString+unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do+ -- first, ask for the length without filling the buffer.+ outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)+ nullPtr 0 nullPtr nullPtr+ -- then, actually perform the encoding.+ createAndTrim (fromEnum outSize) $ \outBuff ->+ fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)+ (castPtr outBuff) outSize nullPtr nullPtr++foreign import stdcall "MultiByteToWideChar" multiByteToWideChar+ :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt++codePageToUnicode :: CodePage -> B.ByteString -> IO String+codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do+ -- first ask for the size without filling the buffer.+ outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0+ -- then, actually perform the decoding.+ allocaArray0 (fromEnum outSize) $ \outBuff -> do+ outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize+ peekCWStringLen (outBuff, fromEnum outSize')++getCodePage :: IO CodePage+getCodePage = do+ conCP <- getConsoleCP+ if conCP > 0+ then return conCP+ else getACP+
src/URL/Curl.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module URL.Curl where@@ -6,7 +7,7 @@ import Control.Exception.Extensible ( bracket ) import Control.Monad ( when )-import Foreign.C.Types ( CLong, CInt )+import Foreign.C.Types ( CLong(..), CInt(..) ) import Progress ( debugMessage )
src/URL/HTTP.hs view
@@ -2,12 +2,15 @@ module URL.HTTP( fetchUrl, postUrl, requestUrl, waitNextUrl ) where +import Prelude hiding ( catch )+ import Darcs.Global ( debugFail ) import Version ( version ) import URL.Request ( ConnectionError(..) ) #ifdef HAVE_HTTP+import Control.Exception ( catch, IOException ) import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) import Network.HTTP import Network.Browser ( browse, request, setCheckForProxy, setErrHandler, setOutHandler )@@ -45,7 +48,7 @@ rqMethod = GET, rqHeaders = headers, rqBody = "" })- (\err -> debugFail $ show err)+ (\(err :: IOException) -> debugFail $ show err) case resp of (_, res@Response { rspCode = (2,0,0) }) -> return (rspBody res) (_, Response { rspCode = (x,y,z) }) ->@@ -65,7 +68,7 @@ Header HdrContentLength (show $ length body) ], rqBody = body })- (\err -> debugFail $ show err)+ (\(err :: IOException) -> debugFail $ show err) case resp of (_, res@Response { rspCode = (2,y,z) }) -> do putStrLn $ "Success 2" ++ show y ++ show z
src/Workaround.hs view
@@ -25,11 +25,14 @@ , sigPIPE ) where +import Prelude hiding ( catch )+ #ifdef WIN32 import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )+import Control.Exception ( catch, IOException ) import qualified Control.Exception ( block )-import qualified System.IO.Error ( isDoesNotExistError, ioError, catch )+import qualified System.IO.Error ( isDoesNotExistError, ioError ) #else @@ -95,9 +98,9 @@ -> IO () renameFile old new = Control.Exception.block $ System.Directory.renameFile old new- `System.IO.Error.catch` \_ ->+ `catch` \(_ :: IOException) -> do System.Directory.removeFile new- `System.IO.Error.catch`+ `catch` (\e -> if System.IO.Error.isDoesNotExistError e then return () else System.IO.Error.ioError e)
+ src/h_iconv.c view
@@ -0,0 +1,18 @@+#include "h_iconv.h"++// Wrapper functions, since iconv_open et al are macros in libiconv.+iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode) {+ return iconv_open(tocode, fromcode);+}++void haskeline_iconv_close(iconv_t cd) {+ iconv_close(cd);+}++size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,+ char **outbuf, size_t *outbytesleft) {+ // Cast inbuf to (void*) so that it works both on Solaris, which expects+ // a (const char**), and on other platforms (e.g. Linux), which expect+ // a (char **).+ return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft);+}
+ src/h_iconv.h view
@@ -0,0 +1,9 @@+#include <iconv.h>++iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode);++void haskeline_iconv_close(iconv_t cd);++size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,+ char **outbuf, size_t *outbytesleft);+
src/test.hs view
@@ -5,10 +5,12 @@ import qualified Darcs.Test.Patch import qualified Darcs.Test.Email -import Control.Monad (when)+import Control.Monad (when, filterM) import Data.List ( isPrefixOf, isSuffixOf, sort ) import qualified Data.ByteString.Char8 as B import System.Console.CmdLib+import System.Directory ( doesFileExist )+import System.Environment.FindBin ( getProgPath ) import System.FilePath( takeDirectory, takeBaseName, isAbsolute ) import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr ) import Test.Framework.Providers.API@@ -49,6 +51,7 @@ , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly , _darcspath :: FilePath }+ deriving Typeable runtest' :: ShellTest -> FilePath -> ShIO Result runtest' (ShellTest fmt _ _ dp) srcdir =@@ -60,7 +63,7 @@ setenv "EMAIL" "tester" setenv "DARCS_DONT_COLOR" "1" setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"- getenv "PATH" >>= setenv "PATH" . ((takeDirectory dp ++ ":") ++)+ getenv "PATH" >>= setenv "PATH" . ((takeDirectory dp ++ pathVarSeparator) ++) setenv "DARCS" dp mkdir ".darcs" writefile ".darcs/defaults" defaults@@ -74,6 +77,11 @@ fmtstr = case fmt of Darcs2 -> "darcs-2" Hashed -> "hashed"+#ifdef WIN32+ pathVarSeparator = ";"+#else+ pathVarSeparator = ":"+#endif runtest :: ShellTest -> ShIO Result runtest t =@@ -152,15 +160,33 @@ Nothing -> return () Just d -> do e <- shellish (test_e d) when e $ fail ("Directory " ++ d ++ " already exists. Cowardly exiting")+ darcsBin <-+ case darcs conf of+ "" -> do+ path <- getProgPath+ let candidates =+ -- if darcs-test lives in foo/something, look for foo/darcs[.exe]+ -- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal+ -- installation folder+ [path </> "darcs" ++ exeSuffix] +++ -- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe]+ -- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find+ -- the darcs in dist/build/darcs/darcs+ [takeDirectory path </> "darcs" </> "darcs" ++ exeSuffix | takeBaseName path == "darcs-test" ]+ availableCandidates <- filterM doesFileExist candidates+ case availableCandidates of+ (darcsBin:_) -> do+ putStrLn $ "Using darcs executable in " ++ darcsBin+ return darcsBin+ [] -> fail ("No darcs specified or found nearby. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?")+ v -> return v when (shell conf || network conf || failing conf) $ do- when (null $ darcs conf) $- fail ("No darcs specified. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?")- when (not (isAbsolute (darcs conf))) $+ when (not (isAbsolute $ darcsBin)) $ fail ("Argument to --darcs should be an absolute path")- when (not (exeSuffix `isSuffixOf` darcs conf)) $+ when (not (exeSuffix `isSuffixOf` darcsBin)) $ putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"- ftests <- shellish $ if failing conf then findShell (darcs conf) (testDir conf) True else return []- stests <- shellish $ if shell conf then findShell (darcs conf) (testDir conf) False else return []+ ftests <- shellish $ if failing conf then findShell darcsBin (testDir conf) True else return []+ stests <- shellish $ if shell conf then findShell darcsBin (testDir conf) False else return [] utests <- if unit conf then doUnit else return [] ntests <- shellish $ if network conf then findNetwork (darcs conf) (testDir conf) else return [] defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests) args
src/win32/System/Posix.hs view
@@ -1,8 +1,9 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix ( sleep ) where -import Foreign.C.Types ( CInt, CUInt, CULong )+import Foreign.C.Types ( CInt(..), CUInt(..), CULong(..) ) foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt
src/win32/System/Posix/Files.hsc view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module System.Posix.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink , getFdStatus, getFileStatus, getSymbolicLinkStatus@@ -14,7 +15,7 @@ import Foreign.C.String( CWString, withCWString ) import Foreign.C.Error( throwErrnoPathIf_ ) import Foreign.Ptr( Ptr, nullPtr )-import Foreign.C( CInt )+import Foreign.C( CInt(..) ) linkCount :: FileStatus -> Int linkCount _ = 1
+ tests/data/metadata-encoding.tgz view
binary file changed (absent → 3156 bytes)
tests/harness.sh view
@@ -16,11 +16,11 @@ if echo $OS | grep -i windows; then if echo $OSTYPE | grep -i cygwin ; then- real=$(cygpath -w $(command -v darcs.exe) | sed -e 's,\\,/,g')+ real=$(cygpath -w $(command -v darcs.exe) | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') else- real=$(cmd //c echo $(command -v darcs.exe) | sed -e 's,\\,/,g')+ real=$(cmd //c echo $(command -v darcs.exe) | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') fi- wanted=$(echo "$DARCS" | sed -e 's,\\,/,g')+ wanted=$(echo "$DARCS" | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') test "$real" = "$wanted" else command -v darcs | fgrep "$DARCS"
+ tests/issue2199-get-dirty-tag.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+## Test for issue2199 - "darcs get --tag" gets too much if the tag is dirty.+##+## Copyright (C) 2012 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++darcs init --repo R++cd R+echo 'wibble' > file+darcs rec -lam 'wibble'+echo 'wobble' > file+darcs rec -lam 'wobble'+cd ..++darcs get R R-temp++cd R-temp+darcs unpull --patch 'wobble' -a+darcs tag 'wibble'+cd ..++cd R+darcs pull ../R-temp -a+cd ..++darcs get --tag wibble R R-tag+cd R-tag+darcs changes | not grep wobble
+ tests/issue2286-metadata-encoding.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+## Test for issue2286 - darcs cha fails when reading non-UTF8 encoded+## metadata+##+## Copyright (C) 2012 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++switch_to_utf8_locale++gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf -++cd metadata-encoding+darcs changes
tests/lib view
@@ -24,34 +24,42 @@ } switch_to_latin9_locale () {- if ! which locale ; then- echo "no locale command, skipping test"- exit 200- fi+ if echo $OS | grep -i windows; then+ chcp.com 28605+ else+ if ! which locale ; then+ echo "no locale command, skipping test"+ exit 200+ fi - # look for a ISO 8859-15 locale. locale -a shows iso885915, on ubuntu at least- latin9_locale=`locale -a | grep -i iso885915 | head -n 1` || (no_latin9_locale_warning; exit 200)- test -n "$latin9_locale" || (no_latin9_locale_warning; exit 200)+ # look for a ISO 8859-15 locale. locale -a shows iso885915, on ubuntu at least+ latin9_locale=`locale -a | egrep -i iso8859-?15 | head -n 1` || (no_latin9_locale_warning; exit 200)+ test -n "$latin9_locale" || (no_latin9_locale_warning; exit 200) - echo "Using locale $latin9_locale"- export LC_ALL=$latin9_locale- echo "character encoding is now `locale charmap`"+ echo "Using locale $latin9_locale"+ export LC_ALL=$latin9_locale+ echo "character encoding is now `locale charmap`"+ fi } # switch locale to utf8 if supported if there's a locale command, skip test # otherwise switch_to_utf8_locale () {- if ! which locale ; then- echo "no locale command"- exit 200 # skip test- fi+ if echo $OS | grep -i windows; then+ chcp.com 65001+ else+ if ! which locale ; then+ echo "no locale command"+ exit 200 # skip test+ fi - utf8_locale=`locale -a | grep .utf8 | head -n 1` || exit 200- test -n "$utf8_locale" || exit 200+ utf8_locale=`locale -a | grep .utf8 | head -n 1` || exit 200+ test -n "$utf8_locale" || exit 200 - echo "Using locale $utf8_locale"- export LC_ALL=$utf8_locale- echo "character encoding is now `locale charmap`"+ echo "Using locale $utf8_locale"+ export LC_ALL=$utf8_locale+ echo "character encoding is now `locale charmap`"+ fi } serve_http() {
tests/utf8.sh view
@@ -41,6 +41,7 @@ if grep "$1" changes.xml ; then echo "$2 OK" else+ cat changes.xml echo "$2 not UTF-8-encoded!" exit 1 fi@@ -70,7 +71,6 @@ echo n >> interaction_script.txt unset DARCSEMAIL-unset DARCS_TESTING_PREFS_DIR unset EMAIL set darcs record -i < interaction_script.txt@@ -117,9 +117,13 @@ echo y | darcs amend-record -p 'Patch by ' -A '´ed is even deader' -a grep_changes 'Žed is even deader' 'author name from amend-record command line flag' -echo '#!/usr/bin/env bash' > editor-echo 'echo All my ¤s are gone > $1' >> editor # create an 'editor' that writes latin9-chmod +x editor+cat <<FAKE > editor.hs # create an 'editor' that writes latin9+import System.Environment+import qualified Data.ByteString as B+str = B.pack [65,108,108,32,109,121,32,164,115,32,97,114,101,32,103,111,110,101]+main = getArgs >>= \[x] -> B.writeFile x str+FAKE+ghc --make -o editor editor.hs export EDITOR="`pwd`/editor" printf "y\ny\n" | darcs amend --edit -p 'Patch by ' grep_changes 'All my â¬s are gone' 'description edited from amend-record'