Add support for core.worktree, and fix support for GIT_WORK_TREE and GIT_DIR.

The environment needs to override git-config. Changed when git config is
read, and avoid rereading it once it's been read.

chdir for both worktree settings.

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
 

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 }
 

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
 	}
+
+

Git/CurrentRepo.hs

@@ -0,0 +1,54 @@
+{- The current git repository.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - 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 }

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

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

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 <joeyh@debian.org>  Tue, 15 May 2012 14:17:49 -0400
 

doc/bugs/GIT_DIR_support_incomplete.mdwn

@@ -13,3 +13,5 @@ as well:
 	# fail
 
 --[[Joey]] 
+
+> [[fixed|done]] --[[Joey]] 

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

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