From 05962f2958eb98bad384702455236ff9d2acfb39 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 27 Oct 2014 18:09:00 +0100
Subject: packages: Implement grafts.

Thanks to Mark H. Weaver <mhw@netris.org> for insightful discussions
and suggestions.

* guix/packages.scm (<package>)[graft]: New field.
  (patch-and-repack): Invoke 'package-derivation' with #:graft? #f.
  (package-source-derivation): Likewise.  Do not use (%guile-for-build)
  in call to 'patch-and-repack', and we could end up using a grafted
  Guile.
  (expand-input): Likewise, also for 'package-cross-derivation' call.
  (package->bag): Add #:graft? parameter.  Honor it.  Use 'strip-append'
  instead of 'package-full-name'.
  (input-graft, input-cross-graft, bag-grafts, package-grafts): New
  procedures.
  (package-derivation, package-cross-derivation): Add #:graft? parameter
  and honor it.
* gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Add
  recursive call on 'graft'.
* guix/build-system/gnu.scm (package-with-explicit-inputs,
  package-with-extra-configure-variable, static-package): Likewise.
  (gnu-build): Use the ungrafted Guile to avoid full rebuilds.
  (gnu-cross-build): Likewise.
* guix/build-system/cmake.scm (cmake-build): Likewise.
* guix/build-system/glib-or-gtk.scm (glib-or-gtk-build): Likewise.
* guix/build-system/perl.scm (perl-build): Likewise.
* guix/build-system/python.scm (python-build): Likewise.
* guix/build-system/ruby.scm (ruby-build): Likewise.
* guix/build-system/trivial.scm (guile-for-build): Likewise.
* tests/packages.scm ("package-derivation, direct graft",
  "package-cross-derivation, direct graft", "package-grafts,
  indirect grafts", "package-grafts, indirect grafts, cross",
  "package-grafts, indirect grafts, propagated inputs",
  "package-derivation, indirect grafts"): New tests.
  ("bag->derivation", "bag->derivation, cross-compilation"): Wrap in
  'parameterize'.
* doc/guix.texi (Security Updates): New node.
  (Invoking guix build): Document --no-graft.
---
 guix/scripts/build.scm | 47 ++++++++++++++++++++++++++++-------------------
 1 file changed, 28 insertions(+), 19 deletions(-)

(limited to 'guix/scripts/build.scm')

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index cde2a25613..7b7f419f3a 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -202,6 +202,7 @@ (define %standard-build-options
 (define %default-options
   ;; Alist of default option values.
   `((system . ,(%current-system))
+    (graft? . #t)
     (substitutes? . #t)
     (build-hook? . #t)
     (print-build-trace? . #t)
@@ -222,6 +223,8 @@ (define (show-help)
   (display (_ "
       --with-source=SOURCE
                          use SOURCE when building the corresponding package"))
+  (display (_ "
+      --no-grafts        do not graft packages"))
   (display (_ "
   -d, --derivations      return the derivation paths of the given packages"))
   (display (_ "
@@ -278,6 +281,10 @@ (define %options
          (option '("with-source") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'with-source arg result)))
+         (option '("no-grafts") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'graft? #f
+                               (alist-delete 'graft? result eq?))))
 
          %standard-build-options))
 
@@ -290,26 +297,28 @@ (define package->derivation
       (triplet
        (cut package-cross-derivation <> <> triplet <>))))
 
-  (define src? (assoc-ref opts 'source?))
-  (define sys  (assoc-ref opts 'system))
+  (define src?   (assoc-ref opts 'source?))
+  (define sys    (assoc-ref opts 'system))
+  (define graft? (assoc-ref opts 'graft?))
 
-  (let ((opts (options/with-source store
-                                   (options/resolve-packages store opts))))
-    (filter-map (match-lambda
-                 (('argument . (? package? p))
-                  (if src?
-                      (let ((s (package-source p)))
-                        (package-source-derivation store s))
-                      (package->derivation store p sys)))
-                 (('argument . (? derivation? drv))
-                  drv)
-                 (('argument . (? derivation-path? drv))
-                  (call-with-input-file drv read-derivation))
-                 (('argument . (? store-path?))
-                  ;; Nothing to do; maybe for --log-file.
-                  #f)
-                 (_ #f))
-                opts)))
+  (parameterize ((%graft? graft?))
+    (let ((opts (options/with-source store
+                                     (options/resolve-packages store opts))))
+      (filter-map (match-lambda
+                   (('argument . (? package? p))
+                    (if src?
+                        (let ((s (package-source p)))
+                          (package-source-derivation store s))
+                        (package->derivation store p sys)))
+                   (('argument . (? derivation? drv))
+                    drv)
+                   (('argument . (? derivation-path? drv))
+                    (call-with-input-file drv read-derivation))
+                   (('argument . (? store-path?))
+                    ;; Nothing to do; maybe for --log-file.
+                    #f)
+                   (_ #f))
+                  opts))))
 
 (define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by actual
-- 
cgit v1.2.3