diff --git a/Annex.hs b/Annex.hs index d1509d4bd2..a9cc680125 100644 --- a/Annex.hs +++ b/Annex.hs @@ -124,7 +124,8 @@ newState gitrepo = AnnexState , cleanup = M.empty } -{- Create and returns an Annex state object for the specified git repo. -} +{- Makes an Annex state object for the specified git repo. + - Ensures the config is read, if it was not already. -} new :: Git.Repo -> IO AnnexState new gitrepo = newState <$> Git.Config.read gitrepo diff --git a/Git/Config.hs b/Git/Config.hs index e37b437071..2fa685a11d 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -27,16 +27,20 @@ getList key repo = M.findWithDefault [] key (fullconfig repo) getMaybe :: String -> Repo -> Maybe String getMaybe key repo = M.lookup key (config repo) -{- Runs git config and populates a repo with its config. -} +{- Runs git config and populates a repo with its config. + - Cannot use pipeRead because it relies on the config having been already + - read. Instead, chdir to the repo. + -} read :: Repo -> IO Repo read repo@(Repo { location = Local { gitdir = d } }) = read' repo d read repo@(Repo { location = LocalUnknown d }) = read' repo d read r = assertLocal r $ error "internal" -{- Cannot use pipeRead because it relies on the config having - been already read. Instead, chdir to the repo. -} read' :: Repo -> FilePath -> IO Repo -read' repo d = bracketCd d $ - pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ hRead repo +read' repo@(Repo { config = c}) d + | c == M.empty = bracketCd d $ + pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ + hRead repo + | otherwise = return repo -- config already read {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo @@ -55,7 +59,6 @@ store s repo = do { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) } - print repo' rs <- Git.Construct.fromRemotes repo' return $ repo' { remotes = rs } diff --git a/Git/Construct.hs b/Git/Construct.hs index 45ea0f64d8..b809d7318a 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -6,7 +6,6 @@ -} module Git.Construct ( - fromCurrent, fromCwd, fromAbsPath, fromPath, @@ -21,8 +20,6 @@ module Git.Construct ( ) where import System.Posix.User -import System.Posix.Env (getEnv, unsetEnv) -import System.Posix.Directory (changeWorkingDirectory) import qualified Data.Map as M hiding (map, split) import Network.URI @@ -31,28 +28,6 @@ import Git.Types import Git import qualified Git.Url as Url -{- Finds the current git repository. - - - - GIT_DIR can override the location of the .git directory. - - - - When GIT_WORK_TREE is set, chdir to it, so that anything using - - this repository runs in the right location. However, this chdir is - - done after determining GIT_DIR; git does not let GIT_WORK_TREE - - influence the git directory. - - - - Both environment variables are unset, to avoid confusing other git - - commands that also look at them. This would particularly be a problem - - when GIT_DIR is relative and we chdir for GIT_WORK_TREE. Instead, - - the Git module passes --work-tree and --git-dir to git commands it runs. - -} -fromCurrent :: IO Repo -fromCurrent = do - r <- maybe fromCwd fromPath =<< getEnv "GIT_DIR" - maybe noop changeWorkingDirectory =<< getEnv "GIT_WORK_TREE" - unsetEnv "GIT_DIR" - unsetEnv "GIT_WORK_TREE" - return r - {- Finds the git repository used for the Cwd, which may be in a parent - directory. -} fromCwd :: IO Repo @@ -251,3 +226,5 @@ newFrom l = return Repo , remotes = [] , remoteName = Nothing } + + diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs new file mode 100644 index 0000000000..4325f452c0 --- /dev/null +++ b/Git/CurrentRepo.hs @@ -0,0 +1,54 @@ +{- The current git repository. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.CurrentRepo where + +import System.Posix.Directory (changeWorkingDirectory) +import System.Posix.Env (getEnv, unsetEnv) + +import Common +import Git.Types +import Git.Construct +import qualified Git.Config + +{- Gets the current git repository. + - + - Honors GIT_DIR and GIT_WORK_TREE. + - Both environment variables are unset, to avoid confusing other git + - commands that also look at them. Instead, the Git module passes + - --work-tree and --git-dir to git commands it runs. + - + - When GIT_WORK_TREE or core.worktree are set, changes the working + - directory if necessary to ensure it is within the repository's work + - tree. While not needed for git commands, this is useful for anything + - else that looks for files in the worktree. + -} +get :: IO Repo +get = do + gd <- takeenv "GIT_DIR" + r <- configure gd =<< maybe fromCwd fromPath gd + wt <- maybe (worktree $ location r) Just <$> takeenv "GIT_WORK_TREE" + case wt of + Nothing -> return r + Just d -> do + changeWorkingDirectory d + return $ addworktree wt r + where + takeenv s = do + v <- getEnv s + when (isJust v) $ + unsetEnv s + return v + configure Nothing r = Git.Config.read r + configure (Just d) r = do + r' <- Git.Config.read r + -- Let GIT_DIR override the default gitdir. + return $ changelocation r' $ + Local { gitdir = d, worktree = worktree (location r') } + addworktree w r = changelocation r $ + Local { gitdir = gitdir (location r), worktree = w } + changelocation r l = r { location = l } diff --git a/GitAnnex.hs b/GitAnnex.hs index 0e707b1868..9910e33d21 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -11,7 +11,7 @@ import System.Console.GetOpt import Common.Annex import qualified Git.Config -import qualified Git.Construct +import qualified Git.CurrentRepo import CmdLine import Command import Types.TrustLevel @@ -133,4 +133,4 @@ header :: String header = "Usage: git-annex command [option ..]" run :: [String] -> IO () -run args = dispatch True args cmds options header Git.Construct.fromCurrent +run args = dispatch True args cmds options header Git.CurrentRepo.get diff --git a/Remote/Git.hs b/Remote/Git.hs index 35928b96cb..79439b784f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -179,12 +179,8 @@ repoAvail r - monad using that repository. -} onLocal :: Git.Repo -> Annex a -> IO a onLocal r a = do - -- Avoid re-reading the repository's configuration if it was - -- already read. - state <- if M.null $ Git.config r - then Annex.new r - else return $ Annex.newState r - Annex.eval state $ do + s <- Annex.new r + Annex.eval s $ do -- No need to update the branch; its data is not used -- for anything onLocal is used to do. Annex.BranchState.disableUpdate diff --git a/debian/changelog b/debian/changelog index 4e61445c8d..586077878b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,8 @@ git-annex (3.20120512) UNRELEASED; urgency=low * Pass -a to cp even when it supports --reflink=auto, to preserve permissions. * Clean up handling of git directory and git worktree. + * Add support for core.worktree, and fix support for GIT_WORK_TREE and + GIT_DIR. -- Joey Hess Tue, 15 May 2012 14:17:49 -0400 diff --git a/doc/bugs/GIT_DIR_support_incomplete.mdwn b/doc/bugs/GIT_DIR_support_incomplete.mdwn index d52871df29..1b9738c4f7 100644 --- a/doc/bugs/GIT_DIR_support_incomplete.mdwn +++ b/doc/bugs/GIT_DIR_support_incomplete.mdwn @@ -13,3 +13,5 @@ as well: # fail --[[Joey]] + +> [[fixed|done]] --[[Joey]] diff --git a/git-union-merge.hs b/git-union-merge.hs index 182d8cf790..2c2e7a46bd 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -10,7 +10,7 @@ import System.Environment import Common import qualified Git.UnionMerge import qualified Git.Config -import qualified Git.Construct +import qualified Git.CurrentRepo import qualified Git.Branch import qualified Git.Index import qualified Git @@ -40,7 +40,7 @@ parseArgs = do main :: IO () main = do [aref, bref, newref] <- map Git.Ref <$> parseArgs - g <- Git.Config.read =<< Git.Construct.fromCurrent + g <- Git.Config.read =<< Git.CurrentRepo.get _ <- Git.Index.override $ tmpIndex g setup g Git.UnionMerge.merge aref bref g diff --git a/test.hs b/test.hs index 1952a39a9b..c52a88d66f 100644 --- a/test.hs +++ b/test.hs @@ -26,7 +26,7 @@ import qualified Annex import qualified Annex.UUID import qualified Backend import qualified Git.Config -import qualified Git.Construct +import qualified Git.CurrentRepo import qualified Git.Filename import qualified Locations import qualified Types.Backend @@ -721,7 +721,7 @@ git_annex_expectoutput command params expected = do -- are not run; this should only be used for actions that query state. annexeval :: Types.Annex a -> IO a annexeval a = do - s <- Annex.new =<< Git.Config.read =<< Git.Construct.fromCurrent + s <- Annex.new =<< Git.CurrentRepo.get Annex.eval s $ do Annex.setOutput Types.Messages.QuietOutput a