[bug#53144] [PATCH 10/13] upstream: Support incrementing the revision of 'git-version'.

[Maxime Devos <maximedevos@telenet.be>]

This is currently pointless, because no updater returns such versions.
A future patch will introduce an updater returning such versions.

* guix/upstream.scm
  (git-version-regexp): New variable.
  (maybe-git-version, maybe-git-version->revision)
  (maybe-git-versions->revision-replacements): New procedures.
  (update-package-source): Use 'package-definition-location' instead of
  'package-location'.  Also replace the revision.
---
 guix/upstream.scm  | 61 +++++++++++++++++++++++++++++++++++++++++++++-
 tests/upstream.scm | 37 ++++++++++++++++++++++++++++
 2 files changed, 97 insertions(+), 1 deletion(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 6666803a92..6b65147356 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -61,6 +61,10 @@ (define-module (guix upstream)
             url-prefix-predicate
             coalesce-sources
 
+            decompose-git-version
+            maybe-git-version->revision
+            maybe-git-versions->revision-replacements ; for tests
+
             upstream-updater
             upstream-updater?
             upstream-updater-name
@@ -230,6 +234,55 @@ (define (release>? r1 r2)
         (sort sources release>?)))
 
 \f
+
+
+;;;
+;;; Manipulating results of 'git-version'.
+;;; TODO: also supporting Mercurial ('hg-version') would be nice.
+;;;
+
+;; A regexp matching versions constructed by 'git-version'.
+(define git-version-regexp
+  (delay (make-regexp "^(.+)-([0123456789]+).([0123456789abcdefg]{7})$")))
+
+(define (decompose-git-version git-version-string)
+  "Split the version string GIT-VERSION-STRING constructed by 'git-version'
+in three parts: the version it was based on, the revision (as a string)
+and the abbreviated commit.  If GIT-VERSION-STRING does not correspond
+to a result of 'git-version', return #false (three times) instead."
+  (define m (regexp-exec (force git-version-regexp) git-version-string))
+  (if m
+      (values (match:substring m 1)
+              (match:substring m 2)
+              (match:substring m 3))
+      (values #false #false #false)))
+
+(define (maybe-git-version->revision maybe-git-version) ; string | #false
+  "If the string MAYBE-GIT-VERSION appears to be the result of a call to
+'git-version', return the revision (as a string).  Otherwise, return #false."
+  (let-values (((version-base revision abbreviated-commit)
+                (decompose-git-version maybe-git-version)))
+    revision))
+
+(define (maybe-git-versions->revision-replacements old new)
+  "If the two strings OLD and NEW appear to be the result of a call
+to 'git-version', return a list of replacements as expected by
+'update-expression' in 'update-package-source' for updating the revision.
+Otherwise, return the empty list."
+  (let* ((old-revision (maybe-git-version->revision old))
+         (new-revision (maybe-git-version->revision new)))
+    (if (and old-revision new-revision)
+        ;; Simply returning ((old-revision . new-revision)) would work.
+        ;; However, revision numbers are usually quite small,
+        ;; e.g. "0" or "1", so that would have a high risk of replacing
+        ;; something unrelated.  Instead, target the (revision ...) form
+        ;; in (let ((commit ...) (revision ...)) (package ...)).
+        `((,(object->string `(revision ,old-revision))
+           . ,(object->string `(revision ,new-revision))))
+        '())))
+
+\f
+
 ;;;
 ;;; Auto-update.
 ;;;
@@ -535,7 +588,11 @@ (define (update-expression expr replacements)
         (version     (upstream-source-version source))
         (version-loc (package-field-location package 'version)))
     (if version-loc
-        (let* ((loc         (package-location package))
+        ;; Use 'package-definition-location' instead of 'package-location'
+        ;; such that the commit and revision in
+        ;; (let ((commit ...) (revision ...)) (package ...)) forms can
+        ;; be updated.
+        (let* ((loc         (package-definition-location package))
                (old-version (package-version package))
                (old-hash    (content-hash-value
                              (origin-hash (package-source package))))
@@ -570,6 +627,8 @@ (define (update-expression expr replacements)
                                            'filename file))
                     (replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
+                                    ,@(maybe-git-versions->revision-replacements
+                                       old-version version)
                                     ,@(if (and old-commit new-commit)
                                           `((,old-commit . ,new-commit))
                                           '())
diff --git a/tests/upstream.scm b/tests/upstream.scm
index 9aacb77229..0b14b9867f 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@ (define-module (test-upstream)
   #:use-module (guix download)
   #:use-module (guix packages)
   #:use-module (guix build-system gnu)
+  #:use-module (guix git-download)
   #:use-module (guix import print)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix upstream)
@@ -210,4 +212,39 @@ (define test-new-package-sexp
                     '("hello" "sed" "tar" "grep"))))
       (else (pk else #false)))))
 
+(define (decompose-git-version* str)
+  (call-with-values (lambda () (decompose-git-version str)) list))
+
+(test-equal "decompose-git-version returns arguments if commit is short"
+  '("1.2.3" "900" "cabba9e")
+  (decompose-git-version* "1.2.3-900.cabba9e"))
+
+(test-equal "decompose-git-version handles - in versions"
+  '("1.2.3-rc0" "123" "ba99a9e")
+  (decompose-git-version* "1.2.3-rc0-123.ba99a9e"))
+
+(test-equal "decompose-git-version returns #false if not a git-version result"
+  '(#false #false #false)
+  (decompose-git-version* "1.2.3-rc0.ba99a9e"))
+
+(test-equal "maybe-git-version->revision returns the revision"
+  "12"
+  (maybe-git-version->revision "1.2.3-12.ba99a9e"))
+
+(test-equal "maybe-git-version->revision returns #false if not a git-version"
+  #false
+  (maybe-git-version->revision "1.2.3-12.nope"))
+
+(test-equal "maybe-git-version->revision-replacement can return ()"
+  '(() () ())
+  (map maybe-git-versions->revision-replacements
+       '("1.2.3" "1.2.3" "1.2.3-21.cabba9e")
+       '("1.2.3" "1.2.3-21.cabba9e" "1.2.3")))
+
+(test-equal "maybe-git-version->revision-replacement with git-version"
+  '(("(revision \"0\")" . "(revision \"1\")"))
+  (maybe-git-versions->revision-replacements
+   (git-version "1.2.3" "0" "cabba9e")
+   (git-version "1.2.3" "1" "ba99age")))
+
 (test-end)
-- 
2.34.0