Archived
1
0
Fork 0

home: import: Factorize triplicated 'version-spec' procedure.

* guix/scripts/package.scm (manifest-entry-version-prefix): New
procedure, moved from...
(export-manifest)[version-spec]: ... here.  Adjust caller.
* tests/home-import.scm (version-spec): Remove.
(eval-test-with-home-environment): Use 'manifest-entry-version-prefix'
instead.
* guix/scripts/home/import.scm (import-manifest): Likewise.
This commit is contained in:
Ludovic Courtès 2021-10-30 23:30:50 +02:00
parent f3933ae40d
commit 96728c54df
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 32 additions and 64 deletions

View file

@ -22,6 +22,7 @@
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix packages) #:use-module (guix packages)
#:autoload (guix scripts package) (manifest-entry-version-prefix)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
@ -241,28 +242,8 @@ containing PACKAGES, or SPECS (package specifications), and SERVICES."
manifest destination-directory manifest destination-directory
#:optional (port (current-output-port))) #:optional (port (current-output-port)))
"Write to PORT a <home-environment> corresponding to MANIFEST." "Write to PORT a <home-environment> corresponding to MANIFEST."
(define (version-spec entry)
(let ((name (manifest-entry-name entry)))
(match (map package-version (find-packages-by-name name))
((_)
;; A single version of NAME is available, so do not specify the
;; version number, even if the available version doesn't match ENTRY.
"")
(versions
;; If ENTRY uses the latest version, don't specify any version.
;; Otherwise return the shortest unique version prefix. Note that
;; this is based on the currently available packages, which could
;; differ from the packages available in the revision that was used
;; to build MANIFEST.
(let ((current (manifest-entry-version entry)))
(if (every (cut version>? current <>)
(delete current versions))
""
(version-unique-prefix (manifest-entry-version entry)
versions)))))))
(match (manifest->code manifest destination-directory (match (manifest->code manifest destination-directory
#:entry-package-version version-spec #:entry-package-version manifest-entry-version-prefix
#:home-environment? #t) #:home-environment? #t)
(('begin exp ...) (('begin exp ...)
(format port (G_ "\ (format port (G_ "\

View file

@ -68,6 +68,7 @@
guix-package guix-package
search-path-environment-variables search-path-environment-variables
manifest-entry-version-prefix
transaction-upgrade-entry ;mostly for testing transaction-upgrade-entry ;mostly for testing
@ -327,10 +328,10 @@ Alternately, see @command{guix package --search-paths -p ~s}.")
;;; Export a manifest. ;;; Export a manifest.
;;; ;;;
(define* (export-manifest manifest (define (manifest-entry-version-prefix entry)
#:optional (port (current-output-port))) "Search among all the versions of ENTRY's package that are available, and
"Write to PORT a manifest corresponding to MANIFEST." return the shortest unambiguous version prefix for this package. If only one
(define (version-spec entry) version of ENTRY's package is available, return the empty string."
(let ((name (manifest-entry-name entry))) (let ((name (manifest-entry-name entry)))
(match (map package-version (find-packages-by-name name)) (match (map package-version (find-packages-by-name name))
((_) ((_)
@ -350,8 +351,12 @@ Alternately, see @command{guix package --search-paths -p ~s}.")
(version-unique-prefix (manifest-entry-version entry) (version-unique-prefix (manifest-entry-version entry)
versions))))))) versions)))))))
(define* (export-manifest manifest
#:optional (port (current-output-port)))
"Write to PORT a manifest corresponding to MANIFEST."
(match (manifest->code manifest (match (manifest->code manifest
#:entry-package-version version-spec) #:entry-package-version
manifest-entry-version-prefix)
(('begin exp ...) (('begin exp ...)
(format port (G_ "\ (format port (G_ "\
;; This \"manifest\" file can be passed to 'guix package -m' to reproduce ;; This \"manifest\" file can be passed to 'guix package -m' to reproduce

View file

@ -24,6 +24,8 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((guix profiles) #:hide (manifest->code)) #:use-module ((guix profiles) #:hide (manifest->code))
#:use-module ((guix build syscalls) #:select (mkdtemp!)) #:use-module ((guix build syscalls) #:select (mkdtemp!))
#:use-module ((guix scripts package)
#:select (manifest-entry-version-prefix))
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -81,33 +83,13 @@ corresponding file."
((file . content) (create-file file content))) ((file . content) (create-file file content)))
files-alist)) files-alist))
;; Copied from (guix profiles)
(define (version-spec entry)
(let ((name (manifest-entry-name entry)))
(match (map package-version (find-packages-by-name name))
((_)
;; A single version of NAME is available, so do not specify the
;; version number, even if the available version doesn't match ENTRY.
"")
(versions
;; If ENTRY uses the latest version, don't specify any version.
;; Otherwise return the shortest unique version prefix. Note that
;; this is based on the currently available packages, which could
;; differ from the packages available in the revision that was used
;; to build MANIFEST.
(let ((current (manifest-entry-version entry)))
(if (every (cut version>? current <>)
(delete current versions))
""
(version-unique-prefix (manifest-entry-version entry)
versions)))))))
(define (eval-test-with-home-environment files-alist manifest matcher) (define (eval-test-with-home-environment files-alist manifest matcher)
(create-temporary-home files-alist) (create-temporary-home files-alist)
(setenv "HOME" %temporary-home-directory) (setenv "HOME" %temporary-home-directory)
(mkdir-p %temporary-home-directory) (mkdir-p %temporary-home-directory)
(let* ((home-environment (manifest->code manifest %destination-directory (let* ((home-environment (manifest->code manifest %destination-directory
#:entry-package-version version-spec #:entry-package-version
manifest-entry-version-prefix
#:home-environment? #t)) #:home-environment? #t))
(result (matcher home-environment))) (result (matcher home-environment)))
(delete-file-recursively %temporary-home-directory) (delete-file-recursively %temporary-home-directory)