diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2024-12-27 11:48:28 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2025-01-08 23:03:04 +0100 |
| commit | 1b1b921d61673ddc7f8211248a4a8c4d88c8794c (patch) | |
| tree | cefb2ad641f202ba30724a28e5ba44be5e0dfb4e | |
| parent | af79677cb4a81964fee6413ef81e257eac5ff695 (diff) | |
upstream: Define ‘preferred-upstream-source’.
* guix/upstream.scm (preferred-upstream-source): New procedure.
* tests/upstream.scm ("preferred-upstream-source"): New test.
Change-Id: I4b48b44f1aa233d2e99bfe2e1359a670297efae8
| -rw-r--r-- | guix/upstream.scm | 12 | ||||
| -rw-r--r-- | tests/upstream.scm | 21 |
2 files changed, 32 insertions, 1 deletions
diff --git a/guix/upstream.scm b/guix/upstream.scm index a6659c3b14..19c5efc21b 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -76,6 +76,7 @@ url-predicate url-prefix-predicate coalesce-sources + preferred-upstream-source upstream-updater upstream-updater? @@ -445,6 +446,17 @@ is no signature. Return #f and #f when this is not applicable." (or (upstream-source-signature-urls source) (circular-list #f))))) +(define (preferred-upstream-source source package) + "Return a variant of SOURCE that uses the same archive type as PACKAGE's +source (gz, xz, zst, etc.). Return SOURCE if this is not applicable." + (let ((url signature-url (preferred-upstream-source-url source package))) + (if url + (upstream-source + (inherit source) + (urls (list url)) + (signature-urls (and=> signature-url list))) + source))) + (define* (package-update/url-fetch store package source #:key key-download key-server) "Return the version, tarball, and SOURCE, to update PACKAGE to diff --git a/tests/upstream.scm b/tests/upstream.scm index a94bb66068..c75ab091e5 100644 --- a/tests/upstream.scm +++ b/tests/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2023-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -26,6 +26,7 @@ #:use-module ((guix licenses) #:prefix license:) #:use-module (guix upstream) #:use-module (guix tests) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -55,4 +56,22 @@ (signature-urls '("ftp://example.org/foo-1.tar.xz.sig"))))))) +(test-equal "preferred-upstream-source" + '(("http://example.org/foo-2.0.tar.xz") + ("http://example.org/foo-2.0.tar.xz.sig")) + (let* ((package (dummy-package + "foo" + (version "1.0") + (source + (dummy-origin (uri "http://example.org/foo-1.0.tar.xz"))))) + (source (upstream-source + (package "foo") + (version "2.0") + (urls '("http://example.org/foo-2.0.tar.gz" + "http://example.org/foo-2.0.tar.xz")) + (signature-urls (map (cut string-append <> ".sig") urls)))) + (preferred (preferred-upstream-source source package))) + (list (upstream-source-urls preferred) + (upstream-source-signature-urls preferred)))) + (test-end) |