diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 77 | ||||
| -rw-r--r-- | tests/scripts-build.scm | 65 |
3 files changed, 107 insertions, 36 deletions
diff --git a/Makefile.am b/Makefile.am index 6784da014b..dea26c81bd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -243,6 +243,7 @@ SCM_TESTS = \ tests/file-systems.scm \ tests/system.scm \ tests/services.scm \ + tests/scripts-build.scm \ tests/containers.scm \ tests/import-utils.scm diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7ca2c6ebc8..77f7a0c3bf 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -41,6 +41,7 @@ set-build-options-from-command-line set-build-options-from-command-line* show-build-options-help + options->transformation guix-build)) @@ -484,39 +485,29 @@ build." (set-guile-for-build (default-guile)) (gexp->derivation "gexp" gexp #:system system)))))) - (transform store (options->things-to-build opts))))) + (map (cut transform store <>) + (options->things-to-build opts))))) (define (transform-package-source sources) - "Return a transformation procedure that uses replaces package sources with -the matching URIs given in SOURCES." + "Return a transformation procedure that replaces package sources with the +matching URIs given in SOURCES." (define new-sources (map (lambda (uri) (cons (package-name->name+version (basename uri)) uri)) sources)) - (lambda (store packages) - (let loop ((packages packages) - (sources new-sources) + (lambda (store obj) + (let loop ((sources new-sources) (result '())) - (match packages - (() - (unless (null? sources) - (warning (_ "sources do not match any package:~{ ~a~}~%") - (match sources - (((name . uri) ...) - uri)))) - (reverse result)) - (((? package? p) tail ...) + (match obj + ((? package? p) (let ((source (assoc-ref sources (package-name p)))) - (loop tail - (alist-delete (package-name p) sources) - (cons (if source - (package-with-source store p source) - p) - result)))) - ((thing tail ...) - (loop tail sources result)))))) + (if source + (package-with-source store p source) + p))) + (_ + obj))))) (define %transformations ;; Transformations that can be applied to things to build. The car is the @@ -526,19 +517,33 @@ the matching URIs given in SOURCES." `((with-source . ,transform-package-source))) (define (options->transformation opts) - "Return a procedure that, when passed a list of things to build (packages, -derivations, etc.), applies the transformations specified by OPTS." - (apply compose - (map (match-lambda - ((key . transform) - (let ((args (filter-map (match-lambda - ((k . arg) - (and (eq? k key) arg))) - opts))) - (if (null? args) - (lambda (store things) things) - (transform args))))) - %transformations))) + "Return a procedure that, when passed an object to build (package, +derivation, etc.), applies the transformations specified by OPTS." + (define applicable + ;; List of applicable transformations as symbol/procedure pairs. + (filter-map (match-lambda + ((key . transform) + (match (filter-map (match-lambda + ((k . arg) + (and (eq? k key) arg))) + opts) + (() #f) + (args (cons key (transform args)))))) + %transformations)) + + (lambda (store obj) + (fold (match-lambda* + (((name . transform) obj) + (let ((new (transform store obj))) + (when (eq? new obj) + (warning (_ "transformation '~a' had no effect on ~a~%") + name + (if (package? obj) + (package-full-name obj) + obj))) + new))) + obj + applicable))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm new file mode 100644 index 0000000000..75dc119e88 --- /dev/null +++ b/tests/scripts-build.scm @@ -0,0 +1,65 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-scripts-build) + #:use-module (guix tests) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix scripts build) + #:use-module (guix ui) + #:use-module (srfi srfi-64)) + + +(test-begin "scripts-build") + +(test-assert "options->transformation, no transformations" + (let ((p (dummy-package "foo")) + (t (options->transformation '()))) + (with-store store + (eq? (t store p) p)))) + +(test-assert "options->transformation, with-source" + ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should + ;; be applicable. + (let* ((p (dummy-package "guix.scm")) + (s (search-path %load-path "guix.scm")) + (t (options->transformation `((with-source . ,s))))) + (with-store store + (let ((new (t store p))) + (and (not (eq? new p)) + (string=? (package-source new) + (add-to-store store "guix.scm" #t + "sha256" s))))))) + +(test-assert "options->transformation, with-source, no matches" + ;; When a transformation in not applicable, a warning must be raised. + (let* ((p (dummy-package "foobar")) + (s (search-path %load-path "guix.scm")) + (t (options->transformation `((with-source . ,s))))) + (with-store store + (let* ((port (open-output-string)) + (new (parameterize ((guix-warning-port port)) + (t store p)))) + (and (eq? new p) + (string-contains (get-output-string port) + "had no effect")))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |