summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cmake.scm2
-rw-r--r--guix/build-system/meson.scm2
-rw-r--r--guix/build/gnu-build-system.scm130
-rw-r--r--guix/build/go-build-system.scm2
-rw-r--r--guix/build/meson-build-system.scm1
-rw-r--r--guix/build/python-build-system.scm33
-rw-r--r--guix/build/syscalls.scm28
-rw-r--r--guix/build/utils.scm230
-rw-r--r--guix/channels.scm52
-rw-r--r--guix/download.scm28
-rw-r--r--guix/gexp.scm75
-rw-r--r--guix/packages.scm51
-rw-r--r--guix/scripts/environment.scm10
-rw-r--r--guix/scripts/pack.scm6
-rw-r--r--guix/self.scm1
-rw-r--r--guix/tests.scm68
16 files changed, 569 insertions, 150 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index ee116c5a4c..ca88fadddf 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -48,7 +48,7 @@
;; Do not use `@' to avoid introducing circular dependencies.
(let ((module (resolve-interface '(gnu packages cmake))))
- (module-ref module 'cmake)))
+ (module-ref module 'cmake-minimal)))
(define* (lower name
#:key source inputs native-inputs outputs system target
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index 370d185545..b29f2f4ecf 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -90,7 +90,7 @@
(outputs '("out"))
(configure-flags ''())
(search-paths '())
- (build-type "plain")
+ (build-type "debugoptimized")
(tests? #t)
(test-target "test")
(glib-or-gtk? #f)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index e5f3197b0a..4df0bb4904 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -25,6 +25,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
@@ -58,19 +59,14 @@ See https://reproducible-builds.org/specs/source-date-epoch/."
(setenv "SOURCE_DATE_EPOCH" "1")
#t)
-(define (first-subdirectory dir)
- "Return the path of the first sub-directory of DIR."
- (file-system-fold (lambda (path stat result)
- (string=? path dir))
- (lambda (path stat result) result) ; leaf
- (lambda (path stat result) result) ; down
- (lambda (path stat result) result) ; up
- (lambda (path stat result) ; skip
- (or result path))
- (lambda (path stat errno result) ; error
- (error "first-subdirectory" (strerror errno)))
- #f
- dir))
+(define (first-subdirectory directory)
+ "Return the file name of the first sub-directory of DIRECTORY."
+ (match (scandir directory
+ (lambda (file)
+ (and (not (member file '("." "..")))
+ (file-is-directory? (string-append directory "/"
+ file)))))
+ ((first . _) first)))
(define* (set-paths #:key target inputs native-inputs
(search-paths '()) (native-search-paths '())
@@ -735,23 +731,64 @@ which cannot be found~%"
(define* (install-license-files #:key outputs
(license-file-regexp %license-file-regexp)
+ out-of-source?
#:allow-other-keys)
"Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
+ (define (find-source-directory package)
+ ;; For an out-of-source build, guess the source directory location
+ ;; relative to the current directory. Return #f on failure.
+ (match (scandir ".."
+ (lambda (file)
+ (and (not (member file '("." ".." "build")))
+ (file-is-directory?
+ (string-append "../" file)))))
+ (() ;hmm, no source
+ #f)
+ ((source) ;only one other file
+ (string-append "../" source))
+ ((directories ...) ;pick the most likely one
+ ;; This happens for example with libstdc++, which lives within the GCC
+ ;; source tree.
+ (any (lambda (directory)
+ (and (string-prefix? package directory)
+ (string-append "../" directory)))
+ directories))))
+
+ (define (copy-to-directories directories sub-directory)
+ (lambda (file)
+ (for-each (if (file-is-directory? file)
+ (cut copy-recursively file <>)
+ (cut install-file file <>))
+ (map (cut string-append <> "/" sub-directory)
+ directories))))
+
(let* ((regexp (make-regexp license-file-regexp))
(out (or (assoc-ref outputs "out")
(match outputs
(((_ . output) _ ...)
output))))
(package (strip-store-file-name out))
- (directory (string-append out "/share/doc/" package))
- (files (scandir "." (lambda (file)
- (regexp-exec regexp file)))))
- (format #t "installing ~a license files~%" (length files))
- (for-each (lambda (file)
- (if (file-is-directory? file)
- (copy-recursively file directory)
- (install-file file directory)))
- files)
+ (outputs (match outputs
+ (((_ . outputs) ...)
+ outputs)))
+ (source (if out-of-source?
+ (find-source-directory
+ (package-name->name+version package))
+ "."))
+ (files (and source
+ (scandir source
+ (lambda (file)
+ (regexp-exec regexp file))))))
+ (if files
+ (begin
+ (format #t "installing ~a license files from '~a'~%"
+ (length files) source)
+ (for-each (copy-to-directories outputs
+ (string-append "share/doc/"
+ package))
+ (map (cut string-append source "/" <>) files)))
+ (format (current-error-port)
+ "failed to find license files~%"))
#t))
(define %standard-phases
@@ -784,34 +821,37 @@ in order. Return #t if all the PHASES succeeded, #f otherwise."
(+ (time-second diff)
(/ (time-nanosecond diff) 1e9))))
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
;; Encoding/decoding errors shouldn't be silent.
(fluid-set! %default-port-conversion-strategy 'error)
- ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
- ;; PHASES can pick the keyword arguments it's interested in.
- (every (match-lambda
- ((name . proc)
- (let ((start (current-time time-monotonic)))
- (format #t "starting phase `~a'~%" name)
- (let ((result (apply proc args))
- (end (current-time time-monotonic)))
- (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
- name result
- (elapsed-time end start))
-
- ;; Issue a warning unless the result is #t.
- (unless (eqv? result #t)
- (format (current-error-port) "\
+ (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ (exit 1)))
+ ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
+ ;; PHASES can pick the keyword arguments it's interested in.
+ (every (match-lambda
+ ((name . proc)
+ (let ((start (current-time time-monotonic)))
+ (format #t "starting phase `~a'~%" name)
+ (let ((result (apply proc args))
+ (end (current-time time-monotonic)))
+ (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
+ name result
+ (elapsed-time end start))
+
+ ;; Issue a warning unless the result is #t.
+ (unless (eqv? result #t)
+ (format (current-error-port) "\
## WARNING: phase `~a' returned `~s'. Return values other than #t
## are deprecated. Please migrate this package so that its phase
## procedures report errors by raising an exception, and otherwise
## always return #t.~%"
- name result))
+ name result))
- ;; Dump the environment variables as a shell script, for handy debugging.
- (system "export > $NIX_BUILD_TOP/environment-variables")
- result))))
- phases))
+ ;; Dump the environment variables as a shell script, for handy debugging.
+ (system "export > $NIX_BUILD_TOP/environment-variables")
+ result))))
+ phases)))
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 3dac43c18a..4bc0156a88 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -237,7 +237,7 @@ unpacking."
"Install the source code of IMPORT-PATH to the primary output directory.
Compiled executable files (Go \"commands\") should have already been installed
to the store based on $GOBIN in the build phase.
-XXX We can't make us of compiled libraries (Go \"packages\")."
+XXX We can't make use of compiled libraries (Go \"packages\")."
(when install-source?
(if (string-null? import-path)
((display "WARNING: The Go import path is unset.\n")))
diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
index d0975fcab0..8043a84abb 100644
--- a/guix/build/meson-build-system.scm
+++ b/guix/build/meson-build-system.scm
@@ -108,6 +108,7 @@ for example libraries only needed for the tests."
;; from the gnu-build-system. If the glib-or-gtk? key is #f (the default)
;; then the extra phases will be removed again in (guix build-system meson).
(modify-phases glib-or-gtk:%standard-phases
+ (delete 'bootstrap)
(replace 'configure configure)
(replace 'build build)
(replace 'check check)
diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 5bb0ba49d5..09bd8465c8 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -1,10 +1,11 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,6 +32,7 @@
#:export (%standard-phases
add-installed-pythonpath
site-packages
+ python-version
python-build))
;; Commentary:
@@ -146,7 +148,7 @@
(format #t "test suite not run~%"))
#t)
-(define (get-python-version python)
+(define (python-version python)
(let* ((version (last (string-split python #\-)))
(components (string-split version #\.))
(major+minor (take components 2)))
@@ -157,7 +159,7 @@
(let* ((out (assoc-ref outputs "out"))
(python (assoc-ref inputs "python")))
(string-append out "/lib/python"
- (get-python-version python)
+ (python-version python)
"/site-packages/")))
(define (add-installed-pythonpath inputs outputs)
@@ -186,11 +188,9 @@ when running checks after installing the package."
(define* (wrap #:key inputs outputs #:allow-other-keys)
(define (list-of-files dir)
- (map (cut string-append dir "/" <>)
- (or (scandir dir (lambda (f)
- (let ((s (stat (string-append dir "/" f))))
- (eq? 'regular (stat:type s)))))
- '())))
+ (find-files dir (lambda (file stat)
+ (and (eq? 'regular (stat:type stat))
+ (not (wrapper? file))))))
(define bindirs
(append-map (match-lambda
@@ -203,7 +203,7 @@ when running checks after installing the package."
(python (assoc-ref inputs "python"))
(var `("PYTHONPATH" prefix
,(cons (string-append out "/lib/python"
- (get-python-version python)
+ (python-version python)
"/site-packages")
(search-path-as-string->list
(or (getenv "PYTHONPATH") ""))))))
@@ -223,7 +223,7 @@ installed with setuptools."
(let* ((out (assoc-ref outputs "out"))
(python (assoc-ref inputs "python"))
(site-packages (string-append out "/lib/python"
- (get-python-version python)
+ (python-version python)
"/site-packages"))
(easy-install-pth (string-append site-packages "/easy-install.pth"))
(new-pth (string-append site-packages "/" name ".pth")))
@@ -251,16 +251,21 @@ installed with setuptools."
#t)
(define %standard-phases
- ;; 'configure' phase is not needed.
+ ;; The build phase only builds C extensions and copies the Python sources,
+ ;; while the install phase byte-compiles and copies them to the prefix
+ ;; directory. The tests are run after the install phase because otherwise
+ ;; the cached .pyc generated during the tests execution seem to interfere
+ ;; with the byte compilation of the install phase.
(modify-phases gnu:%standard-phases
(add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980)
(add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism
enable-bytecode-determinism)
(delete 'bootstrap)
- (delete 'configure)
- (replace 'install install)
- (replace 'check check)
+ (delete 'configure) ;not needed
(replace 'build build)
+ (delete 'check) ;moved after the install phase
+ (replace 'install install)
+ (add-after 'install 'check check)
(add-after 'install 'wrap wrap)
(add-before 'strip 'rename-pth-file rename-pth-file)))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index f2fdb4d9d1..bbf2531c79 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -68,6 +68,7 @@
statfs
free-disk-space
device-in-use?
+ add-to-entropy-count
processes
mkdtemp!
@@ -708,6 +709,33 @@ backend device."
;;;
+;;; Random.
+;;;
+
+;; From <uapi/linux/random.h>.
+(define RNDADDTOENTCNT #x40045201)
+
+(define (add-to-entropy-count port-or-fd n)
+ "Add N to the kernel's entropy count (the value that can be read from
+/proc/sys/kernel/random/entropy_avail). PORT-OR-FD must correspond to
+/dev/urandom or /dev/random. Raise to 'system-error with EPERM when the
+caller lacks root privileges."
+ (let ((fd (if (port? port-or-fd)
+ (fileno port-or-fd)
+ port-or-fd))
+ (box (make-bytevector (sizeof int))))
+ (bytevector-sint-set! box 0 n (native-endianness)
+ (sizeof int))
+ (let-values (((ret err)
+ (%ioctl fd RNDADDTOENTCNT
+ (bytevector->pointer box))))
+ (unless (zero? err)
+ (throw 'system-error "add-to-entropy-count" "~A"
+ (list (strerror err))
+ (list err))))))
+
+
+;;;
;;; Containers.
;;;
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 5fe3286843..b8be73ead4 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -1,8 +1,10 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -87,7 +89,13 @@
patch-/usr/bin/file
fold-port-matches
remove-store-references
+ wrapper?
wrap-program
+ wrap-script
+
+ wrap-error?
+ wrap-error-program
+ wrap-error-type
invoke
invoke-error?
@@ -96,10 +104,33 @@
invoke-error-exit-status
invoke-error-term-signal
invoke-error-stop-signal
+ report-invoke-error
+
+ invoke/quiet
locale-category->string))
+
+;;;
+;;; Guile 2.0 compatibility later.
+;;;
+;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.
+(cond-expand
+ ((and guile-2 (not guile-2.2))
+ (define (setvbuf port mode . rest)
+ (apply (@ (guile) setvbuf) port
+ (match mode
+ ('line _IOLBF)
+ ('block _IOFBF)
+ ('none _IONBF)
+ (_ mode)) ;an _IO* integer
+ rest))
+
+ (module-replace! (current-module) '(setvbuf)))
+ (else #f))
+
+
;;;
;;; Directories.
;;;
@@ -600,6 +631,11 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and
((_ phases (add-after old-phase-name new-phase-name new-phase))
(alist-cons-after old-phase-name new-phase-name new-phase phases))))
+
+;;;
+;;; Program invocation.
+;;;
+
(define-condition-type &invoke-error &error
invoke-error?
(program invoke-error-program)
@@ -621,6 +657,68 @@ if the exit code is non-zero; otherwise return #t."
(stop-signal (status:stop-sig code))))))
#t))
+(define* (report-invoke-error c #:optional (port (current-error-port)))
+ "Report to PORT about C, an '&invoke-error' condition, in a human-friendly
+way."
+ (format port "command~{ ~s~} failed with ~:[signal~;status~] ~a~%"
+ (cons (invoke-error-program c)
+ (invoke-error-arguments c))
+ (invoke-error-exit-status c)
+ (or (invoke-error-exit-status c)
+ (invoke-error-term-signal c)
+ (invoke-error-stop-signal c))))
+
+(define (open-pipe-with-stderr program . args)
+ "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
+both its standard output and standard error to the pipe. Return two value:
+the pipe to read PROGRAM's data from, and the PID of the child process running
+PROGRAM."
+ ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
+ ;; we need to roll our own.
+ (match (pipe)
+ ((input . output)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port input)
+ (dup2 (fileno output) 1)
+ (dup2 (fileno output) 2)
+ (apply execlp program program args))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (close-port output)
+ (values input pid))))))
+
+(define (invoke/quiet program . args)
+ "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
+error. If PROGRAM succeeds, print nothing and return the unspecified value;
+otherwise, raise a '&message' error condition that includes the status code
+and the output of PROGRAM."
+ (let-values (((pipe pid)
+ (apply open-pipe-with-stderr program args)))
+ (let loop ((lines '()))
+ (match (read-line pipe)
+ ((? eof-object?)
+ (close-port pipe)
+ (match (waitpid pid)
+ ((_ . status)
+ (unless (zero? status)
+ (let-syntax ((G_ (syntax-rules () ;for xgettext
+ ((_ str) str))))
+ (raise (condition
+ (&message
+ (message (format #f (G_ "'~a~{ ~a~}' exited \
+with status ~a; output follows:~%~%~{ ~a~%~}")
+ program args
+ (or (status:exit-val status)
+ status)
+ (reverse lines)))))))))))
+ (line
+ (loop (cons line lines)))))))
+
;;;
;;; Text substitution (aka. sed).
@@ -987,8 +1085,8 @@ known as `nuke-refs' in Nixpkgs."
;; We cannot use `regexp-exec' here because it cannot deal with
;; strings containing NUL characters.
(format #t "removing store references from `~a'...~%" file)
- (setvbuf in _IOFBF 65536)
- (setvbuf out _IOFBF 65536)
+ (setvbuf in 'block 65536)
+ (setvbuf out 'block 65536)
(fold-port-matches (lambda (match result)
(put-bytevector out (string->utf8 store))
(put-u8 out (char->integer #\/))
@@ -1003,6 +1101,18 @@ known as `nuke-refs' in Nixpkgs."
(put-u8 out (char->integer char))
result))))))
+(define-condition-type &wrap-error &error
+ wrap-error?
+ (program wrap-error-program)
+ (type wrap-error-type))
+
+(define (wrapper? prog)
+ "Return #t if PROG is a wrapper as produced by 'wrap-program'."
+ (and (file-exists? prog)
+ (let ((base (basename prog)))
+ (and (string-prefix? "." base)
+ (string-suffix? "-real" base)))))
+
(define* (wrap-program prog #:rest vars)
"Make a wrapper for PROG. VARS should look like this:
@@ -1100,6 +1210,120 @@ with definitions for VARS."
(chmod prog-tmp #o755)
(rename-file prog-tmp prog))))
+(define wrap-script
+ (let ((interpreter-regex
+ (make-regexp
+ (string-append "^#! ?(/[^ ]+/bin/("
+ (string-join '("python[^ ]*"
+ "Rscript"
+ "perl"
+ "ruby"
+ "bash"
+ "sh") "|")
+ "))( ?.*)")))
+ (coding-line-regex
+ (make-regexp
+ ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)")))
+ (lambda* (prog #:key (guile (which "guile")) #:rest vars)
+ "Wrap the script PROG such that VARS are set first. The format of VARS
+is the same as in the WRAP-PROGRAM procedure. This procedure differs from
+WRAP-PROGRAM in that it does not create a separate shell script. Instead,
+PROG is modified directly by prepending a Guile script, which is interpreted
+as a comment in the script's language.
+
+Special encoding comments as supported by Python are recreated on the second
+line.
+
+Note that this procedure can only be used once per file as Guile scripts are
+not supported."
+ (define update-env
+ (match-lambda
+ ((var sep '= rest)
+ `(setenv ,var ,(string-join rest sep)))
+ ((var sep 'prefix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append ,(string-join rest sep)
+ ,sep current)
+ ,(string-join rest sep)))))
+ ((var sep 'suffix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append current ,sep
+ ,(string-join rest sep))
+ ,(string-join rest sep)))))
+ ((var '= rest)
+ `(setenv ,var ,(string-join rest ":")))
+ ((var 'prefix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append ,(string-join rest ":")
+ ":" current)
+ ,(string-join rest ":")))))
+ ((var 'suffix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append current ":"
+ ,(string-join rest ":"))
+ ,(string-join rest ":")))))))
+ (let-values (((interpreter args coding-line)
+ (call-with-ascii-input-file prog
+ (lambda (p)
+ (let ((first-match
+ (false-if-exception
+ (regexp-exec interpreter-regex (read-line p)))))
+ (values (and first-match (match:substring first-match 1))
+ (and first-match (match:substring first-match 3))
+ (false-if-exception
+ (and=> (regexp-exec coding-line-regex (read-line p))
+ (lambda (m) (match:substring m 0))))))))))
+ (if interpreter
+ (let* ((header (format #f "\
+#!~a --no-auto-compile
+#!#; ~a
+#\\-~s
+#\\-~s
+"
+ guile
+ (or coding-line "Guix wrapper")
+ (cons 'begin (map update-env
+ (match vars
+ ((#:guile _ . vars) vars)
+ (_ vars))))
+ `(let ((cl (command-line)))
+ (apply execl ,interpreter
+ (car cl)
+ (cons (car cl)
+ (append
+ ',(string-split args #\space)
+ cl))))))
+ (template (string-append prog ".XXXXXX"))
+ (out (mkstemp! template))
+ (st (stat prog))
+ (mode (stat:mode st)))
+ (with-throw-handler #t
+ (lambda ()
+ (call-with-ascii-input-file prog
+ (lambda (p)
+ (format out header)
+ (dump-port p out)
+ (close out)
+ (chmod template mode)
+ (rename-file template prog)
+ (set-file-time prog st))))
+ (lambda (key . args)
+ (format (current-error-port)
+ "wrap-script: ~a: error: ~a ~s~%"
+ prog key args)
+ (false-if-exception (delete-file template))
+ (raise (condition
+ (&wrap-error (program prog)
+ (type key))))
+ #f)))
+ (raise (condition
+ (&wrap-error (program prog)
+ (type 'no-interpreter-found)))))))))
+
;;;
;;; Locales.
diff --git a/guix/channels.scm b/guix/channels.scm
index 4e6e7090ac..2c28dccbcb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -27,6 +27,7 @@
#:use-module (guix discovery)
#:use-module (guix monads)
#:use-module (guix profiles)
+ #:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix combinators)
#:use-module (guix diagnostics)
@@ -47,6 +48,7 @@
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
+ #:use-module ((ice-9 rdelim) #:select (read-string))
#:export (channel
channel?
channel-name
@@ -306,6 +308,46 @@ to '%package-module-path'."
(gexp->derivation-in-inferior name build core)))
+(define (syscalls-reexports-local-variables? source)
+ "Return true if (guix build syscalls) contains the bug described at
+<https://bugs.gnu.org/36723>."
+ (catch 'system-error
+ (lambda ()
+ (define content
+ (call-with-input-file (string-append source
+ "/guix/build/syscalls.scm")
+ read-string))
+
+ ;; The faulty code would use the 're-export' macro, causing the
+ ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using
+ ;; Guile > 2.2.4.
+ (string-contains content "(re-export variable)"))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ #f
+ (apply throw args)))))
+
+(define (guile-2.2.4)
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-2.2.4))
+
+(define %quirks
+ ;; List of predicate/package pairs. This allows us provide information
+ ;; about specific Guile versions that old Guix revisions might need to use
+ ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
+ ;; <https://bugs.gnu.org/37506>
+ `((,syscalls-reexports-local-variables? . ,guile-2.2.4)))
+
+(define* (guile-for-source source #:optional (quirks %quirks))
+ "Return the Guile package to use when building SOURCE or #f if the default
+'%guile-for-build' should be good enough."
+ (let loop ((quirks quirks))
+ (match quirks
+ (()
+ #f)
+ (((predicate . guile) rest ...)
+ (if (predicate source) (guile) (loop rest))))))
+
(define* (build-from-source name source
#:key core verbose? commit
(dependencies '()))
@@ -327,15 +369,19 @@ package modules under SOURCE using CORE, an instance of Guix."
;; about it.
(parameterize ((guix-warning-port
(%make-void-port "w")))
- (primitive-load script))))))
+ (primitive-load script)))))
+ (guile (guile-for-source source)))
;; BUILD must be a monadic procedure of at least one argument: the
;; source tree.
;;
;; Note: BUILD can return #f if it does not support %PULL-VERSION. In
;; the future we'll fall back to a previous version of the protocol
;; when that happens.
- (build source #:verbose? verbose? #:version commit
- #:pull-version %pull-version))
+ (mbegin %store-monad
+ (mwhen guile
+ (set-guile-for-build guile))
+ (build source #:verbose? verbose? #:version commit
+ #:pull-version %pull-version)))
;; Build a set of modules that extend Guix using the standard method.
(standard-module-derivation name source core dependencies)))
diff --git a/guix/download.scm b/guix/download.scm
index b24aaa0a86..47c8087732 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -36,6 +36,7 @@
#:use-module (srfi srfi-26)
#:export (%mirrors
url-fetch
+ url-fetch/executable
url-fetch/tarbomb
url-fetch/zipbomb
download-to-store))
@@ -419,8 +420,10 @@
(define* (built-in-download file-name url
#:key system hash-algo hash
mirrors content-addressed-mirrors
+ executable?
(guile 'unused))
- "Download FILE-NAME from URL using the built-in 'download' builder.
+ "Download FILE-NAME from URL using the built-in 'download' builder. When
+EXECUTABLE? is true, make the downloaded file executable.
This is an \"out-of-band\" download in that the returned derivation does not
explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the
@@ -432,6 +435,7 @@ download by itself using its own dependencies."
#:system system
#:hash-algo hash-algo
#:hash hash
+ #:recursive? executable?
#:sources (list mirrors content-addressed-mirrors)
;; Honor the user's proxy and locale settings.
@@ -442,7 +446,10 @@ download by itself using its own dependencies."
#:env-vars `(("url" . ,(object->string url))
("mirrors" . ,mirrors)
("content-addressed-mirrors"
- . ,content-addressed-mirrors))
+ . ,content-addressed-mirrors)
+ ,@(if executable?
+ '(("executable" . "1"))
+ '()))
;; Do not offload this derivation because we cannot be
;; sure that the remote daemon supports the 'download'
@@ -453,11 +460,13 @@ download by itself using its own dependencies."
(define* (url-fetch url hash-algo hash
#:optional name
#:key (system (%current-system))
- (guile (default-guile)))
+ (guile (default-guile))
+ executable?)
"Return a fixed-output derivation that fetches URL (a string, or a list of
strings denoting alternate URLs), which is expected to have hash HASH of type
HASH-ALGO (a symbol). By default, the file name is the base name of URL;
-optionally, NAME can specify a different file name.
+optionally, NAME can specify a different file name. When EXECUTABLE? is true,
+make the downloaded file executable.
When one of the URL starts with mirror://, then its host part is
interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
@@ -488,10 +497,21 @@ in the store."
#:system system
#:hash-algo hash-algo
#:hash hash
+ #:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
%content-addressed-mirror-file)))))
+(define* (url-fetch/executable url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile)))
+ "Like 'url-fetch', but make the downloaded file executable."
+ (url-fetch url hash-algo hash name
+ #:system system
+ #:guile guile
+ #:executable? #t))
+
(define* (url-fetch/tarbomb url hash-algo hash
#:optional name
#:key (system (%current-system))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 26881ce16c..600750e846 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -663,8 +663,7 @@ names and file names suitable for the #:allowed-references argument to
(guile-for-build (%guile-for-build))
(effective-version "2.2")
- deprecation-warnings
- (pre-load-modules? #t)) ;transitional
+ deprecation-warnings)
"*Note: This API is subject to change; use at your own risk!*
Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a
@@ -731,8 +730,6 @@ derivations--e.g., code evaluated for its side effects."
#:module-path module-path
#:extensions extensions
#:guile guile
- #:pre-load-modules?
- pre-load-modules?
#:deprecation-warnings
deprecation-warnings)
(return #f))))
@@ -776,12 +773,6 @@ derivations--e.g., code evaluated for its side effects."
leaked-env-vars
local-build? (substitutable? #t)
(properties '())
-
- ;; TODO: This parameter is transitional; it's here
- ;; to avoid a full rebuild. Remove it on the next
- ;; rebuild cycle.
- (pre-load-modules? #t)
-
deprecation-warnings
(script-name (string-append name "-builder")))
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
@@ -865,9 +856,7 @@ The other arguments are as for 'derivation'."
#:effective-version
effective-version
#:deprecation-warnings
- deprecation-warnings
- #:pre-load-modules?
- pre-load-modules?))
+ deprecation-warnings))
(graphs (if references-graphs
(lower-reference-graphs references-graphs
@@ -1349,11 +1338,7 @@ last one is created from the given <scheme-file> object."
(guile (%guile-for-build))
(module-path %load-path)
(extensions '())
- (deprecation-warnings #f)
-
- ;; TODO: This flag is here to prevent a full
- ;; rebuild. Remove it on the next rebuild cycle.
- (pre-load-modules? #t))
+ (deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other. When TARGET is true, cross-compile MODULES for
@@ -1393,11 +1378,8 @@ TARGET, a GNU triplet."
(let* ((base (basename entry ".scm"))
(output (string-append output "/" base ".go")))
(format #t "[~2@a/~2@a] Compiling '~a'...~%"
- (+ 1 processed
- (ungexp-splicing (if pre-load-modules?
- (gexp ((ungexp total)))
- (gexp ()))))
- (ungexp (* total (if pre-load-modules? 2 1)))
+ (+ 1 processed (ungexp total))
+ (ungexp (* total 2))
entry)
(ungexp-splicing
@@ -1421,6 +1403,26 @@ TARGET, a GNU triplet."
processed
entries)))
+ (define* (load-from-directory directory
+ #:optional (loaded 0))
+ "Load all the source files found in DIRECTORY."
+ ;; XXX: This works around <https://bugs.gnu.org/15602>.
+ (let ((entries (map (cut string-append directory "/" <>)
+ (scandir directory regular?))))
+ (fold (lambda (file loaded)
+ (if (file-is-directory? file)
+ (load-from-directory file loaded)
+ (begin
+ (format #t "[~2@a/~2@a] Loading '~a'...~%"
+ (+ 1 loaded) (ungexp (* 2 total))
+ file)
+ (save-module-excursion
+ (lambda ()
+ (primitive-load file)))
+ (+ 1 loaded))))
+ loaded
+ entries)))
+
(setvbuf (current-output-port)
(cond-expand (guile-2.2 'line) (else _IOLBF)))
@@ -1456,32 +1458,7 @@ TARGET, a GNU triplet."
(mkdir (ungexp output))
(chdir (ungexp modules))
- (ungexp-splicing
- (if pre-load-modules?
- (gexp ((define* (load-from-directory directory
- #:optional (loaded 0))
- "Load all the source files found in DIRECTORY."
- ;; XXX: This works around <https://bugs.gnu.org/15602>.
- (let ((entries (map (cut string-append directory "/" <>)
- (scandir directory regular?))))
- (fold (lambda (file loaded)
- (if (file-is-directory? file)
- (load-from-directory file loaded)
- (begin
- (format #t "[~2@a/~2@a] Loading '~a'...~%"
- (+ 1 loaded)
- (ungexp (* 2 total))
- file)
- (save-module-excursion
- (lambda ()
- (primitive-load file)))
- (+ 1 loaded))))
- loaded
- entries)))
-
- (load-from-directory ".")))
- (gexp ())))
-
+ (load-from-directory ".")
(process-directory "." (ungexp output) 0))))
;; TODO: Pass MODULES as an environment variable.
diff --git a/guix/packages.scm b/guix/packages.scm
index b92ed0ab0c..f2c94c7bc2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -505,11 +506,17 @@ specifies modules in scope when evaluating SNIPPET."
(and=> (file-extension file-name)
(cut string-every char-set:hex-digit <>)))
+ (define (checkout? directory)
+ ;; Return true if DIRECTORY is a checkout (git, svn, etc).
+ (string-suffix? "-checkout" directory))
+
(define (tarxz-name file-name)
;; Return a '.tar.xz' file name based on FILE-NAME.
- (let ((base (if (numeric-extension? file-name)
- original-file-name
- (file-sans-extension file-name))))
+ (let ((base (cond ((numeric-extension? file-name)
+ original-file-name)
+ ((checkout? file-name)
+ (string-drop-right file-name 9))
+ (else (file-sans-extension file-name)))))
(string-append base
(if (equal? (file-extension base) "tar")
".xz"
@@ -642,13 +649,11 @@ specifies modules in scope when evaluating SNIPPET."
(let ((name (tarxz-name original-file-name)))
(gexp->derivation name build
- ;; TODO: Remove this on the next rebuild cycle.
- #:pre-load-modules? #f
-
#:graft? #f
#:system system
- #:deprecation-warnings #t ;to avoid a rebuild
- #:guile-for-build guile-for-build))))
+ #:guile-for-build guile-for-build
+ #:properties `((type . origin)
+ (patches . ,(length patches)))))))
(define (transitive-inputs inputs)
"Return the closure of INPUTS when considering the 'propagated-inputs'
@@ -762,23 +767,29 @@ in INPUTS and their transitive propagated inputs."
(transitive-inputs inputs)))
(define package-transitive-supported-systems
- (mlambdaq (package)
- "Return the intersection of the systems supported by PACKAGE and those
+ (let ()
+ (define supported-systems
+ (mlambda (package system)
+ (parameterize ((%current-system system))
+ (fold (lambda (input systems)
+ (match input
+ ((label (? package? package) . _)
+ (lset-intersection string=? systems
+ (supported-systems package system)))
+ (_
+ systems)))
+ (package-supported-systems package)
+ (bag-direct-inputs (package->bag package))))))
+
+ (lambda* (package #:optional (system (%current-system)))
+ "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
- (fold (lambda (input systems)
- (match input
- ((label (? package? p) . _)
- (lset-intersection
- string=? systems (package-transitive-supported-systems p)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package)))))
+ (supported-systems package system))))
(define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
dependencies are known to build on SYSTEM."
- (member system (package-transitive-supported-systems package)))
+ (member system (package-transitive-supported-systems package system)))
(define (bag-direct-inputs bag)
"Same as 'package-direct-inputs', but applied to a bag."
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 4a51654ce6..d78ca0f303 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -29,7 +29,7 @@
#:use-module (guix search-paths)
#:use-module (guix build utils)
#:use-module (guix monads)
- #:use-module ((guix gexp) #:select (lower-inputs))
+ #:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix scripts)
#:use-module (guix scripts build)
#:use-module (gnu build linux-container)
@@ -40,7 +40,8 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages commencement)
#:use-module (gnu packages guile)
- #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
+ #:use-module ((gnu packages bootstrap)
+ #:select (bootstrap-executable %bootstrap-guile))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
@@ -630,8 +631,7 @@ Otherwise, return the derivation for the Bash package."
(package->derivation bash))
;; Use the bootstrap Bash instead.
((and container? bootstrap?)
- (interned-file
- (search-bootstrap-binary "bash" system)))
+ (lower-object (bootstrap-executable "bash" system)))
(else
(return #f)))))
@@ -764,7 +764,7 @@ message if any test fails."
(container?
(let ((bash-binary
(if bootstrap?
- bash
+ (derivation->output-path bash)
(string-append (derivation->output-path bash)
"/bin/sh"))))
(launch-environment/container #:command command
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 2543f0c0b5..920d6c01fe 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -574,9 +574,9 @@ the image."
"Return the C compiler that uses the bootstrap toolchain. This is used only
by '--bootstrap', for testing purposes."
(define bootstrap-toolchain
- (list (first (assoc-ref %bootstrap-inputs "gcc"))
- (first (assoc-ref %bootstrap-inputs "binutils"))
- (first (assoc-ref %bootstrap-inputs "libc"))))
+ (list (first (assoc-ref (%bootstrap-inputs) "gcc"))
+ (first (assoc-ref (%bootstrap-inputs) "binutils"))
+ (first (assoc-ref (%bootstrap-inputs) "libc"))))
(c-compiler bootstrap-toolchain
#:guile %bootstrap-guile))
diff --git a/guix/self.scm b/guix/self.scm
index 142c834137..207e80d842 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -733,6 +733,7 @@ Info manual."
(filter-map (match-lambda
(('guix 'scripts _ ..1) #f)
(('guix 'man-db) #f)
+ (('guix 'tests _ ...) #f)
(name name))
(scheme-modules* source "guix"))
(list *core-modules*)
diff --git a/guix/tests.scm b/guix/tests.scm
index 66d60e964e..ff31bcad44 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -23,12 +23,18 @@
#:use-module (guix packages)
#:use-module (guix base32)
#:use-module (guix serialization)
+ #:use-module (guix monads)
+ #:use-module ((guix utils) #:select (substitute-keyword-arguments))
+ #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (gcrypt hash)
#:use-module (guix build-system gnu)
+ #:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
#:use-module (ice-9 binary-ports)
#:use-module (web uri)
#:export (open-connection-for-tests
@@ -42,6 +48,8 @@
shebang-too-long?
with-environment-variable
+ search-bootstrap-binary
+
mock
%test-substitute-urls
test-assertm
@@ -50,7 +58,9 @@
with-derivation-narinfo
with-derivation-substitute
dummy-package
- dummy-origin))
+ dummy-origin
+
+ gnu-make-for-tests))
;;; Commentary:
;;;
@@ -83,6 +93,35 @@
store)))
+(define (bootstrap-binary-file program system)
+ "Return the absolute file name where bootstrap binary PROGRAM for SYSTEM is
+stored."
+ (string-append (dirname (search-path %load-path
+ "gnu/packages/bootstrap.scm"))
+ "/bootstrap/" system "/" program))
+
+(define (search-bootstrap-binary file-name system)
+ "Search the bootstrap binary FILE-NAME for SYSTEM. Raise an error if not
+found."
+ ;; Note: Keep bootstrap binaries on the local file system so that the 'guix'
+ ;; package can provide them as inputs and copy them to the right place.
+ (let* ((system (match system
+ ("x86_64-linux" "i686-linux")
+ (_ system)))
+ (file (bootstrap-binary-file file-name system)))
+ (if (file-exists? file)
+ file
+ (with-store store
+ (run-with-store store
+ (mlet %store-monad ((drv (origin->derivation
+ (bootstrap-executable file-name system))))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (begin
+ (mkdir-p (dirname file))
+ (copy-file (derivation->output-path drv) file)
+ (return file)))))))))
+
(define (call-with-external-store proc)
"Call PROC with an open connection to the external store or #f it there is
no external store to talk to."
@@ -364,6 +403,33 @@ default values, and with EXTRA-FIELDS set as specified."
(sha256 (base32 (make-string 52 #\x))))))
(origin (inherit o) extra-fields ...)))
+(define gnu-make-for-tests
+ ;; This is a variant of 'gnu-make-boot0' that can be built with minimal
+ ;; resources.
+ (package-with-bootstrap-guile
+ (package
+ (inherit gnu-make)
+ (name "make-test-boot0")
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+ #:tests? #f ;cannot run "make check"
+ ,@(substitute-keyword-arguments (package-arguments gnu-make)
+ ((#:phases phases)
+ `(modify-phases ,phases
+ (replace 'build
+ (lambda _
+ (invoke "./build.sh")
+ #t))
+ (replace 'install
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (bin (string-append out "/bin")))
+ (install-file "make" bin)
+ #t))))))))
+ (native-inputs '()) ;no need for 'pkg-config'
+ (inputs %bootstrap-inputs-for-tests))))
+
;; Local Variables:
;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
generated by cgit v1.2.3 (git 2.46.2) at 2024-12-29 10:34:07 +0000