diff options
Diffstat (limited to 'guix/git.scm')
| -rw-r--r-- | guix/git.scm | 65 |
1 files changed, 52 insertions, 13 deletions
diff --git a/guix/git.scm b/guix/git.scm index 92121156cf..0d8e617cc9 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -39,10 +39,12 @@ honor-system-x509-certificates! with-repository + false-if-git-not-found update-cached-checkout url+commit->name latest-repository-commit commit-difference + commit-relation git-checkout git-checkout? @@ -242,18 +244,23 @@ Return true on success, false on failure." (G_ "Support for submodules is missing; \ please upgrade Guile-Git.~%")))) +(define-syntax-rule (false-if-git-not-found exp) + "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised." + (catch 'git-error + (lambda () + exp) + (lambda (key error . rest) + (if (= GIT_ENOTFOUND (git-error-code error)) + #f + (apply throw key error rest))))) + (define (reference-available? repository ref) "Return true if REF, a reference such as '(commit . \"cabba9e\"), is definitely available in REPOSITORY, false otherwise." (match ref (('commit . commit) - (catch 'git-error - (lambda () - (->bool (commit-lookup repository (string->oid commit)))) - (lambda (key error . rest) - (if (= GIT_ENOTFOUND (git-error-code error)) - #f - (apply throw key error rest))))) + (false-if-git-not-found + (->bool (commit-lookup repository (string->oid commit))))) (_ #f))) @@ -261,14 +268,16 @@ definitely available in REPOSITORY, false otherwise." #:key (ref '(branch . "master")) recursive? + starting-commit (log-port (%make-void-port "w")) (cache-directory (url-cache-directory url (%repository-cache-directory) #:recursive? recursive?))) - "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two + "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return three values: the cache directory name, and the SHA1 commit (a string) corresponding -to REF. +to REF, and the relation of the new commit relative to STARTING-COMMIT (if +provided) as returned by 'commit-relation'. REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value the associated data: [<branch name> | <sha1> | <tag name> | <string>]. @@ -301,7 +310,20 @@ When RECURSIVE? is true, check out submodules as well, if any." (remote-fetch (remote-lookup repository "origin")))) (when recursive? (update-submodules repository #:log-port log-port)) - (let ((oid (switch-to-ref repository canonical-ref))) + + ;; Note: call 'commit-relation' from here because it's more efficient + ;; than letting users re-open the checkout later on. + (let* ((oid (switch-to-ref repository canonical-ref)) + (new (and starting-commit + (commit-lookup repository oid))) + (old (and starting-commit + (false-if-git-not-found + (commit-lookup repository + (string->oid starting-commit))))) + (relation (and starting-commit + (if old + (commit-relation old new) + 'unrelated)))) ;; Reclaim file descriptors and memory mappings associated with ;; REPOSITORY as soon as possible. @@ -309,7 +331,7 @@ When RECURSIVE? is true, check out submodules as well, if any." 'repository-close!) (repository-close! repository)) - (values cache-directory (oid->string oid)))))) + (values cache-directory (oid->string oid) relation))))) (define* (latest-repository-commit store url #:key @@ -342,7 +364,7 @@ Log progress and checkout info to LOG-PORT." (format log-port "updating checkout of '~a'...~%" url) (let*-values - (((checkout commit) + (((checkout commit _) (update-cached-checkout url #:recursive? recursive? #:ref ref @@ -394,7 +416,9 @@ 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 (list->setq excluded)))) + (visited (fold commit-closure + (setq) + (cons old excluded)))) (match commits (() (reverse result)) @@ -405,6 +429,21 @@ that of OLD." (cons head result) (set-insert head visited))))))) +(define (commit-relation old new) + "Return a symbol denoting the relation between OLD and NEW, two commit +objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or +'unrelated, or 'self (OLD and NEW are the same commit)." + (if (eq? old new) + 'self + (let ((newest (commit-closure new))) + (if (set-contains? newest old) + 'ancestor + (let* ((seen (list->setq (commit-parents new))) + (oldest (commit-closure old seen))) + (if (set-contains? oldest new) + 'descendant + 'unrelated)))))) + ;;; ;;; Checkouts. |