03/03: pack: Honor package transformation options.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit aad16cc1965ab3488449c262455eb29b15c77e95
Author: Ludovic Courtès <address@hidden>
Date:   Mon May 7 10:44:18 2018 +0200

    pack: Honor package transformation options.
    
    Previously they would silently be ignored.
    
    * guix/scripts/pack.scm (guix-pack)[manifest-from-args]: Add 'store'
    parameter.  Call 'options->transformation' and use it.
    Move 'with-store' and 'parameterize' around the 'let'.
    * tests/guix-pack.sh: Add test using '--with-source'.
---
 guix/scripts/pack.scm | 67 ++++++++++++++++++++++++++++-----------------------
 tests/guix-pack.sh    |  7 ++++++
 2 files changed, 44 insertions(+), 30 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index b90bc41..1f493d8 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -43,6 +43,7 @@
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (compressor?
@@ -397,9 +398,14 @@ Create a bundle of PACKAGE.\n"))
        (read/eval-package-expression exp))
       (x #f)))
 
-  (define (manifest-from-args opts)
-    (let ((packages      (filter-map maybe-package-argument opts))
-          (manifest-file (assoc-ref opts 'manifest)))
+  (define (manifest-from-args store opts)
+    (let* ((transform     (options->transformation opts))
+           (packages      (map (match-lambda
+                                 (((? package? package) output)
+                                  (list (transform store package)
+                                        output)))
+                               (filter-map maybe-package-argument opts)))
+           (manifest-file (assoc-ref opts 'manifest)))
       (cond
        ((and manifest-file (not (null? packages)))
         (leave (G_ "both a manifest and a package list were given~%")))
@@ -409,33 +415,34 @@ Create a bundle of PACKAGE.\n"))
        (else (packages->manifest packages)))))
 
   (with-error-handling
-    (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-           (manifest    (manifest-from-args opts))
-           (pack-format (assoc-ref opts 'format))
-           (name        (string-append (symbol->string pack-format)
-                                       "-pack"))
-           (target      (assoc-ref opts 'target))
-           (bootstrap?  (assoc-ref opts 'bootstrap?))
-           (compressor  (if bootstrap?
-                            bootstrap-xz
-                            (assoc-ref opts 'compressor)))
-           (tar         (if bootstrap?
-                            %bootstrap-coreutils&co
-                            tar))
-           (symlinks    (assoc-ref opts 'symlinks))
-           (build-image (match (assq-ref %formats pack-format)
-                          ((? procedure? proc) proc)
-                          (#f
-                           (leave (G_ "~a: unknown pack format")
-                                  format))))
-           (localstatedir? (assoc-ref opts 'localstatedir?)))
-      (with-store store
-        (parameterize ((%graft? (assoc-ref opts 'graft?))
-                       (%guile-for-build (package-derivation
-                                          store
-                                          (if (assoc-ref opts 'bootstrap?)
-                                              %bootstrap-guile
-                                              (canonical-package guile-2.2)))))
+    (with-store store
+      (parameterize ((%graft? (assoc-ref opts 'graft?))
+                     (%guile-for-build (package-derivation
+                                        store
+                                        (if (assoc-ref opts 'bootstrap?)
+                                            %bootstrap-guile
+                                            (canonical-package guile-2.2))
+                                        #:graft? (assoc-ref opts 'graft?))))
+        (let* ((dry-run?    (assoc-ref opts 'dry-run?))
+               (manifest    (manifest-from-args store opts))
+               (pack-format (assoc-ref opts 'format))
+               (name        (string-append (symbol->string pack-format)
+                                           "-pack"))
+               (target      (assoc-ref opts 'target))
+               (bootstrap?  (assoc-ref opts 'bootstrap?))
+               (compressor  (if bootstrap?
+                                bootstrap-xz
+                                (assoc-ref opts 'compressor)))
+               (tar         (if bootstrap?
+                                %bootstrap-coreutils&co
+                                tar))
+               (symlinks    (assoc-ref opts 'symlinks))
+               (build-image (match (assq-ref %formats pack-format)
+                              ((? procedure? proc) proc)
+                              (#f
+                               (leave (G_ "~a: unknown pack format")
+                                      format))))
+               (localstatedir? (assoc-ref opts 'localstatedir?)))
           ;; Set the build options before we do anything else.
           (set-build-options-from-command-line store opts)
 
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index d34f720..ec56ac9 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -83,3 +83,10 @@ guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ 
guile-bootstrap
 # Build a tarball pack of cross-compiled software.  Use coreutils because
 # guile-bootstrap is not intended to be cross-compiled.
 guix pack --dry-run --bootstrap --target=arm-unknown-linux-gnueabihf coreutils
+
+# Make sure package transformation options are honored.
+mkdir -p "$test_directory"
+drv1="`guix pack -n guile 2>&1 | grep pack.*\.drv`"
+drv2="`guix pack -n --with-source=guile=$test_directory guile 2>&1 | grep 
pack.*\.drv`"
+test -n "$drv1"
+test "$drv1" != "$drv2"