mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
environment: Support package transformation options.
Fixes <https://bugs.gnu.org/33776>. Reported by Adrien Guilbaud <adrien.guilbaud@inria.fr>. * guix/scripts/environment.scm (show-help): Add call to 'show-transformation-options-help'. (%options): Add %TRANSFORMATION-OPTIONS. (options/resolve-packages): Add 'store' parameter. [transform, package->manifest-entry*]: New procedures. Use 'package->manifest-entry*' instead of 'package->manifest-entry'. (guix-environment): Move definition of 'manifest' within 'with-store'. * tests/guix-environment.sh: Add test.
This commit is contained in:
parent
bafcf1f32f
commit
a93c160631
3 changed files with 33 additions and 8 deletions
|
@ -8350,7 +8350,8 @@ guix environment --container --share=$HOME=/exchange --ad-hoc guile -- guile
|
||||||
|
|
||||||
@command{guix environment}
|
@command{guix environment}
|
||||||
also supports all of the common build options that @command{guix
|
also supports all of the common build options that @command{guix
|
||||||
build} supports (@pxref{Common Build Options}).
|
build} supports (@pxref{Common Build Options}) as well as package
|
||||||
|
transformation options (@pxref{Package Transformation Options}).
|
||||||
|
|
||||||
|
|
||||||
@node Invoking guix publish
|
@node Invoking guix publish
|
||||||
|
|
|
@ -162,6 +162,8 @@ (define (show-help)
|
||||||
(newline)
|
(newline)
|
||||||
(show-build-options-help)
|
(show-build-options-help)
|
||||||
(newline)
|
(newline)
|
||||||
|
(show-transformation-options-help)
|
||||||
|
(newline)
|
||||||
(display (G_ "
|
(display (G_ "
|
||||||
-h, --help display this help and exit"))
|
-h, --help display this help and exit"))
|
||||||
(display (G_ "
|
(display (G_ "
|
||||||
|
@ -261,7 +263,9 @@ (define %options
|
||||||
(option '("bootstrap") #f #f
|
(option '("bootstrap") #f #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'bootstrap? #t result)))
|
(alist-cons 'bootstrap? #t result)))
|
||||||
%standard-build-options))
|
|
||||||
|
(append %transformation-options
|
||||||
|
%standard-build-options)))
|
||||||
|
|
||||||
(define (pick-all alist key)
|
(define (pick-all alist key)
|
||||||
"Return a list of values in ALIST associated with KEY."
|
"Return a list of values in ALIST associated with KEY."
|
||||||
|
@ -274,7 +278,7 @@ (define same-key? (cut eq? key <>))
|
||||||
(_ memo)))
|
(_ memo)))
|
||||||
'() alist))
|
'() alist))
|
||||||
|
|
||||||
(define (options/resolve-packages opts)
|
(define (options/resolve-packages store opts)
|
||||||
"Return OPTS with package specification strings replaced by manifest entries
|
"Return OPTS with package specification strings replaced by manifest entries
|
||||||
for the corresponding packages."
|
for the corresponding packages."
|
||||||
(define (manifest-entry=? e1 e2)
|
(define (manifest-entry=? e1 e2)
|
||||||
|
@ -282,15 +286,21 @@ (define (manifest-entry=? e1 e2)
|
||||||
(string=? (manifest-entry-output e1)
|
(string=? (manifest-entry-output e1)
|
||||||
(manifest-entry-output e2))))
|
(manifest-entry-output e2))))
|
||||||
|
|
||||||
|
(define transform
|
||||||
|
(cut (options->transformation opts) store <>))
|
||||||
|
|
||||||
|
(define* (package->manifest-entry* package #:optional (output "out"))
|
||||||
|
(package->manifest-entry (transform package) output))
|
||||||
|
|
||||||
(define (packages->outputs packages mode)
|
(define (packages->outputs packages mode)
|
||||||
(match packages
|
(match packages
|
||||||
((? package? package)
|
((? package? package)
|
||||||
(if (eq? mode 'ad-hoc-package)
|
(if (eq? mode 'ad-hoc-package)
|
||||||
(list (package->manifest-entry package))
|
(list (package->manifest-entry* package))
|
||||||
(package-environment-inputs package)))
|
(package-environment-inputs package)))
|
||||||
(((? package? package) (? string? output))
|
(((? package? package) (? string? output))
|
||||||
(if (eq? mode 'ad-hoc-package)
|
(if (eq? mode 'ad-hoc-package)
|
||||||
(list (package->manifest-entry package output))
|
(list (package->manifest-entry* package output))
|
||||||
(package-environment-inputs package)))
|
(package-environment-inputs package)))
|
||||||
((lst ...)
|
((lst ...)
|
||||||
(append-map (cut packages->outputs <> mode) lst))))
|
(append-map (cut packages->outputs <> mode) lst))))
|
||||||
|
@ -301,7 +311,7 @@ (define (packages->outputs packages mode)
|
||||||
(('package 'ad-hoc-package (? string? spec))
|
(('package 'ad-hoc-package (? string? spec))
|
||||||
(let-values (((package output)
|
(let-values (((package output)
|
||||||
(specification->package+output spec)))
|
(specification->package+output spec)))
|
||||||
(list (package->manifest-entry package output))))
|
(list (package->manifest-entry* package output))))
|
||||||
(('package 'package (? string? spec))
|
(('package 'package (? string? spec))
|
||||||
(package-environment-inputs
|
(package-environment-inputs
|
||||||
(specification->package+output spec)))
|
(specification->package+output spec)))
|
||||||
|
@ -654,7 +664,6 @@ (define (guix-environment . args)
|
||||||
;; within the container.
|
;; within the container.
|
||||||
'("/bin/sh")
|
'("/bin/sh")
|
||||||
(list %default-shell))))
|
(list %default-shell))))
|
||||||
(manifest (options/resolve-packages opts))
|
|
||||||
(mappings (pick-all opts 'file-system-mapping)))
|
(mappings (pick-all opts 'file-system-mapping)))
|
||||||
|
|
||||||
(when container? (assert-container-features))
|
(when container? (assert-container-features))
|
||||||
|
@ -666,6 +675,9 @@ (define (guix-environment . args)
|
||||||
|
|
||||||
(with-store store
|
(with-store store
|
||||||
(with-status-report print-build-event
|
(with-status-report print-build-event
|
||||||
|
(define manifest
|
||||||
|
(options/resolve-packages store opts))
|
||||||
|
|
||||||
(set-build-options-from-command-line store opts)
|
(set-build-options-from-command-line store opts)
|
||||||
|
|
||||||
;; Use the bootstrap Guile when requested.
|
;; Use the bootstrap Guile when requested.
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
# GNU Guix --- Functional package management for GNU
|
# GNU Guix --- Functional package management for GNU
|
||||||
# Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
# Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||||
#
|
#
|
||||||
# This file is part of GNU Guix.
|
# This file is part of GNU Guix.
|
||||||
#
|
#
|
||||||
|
@ -118,6 +118,18 @@ fi
|
||||||
# in its profile (e.g., for 'gzip'), but we have to accept them.
|
# in its profile (e.g., for 'gzip'), but we have to accept them.
|
||||||
guix environment guix --bootstrap -n
|
guix environment guix --bootstrap -n
|
||||||
|
|
||||||
|
# Try program transformation options.
|
||||||
|
mkdir "$tmpdir/emacs-36.8"
|
||||||
|
drv="`guix environment --ad-hoc emacs -n 2>&1 | grep 'emacs.*\.drv'`"
|
||||||
|
transformed_drv="`guix environment --ad-hoc emacs --with-source="$tmpdir/emacs-36.8" -n 2>&1 | grep 'emacs.*\.drv'`"
|
||||||
|
test -n "$drv"
|
||||||
|
test "$drv" != "$transformed_drv"
|
||||||
|
case "$transformed_drv" in
|
||||||
|
*-emacs-36.8.drv) true;;
|
||||||
|
*) false;;
|
||||||
|
esac
|
||||||
|
rmdir "$tmpdir/emacs-36.8"
|
||||||
|
|
||||||
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
|
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
|
||||||
then
|
then
|
||||||
# Compute the build environment for the initial GNU Make.
|
# Compute the build environment for the initial GNU Make.
|
||||||
|
|
Loading…
Reference in a new issue