From 3bdf2d2052f3a194b3f72500ca71867fb22e1315 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 1 Dec 2013 15:14:13 -0400
Subject: merge from git-annex

Note that the batchCommand stuff is not used in git-repair, so
configure does not need to check for nice, ionice, and nocache,
nor are they dependend on.
---
 Git/Branch.hs | 36 ++++++++++++++++++++++++++++--------
 Git/Fsck.hs   |  9 ++++-----
 Git/Ref.hs    |  6 ++++++
 3 files changed, 38 insertions(+), 13 deletions(-)

(limited to 'Git')

diff --git a/Git/Branch.hs b/Git/Branch.hs
index 7b3297d..405fa10 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -89,18 +89,38 @@ fastForward branch (first:rest) repo =
 			(False, False) -> findbest c rs -- same
 
 {- Commits the index into the specified branch (or other ref), 
- - with the specified parent refs, and returns the committed sha -}
-commit :: String -> Branch -> [Ref] -> Repo -> IO Sha
-commit message branch parentrefs repo = do
+ - with the specified parent refs, and returns the committed sha.
+ -
+ - Without allowempy set, avoids making a commit if there is exactly
+ - one parent, and it has the same tree that would be committed.
+ -
+ - Unlike git-commit, does not run any hooks, or examine the work tree
+ - in any way.
+ -}
+commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
+commit allowempty message branch parentrefs repo = do
 	tree <- getSha "write-tree" $
 		pipeReadStrict [Param "write-tree"] repo
-	sha <- getSha "commit-tree" $ pipeWriteRead
-		(map Param $ ["commit-tree", show tree] ++ ps)
-		(Just $ flip hPutStr message) repo
-	update branch sha repo
-	return sha
+	ifM (cancommit tree)
+		( do
+			sha <- getSha "commit-tree" $ pipeWriteRead
+				(map Param $ ["commit-tree", show tree] ++ ps)
+				(Just $ flip hPutStr message) repo
+			update branch sha repo
+			return $ Just sha
+		, return Nothing
+		)
   where
 	ps = concatMap (\r -> ["-p", show r]) parentrefs
+	cancommit tree
+		| allowempty = return True
+		| otherwise = case parentrefs of
+			[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
+			_ -> return True
+
+commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha
+commitAlways message branch parentrefs repo = fromJust
+	<$> commit True message branch parentrefs repo
 
 {- A leading + makes git-push force pushing a branch. -}
 forcePush :: String -> String
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 8555aa0..8d5b75b 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -37,17 +37,16 @@ data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
  -}
 findBroken :: Bool -> Repo -> IO FsckResults
 findBroken batchmode r = do
+	let (command, params) = ("git", fsckParams r)
+	(command', params') <- if batchmode
+		then toBatchCommand (command, params)
+		else return (command, params)
 	(output, fsckok) <- processTranscript command' (toCommand params') Nothing
 	let objs = findShas output
 	badobjs <- findMissing objs r
 	if S.null badobjs && not fsckok
 		then return FsckFailed
 		else return $ FsckFoundMissing badobjs
-  where
-	(command, params) = ("git", fsckParams r)
-	(command', params')
-		| batchmode = toBatchCommand (command, params)
-		| otherwise = (command, params)
 
 foundBroken :: FsckResults -> Bool
 foundBroken FsckFailed = True
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 6ce1b87..0947293 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -10,6 +10,7 @@ module Git.Ref where
 import Common
 import Git
 import Git.Command
+import Git.Sha
 
 import Data.Char (chr)
 
@@ -105,6 +106,11 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
   where
 	uniqref (a, _) (b, _) = a == b
 
+{- Gets the sha of the tree a ref uses. -}
+tree :: Ref -> Repo -> IO (Maybe Sha)
+tree ref = extractSha <$$> pipeReadStrict
+	[ Param "rev-parse", Param (show ref ++ ":") ]
+
 {- Checks if a String is a legal git ref name.
  -
  - The rules for this are complex; see git-check-ref-format(1) -}
-- 
cgit v1.2.3