mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

upstream: Define ‘preferred-upstream-source’.

Browse source 
* guix/upstream.scm (preferred-upstream-source): New procedure.
* tests/upstream.scm ("preferred-upstream-source"): New test.

Change-Id: I4b48b44f1aa233d2e99bfe2e1359a670297efae8
This commit is contained in:
Ludovic Courtès 2024-12-27 11:48:28 +01:00
parent af79677cb4
commit 1b1b921d61
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 32 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
guix/upstream.scm
View file

@ -76,6 +76,7 @@ (define-module (guix upstream)
url-predicate url-predicate
url-prefix-predicate url-prefix-predicate
coalesce-sources coalesce-sources
preferred-upstream-source
upstream-updater upstream-updater
upstream-updater? upstream-updater?
@ -445,6 +446,17 @@ (define (preferred-upstream-source-url source package)
(or (upstream-source-signature-urls source) (or (upstream-source-signature-urls source)
(circular-list #f))))) (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 (define* (package-update/url-fetch store package source
#:key key-download key-server) #:key key-download key-server)
"Return the version, tarball, and SOURCE, to update PACKAGE to "Return the version, tarball, and SOURCE, to update PACKAGE to

21
tests/upstream.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -26,6 +26,7 @@ (define-module (test-upstream)
#:use-module ((guix licenses) #:prefix license:) #:use-module ((guix licenses) #:prefix license:)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (ice-9 match)) #:use-module (ice-9 match))
@ -55,4 +56,22 @@ (define-module (test-upstream)
(signature-urls (signature-urls
'("ftp://example.org/foo-1.tar.xz.sig"))))))) '("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) (test-end)