aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-09-14 17:54:06 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-23 10:38:43 +0200
commit873f6f1334ab06a69e768a8aea0054404237542f (patch)
tree81d0183061f1dec3c0a0fb276d9c912412c45105
parenta78dcb3d599cc84b347578940bb0fd44b1ad50b4 (diff)
downloadguix-873f6f1334ab06a69e768a8aea0054404237542f.tar
guix-873f6f1334ab06a69e768a8aea0054404237542f.tar.gz
git: Add 'commit-difference'.
* guix/git.scm (commit-closure, commit-difference): New procedures. * guix/tests/git.scm, tests/git.scm: New files. * Makefile.am (dist_noinst_DATA): Add guix/tests/git.scm. (SCM_TESTS): Add tests/git.scm.
-rw-r--r--.dir-locals.el1
-rw-r--r--Makefile.am6
-rw-r--r--guix/git.scm40
-rw-r--r--guix/tests/git.scm97
-rw-r--r--tests/git.scm99
5 files changed, 242 insertions, 1 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 228685a69f..22aac2c402 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -90,6 +90,7 @@
(eval . (put 'eventually 'scheme-indent-function 1))
(eval . (put 'call-with-progress-reporter 'scheme-indent-function 1))
+ (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2))
;; This notably allows '(' in Paredit to not insert a space when the
;; preceding symbol is one of these.
diff --git a/Makefile.am b/Makefile.am
index f71ea77671..658f03bd54 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -307,7 +307,10 @@ STORE_MODULES = \
MODULES += $(STORE_MODULES)
# Internal modules with test suite support.
-dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
+dist_noinst_DATA = \
+ guix/tests.scm \
+ guix/tests/http.scm \
+ guix/tests/git.scm
# Auxiliary files for packages.
AUX_FILES = \
@@ -391,6 +394,7 @@ SCM_TESTS = \
tests/file-systems.scm \
tests/gem.scm \
tests/gexp.scm \
+ tests/git.scm \
tests/glob.scm \
tests/gnu-maintenance.scm \
tests/grafts.scm \
diff --git a/guix/git.scm b/guix/git.scm
index 92a7353b5a..d7dddde3a7 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -28,6 +28,7 @@
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix gexp)
+ #:use-module (guix sets)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@@ -37,8 +38,10 @@
#:export (%repository-cache-directory
honor-system-x509-certificates!
+ with-repository
update-cached-checkout
latest-repository-commit
+ commit-difference
git-checkout
git-checkout?
@@ -341,6 +344,43 @@ Log progress and checkout info to LOG-PORT."
;;;
+;;; Commit difference.
+;;;
+
+(define (commit-closure commit)
+ "Return the closure of COMMIT as a set."
+ (let loop ((commits (list commit))
+ (visited (setq)))
+ (match commits
+ (()
+ visited)
+ ((head . tail)
+ (if (set-contains? visited head)
+ (loop tail visited)
+ (loop (append (commit-parents head) tail)
+ (set-insert head visited)))))))
+
+(define (commit-difference new old)
+ "Return the list of commits between NEW and OLD, where OLD is assumed to be
+an ancestor of NEW.
+
+Essentially, this computes the set difference between the closure of NEW and
+that of OLD."
+ (let loop ((commits (list new))
+ (result '())
+ (visited (commit-closure old)))
+ (match commits
+ (()
+ (reverse result))
+ ((head . tail)
+ (if (set-contains? visited head)
+ (loop tail result visited)
+ (loop (append (commit-parents head) tail)
+ (cons head result)
+ (set-insert head visited)))))))
+
+
+;;;
;;; Checkouts.
;;;
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
new file mode 100644
index 0000000000..52abe77c83
--- /dev/null
+++ b/guix/tests/git.scm
@@ -0,0 +1,97 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix tests git)
+ #:use-module (git)
+ #:use-module (guix utils)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 control)
+ #:export (git-command
+ with-temporary-git-repository
+ find-commit))
+
+(define git-command
+ (make-parameter "git"))
+
+(define (populate-git-repository directory directives)
+ "Initialize a new Git checkout and repository in DIRECTORY and apply
+DIRECTIVES. Each element of DIRECTIVES is an sexp like:
+
+ (add \"foo.txt\" \"hi!\")
+
+Return DIRECTORY on success."
+
+ ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
+ ;; all this, so resort to the "git" command.
+ (define (git command . args)
+ (apply invoke (git-command) "-C" directory
+ command args))
+
+ (mkdir-p directory)
+ (git "init")
+
+ (let loop ((directives directives))
+ (match directives
+ (()
+ directory)
+ ((('add file contents) rest ...)
+ (let ((file (string-append directory "/" file)))
+ (mkdir-p (dirname file))
+ (call-with-output-file file
+ (lambda (port)
+ (display contents port)))
+ (git "add" file)
+ (loop rest)))
+ ((('commit text) rest ...)
+ (git "commit" "-m" text)
+ (loop rest))
+ ((('branch name) rest ...)
+ (git "branch" name)
+ (loop rest))
+ ((('checkout branch) rest ...)
+ (git "checkout" branch)
+ (loop rest))
+ ((('merge branch message) rest ...)
+ (git "merge" branch "-m" message)
+ (loop rest)))))
+
+(define (call-with-temporary-git-repository directives proc)
+ (call-with-temporary-directory
+ (lambda (directory)
+ (populate-git-repository directory directives)
+ (proc directory))))
+
+(define-syntax-rule (with-temporary-git-repository directory
+ directives exp ...)
+ "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
+per DIRECTIVES."
+ (call-with-temporary-git-repository directives
+ (lambda (directory)
+ exp ...)))
+
+(define (find-commit repository message)
+ "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
+ (let/ec return
+ (fold-commits (lambda (commit _)
+ (and (string-contains (commit-message commit)
+ message)
+ (return commit)))
+ #f
+ repository)
+ (error "commit not found" message)))
diff --git a/tests/git.scm b/tests/git.scm
new file mode 100644
index 0000000000..8ba10ece51
--- /dev/null
+++ b/tests/git.scm
@@ -0,0 +1,99 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-git)
+ #:use-module (git)
+ #:use-module (guix git)
+ #:use-module (guix tests git)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64))
+
+;; Test the (guix git) tools.
+
+(test-begin "git")
+
+;; 'with-temporary-git-repository' relies on the 'git' command.
+(unless (which (git-command)) (test-skip 1))
+(test-assert "commit-difference, linear history"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "first commit")
+ (add "b.txt" "B")
+ (commit "second commit")
+ (add "c.txt" "C")
+ (commit "third commit")
+ (add "d.txt" "D")
+ (commit "fourth commit"))
+ (with-repository directory repository
+ (let ((commit1 (find-commit repository "first"))
+ (commit2 (find-commit repository "second"))
+ (commit3 (find-commit repository "third"))
+ (commit4 (find-commit repository "fourth")))
+ (and (lset= eq? (commit-difference commit4 commit1)
+ (list commit2 commit3 commit4))
+ (lset= eq? (commit-difference commit4 commit2)
+ (list commit3 commit4))
+ (equal? (commit-difference commit3 commit2)
+ (list commit3))
+
+ ;; COMMIT4 is not an ancestor of COMMIT1 so we should get the
+ ;; empty list.
+ (null? (commit-difference commit1 commit4)))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-assert "commit-difference, fork"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "first commit")
+ (branch "devel")
+ (checkout "devel")
+ (add "devel/1.txt" "1")
+ (commit "first devel commit")
+ (add "devel/2.txt" "2")
+ (commit "second devel commit")
+ (checkout "master")
+ (add "b.txt" "B")
+ (commit "second commit")
+ (add "c.txt" "C")
+ (commit "third commit")
+ (merge "devel" "merge")
+ (add "d.txt" "D")
+ (commit "fourth commit"))
+ (with-repository directory repository
+ (let ((master1 (find-commit repository "first commit"))
+ (master2 (find-commit repository "second commit"))
+ (master3 (find-commit repository "third commit"))
+ (master4 (find-commit repository "fourth commit"))
+ (devel1 (find-commit repository "first devel"))
+ (devel2 (find-commit repository "second devel"))
+ (merge (find-commit repository "merge")))
+ (and (equal? (commit-difference master4 merge)
+ (list master4))
+ (lset= eq? (commit-difference master3 master1)
+ (list master3 master2))
+ (lset= eq? (commit-difference devel2 master1)
+ (list devel2 devel1))
+
+ ;; The merge occurred between MASTER2 and MASTER4 so here we
+ ;; expect to see all the commits from the "devel" branch in
+ ;; addition to those on "master".
+ (lset= eq? (commit-difference master4 master2)
+ (list master4 merge master3 devel1 devel2)))))))
+
+(test-end "git")