diff options
| -rw-r--r-- | guix/git.scm | 24 | ||||
| -rw-r--r-- | tests/git.scm | 52 |
2 files changed, 74 insertions, 2 deletions
diff --git a/guix/git.scm b/guix/git.scm index 43e85a5026..53e7219c8c 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> @@ -46,6 +46,7 @@ #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (%repository-cache-directory @@ -60,6 +61,7 @@ latest-repository-commit commit-difference commit-relation + commit-descendant? remote-refs @@ -623,6 +625,26 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or (if (set-contains? oldest new) 'descendant 'unrelated)))))) + +(define (commit-descendant? new old) + "Return true if NEW is the descendant of one of OLD, a list of commits. + +When the expected result is likely #t, this is faster than using +'commit-relation' since fewer commits need to be traversed." + (let ((old (list->setq old))) + (let loop ((commits (list new)) + (visited (setq))) + (match commits + (() + #f) + (_ + ;; Perform a breadth-first search as this is likely going to + ;; terminate more quickly than a depth-first search. + (let ((commits (remove (cut set-contains? visited <>) commits))) + (or (any (cut set-contains? old <>) commits) + (loop (append-map commit-parents commits) + (fold set-insert visited commits))))))))) + ;; ;;; Remote operations. diff --git a/tests/git.scm b/tests/git.scm index d0646bbc85..ca59d2a33e 100644 --- a/tests/git.scm +++ b/tests/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz ;;; ;;; This file is part of GNU Guix. @@ -163,6 +163,56 @@ (commit-relation merge master1)))))) (unless (which (git-command)) (test-skip 1)) +(test-equal "commit-descendant?" + '((master3 master3 => #t) + (master1 master3 => #f) + (master3 master1 => #t) + (master2 branch1 => #f) + (master2 branch1 master1 => #t) + (branch1 master2 => #f) + (branch1 merge => #f) + (merge branch1 => #t) + (master1 merge => #f) + (merge master1 => #t)) + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (branch "hack") + (checkout "hack") + (add "1.txt" "1") + (commit "branch commit") + (checkout "master") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (merge "hack" "merge")) + (with-repository directory repository + (let ((master1 (find-commit repository "first")) + (master2 (find-commit repository "second")) + (master3 (find-commit repository "third")) + (branch1 (find-commit repository "branch")) + (merge (find-commit repository "merge"))) + (letrec-syntax ((verify + (syntax-rules () + ((_) '()) + ((_ (new old ...) rest ...) + (cons `(new old ... => + ,(commit-descendant? new + (list old ...))) + (verify rest ...)))))) + (verify (master3 master3) + (master1 master3) + (master3 master1) + (master2 branch1) + (master2 branch1 master1) + (branch1 master2) + (branch1 merge) + (merge branch1) + (master1 merge) + (merge master1))))))) + +(unless (which (git-command)) (test-skip 1)) (test-equal "remote-refs" '("refs/heads/develop" "refs/heads/master" "refs/tags/v1.0" "refs/tags/v1.1") |