diff options
Diffstat (limited to 'guix')
31 files changed, 554 insertions, 330 deletions
diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 6ce813a001..d081a2b313 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -166,12 +166,26 @@ to the default GNU unpack strategy." "/share/java") source-dir test-dir main-class test-include test-exclude)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) - (setenv "CLASSPATH" (generate-classpath inputs))) + (setenv "CLASSPATH" (generate-classpath inputs)) + #t) (define* (build #:key (make-flags '()) (build-target "jar") #:allow-other-keys) (zero? (apply system* `("ant" ,build-target ,@make-flags)))) +(define* (generate-jar-indices #:key outputs #:allow-other-keys) + "Generate file \"META-INF/INDEX.LIST\". This file does not use word wraps +and is preferred over \"META-INF/MAINFEST.MF\", which does use word wraps, +by Java when resolving dependencies. So we make sure to create it so that +grafting works - and so that the garbage collector doesn't collect +dependencies of this jar file." + (define (generate-index jar) + (invoke "jar" "-i" jar)) + (every (match-lambda + ((output . directory) + (every generate-index (find-files directory "\\.jar$")))) + outputs)) + (define* (strip-jar-timestamps #:key outputs #:allow-other-keys) "Unpack all jar archives, reset the timestamp of all contained files, and @@ -228,11 +242,14 @@ repack them. This is necessary to ensure that archives are reproducible." (define %standard-phases (modify-phases gnu:%standard-phases (replace 'unpack unpack) + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) (replace 'install install) - (add-after 'install 'strip-jar-timestamps strip-jar-timestamps))) + (add-after 'install 'generate-jar-indices generate-jar-indices) + (add-after 'generate-jar-indices 'strip-jar-timestamps + strip-jar-timestamps))) (define* (ant-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index c5e820a00a..dd6373b33a 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -220,6 +220,7 @@ valid." (define %standard-phases/source (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'check) (delete 'build) @@ -227,6 +228,7 @@ valid." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'install) (replace 'build build) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 139b40321f..f52444f61c 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -172,6 +172,7 @@ SRC-NAME as if it was part of the directory DIR-NAME with name (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm index c82d9fef87..9b1112f2d6 100644 --- a/guix/build/cmake-build-system.scm +++ b/guix/build/cmake-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> @@ -73,7 +73,7 @@ '()) ,@configure-flags))) (format #t "running 'cmake' with arguments ~s~%" args) - (zero? (apply system* "cmake" args))))) + (apply invoke "cmake" args)))) (define* (check #:key (tests? #t) (parallel-tests? #t) (test-target "test") #:allow-other-keys) @@ -86,6 +86,7 @@ ;; Everything is as with the GNU Build System except for the `configure' ;; and 'check' phases. (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'check check) (replace 'configure configure))) diff --git a/guix/build/cvs.scm b/guix/build/cvs.scm index 9976e624b3..7111043747 100644 --- a/guix/build/cvs.scm +++ b/guix/build/cvs.scm @@ -55,19 +55,20 @@ Return #t on success, #f otherwise." ;; Use "-z0" because enabling compression leads to hangs during checkout on ;; certain repositories, such as ;; ":pserver:anonymous@cvs.savannah.gnu.org:/sources/gnustandards". - (and (zero? (system* cvs-command "-z0" - "-d" cvs-root-directory - "checkout" - (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision) - "-D" "-r") - revision - module)) - ;; Copy rather than rename in case MODULE and DIRECTORY are on - ;; different devices. - (copy-recursively module directory) + (invoke cvs-command "-z0" + "-d" cvs-root-directory + "checkout" + (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision) + "-D" "-r") + revision + module) - (with-directory-excursion directory - (for-each delete-file-recursively (find-cvs-directories))) - #t)) + ;; Copy rather than rename in case MODULE and DIRECTORY are on + ;; different devices. + (copy-recursively module directory) + + (with-directory-excursion directory + (for-each delete-file-recursively (find-cvs-directories))) + #t) ;;; cvs.scm ends here diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm index ed86635708..9a72e3d544 100644 --- a/guix/build/dub-build-system.scm +++ b/guix/build/dub-build-system.scm @@ -121,6 +121,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 094b04750a..47a9eda9e6 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -270,6 +270,7 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (modify-phases gnu:%standard-phases (replace 'unpack unpack) (add-after 'unpack 'set-emacs-load-path set-emacs-load-path) + (delete 'bootstrap) (delete 'configure) ;; Move the build phase after install: the .el files are byte compiled ;; directly in the store. diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index a98e7a6343..fdacd30dd6 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm index f2a646f6f4..6726595fe1 100644 --- a/guix/build/font-build-system.scm +++ b/guix/build/font-build-system.scm @@ -59,6 +59,7 @@ archive, or a font file." (define %standard-phases (modify-phases gnu:%standard-phases (replace 'unpack unpack) + (delete 'bootstrap) (delete 'configure) (delete 'check) (delete 'build) diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index b6291e735b..ba680fd1a9 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -202,16 +203,16 @@ add a dependency of that output on GLib and GTK+." (define* (compile-glib-schemas #:key outputs #:allow-other-keys) "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas if needed." - (every (match-lambda - ((output . directory) - (let ((schemasdir (string-append directory - "/share/glib-2.0/schemas"))) - (if (and (directory-exists? schemasdir) - (not (file-exists? - (string-append schemasdir "/gschemas.compiled")))) - (zero? (system* "glib-compile-schemas" schemasdir)) - #t)))) - outputs)) + (for-each (match-lambda + ((output . directory) + (let ((schemasdir (string-append directory + "/share/glib-2.0/schemas"))) + (when (and (directory-exists? schemasdir) + (not (file-exists? + (string-append schemasdir "/gschemas.compiled")))) + (invoke "glib-compile-schemas" schemasdir))))) + outputs) + #t) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 7b43361f99..be5ad78b93 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,10 +27,13 @@ #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:export (%standard-phases %license-file-regexp + dump-file-contents gnu-build)) ;; Commentary: @@ -83,6 +87,9 @@ See https://reproducible-builds.org/specs/source-date-epoch/." (#f ; not cross compiling '()))) + ;; Tell 'ld-wrapper' to disallow non-store libraries. + (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no") + ;; When cross building, $PATH must refer only to native (host) inputs since ;; target inputs are not executable. (set-path-environment-variable "PATH" '("bin" "sbin") @@ -152,12 +159,50 @@ working directory." ;; Preserve timestamps (set to the Epoch) on the copied tree so that ;; things work deterministically. (copy-recursively source "." - #:keep-mtime? #t) - #t) - (and (if (string-suffix? ".zip" source) - (zero? (system* "unzip" source)) - (zero? (system* "tar" "xvf" source))) - (chdir (first-subdirectory "."))))) + #:keep-mtime? #t)) + (begin + (if (string-suffix? ".zip" source) + (invoke "unzip" source) + (invoke "tar" "xvf" source)) + (chdir (first-subdirectory ".")))) + #t) + +(define %bootstrap-scripts + ;; Typical names of Autotools "bootstrap" scripts. + '("bootstrap" "bootstrap.sh" "autogen.sh")) + +(define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts) + #:allow-other-keys) + "If the code uses Autotools and \"configure\" is missing, run +\"autoreconf\". Otherwise do nothing." + ;; Note: Run that right after 'unpack' so that the generated files are + ;; visible when the 'patch-source-shebangs' phase runs. + (if (not (file-exists? "configure")) + + ;; First try one of the BOOTSTRAP-SCRIPTS. If none exists, and it's + ;; clearly an Autoconf-based project, run 'autoreconf'. Otherwise, do + ;; nothing (perhaps the user removed or overrode the 'configure' phase.) + (let ((script (find file-exists? bootstrap-scripts))) + ;; GNU packages often invoke the 'git-version-gen' script from + ;; 'configure.ac' so make sure it has a valid shebang. + (false-if-file-not-found + (patch-shebang "build-aux/git-version-gen")) + + (if script + (let ((script (string-append "./" script))) + (format #t "running '~a'~%" script) + (if (executable-file? script) + (begin + (patch-shebang script) + (invoke script)) + (invoke "sh" script))) + (if (or (file-exists? "configure.ac") + (file-exists? "configure.in")) + (invoke "autoreconf" "-vif") + (format #t "no 'configure.ac' or anything like that, \ +doing nothing~%")))) + (format #t "GNU build system bootstrapping not needed~%")) + #t) ;; See <http://bugs.gnu.org/17840>. (define* (patch-usr-bin-file #:key native-inputs inputs @@ -184,7 +229,8 @@ $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's (lambda (file stat) ;; Filter out symlinks. (eq? 'regular (stat:type stat))) - #:stat lstat))) + #:stat lstat)) + #t) (define (patch-generated-file-shebangs . rest) "Patch shebangs in generated files, including `SHELL' variables in @@ -199,7 +245,9 @@ makefiles." #:stat lstat)) ;; Patch `SHELL' in generated makefiles. - (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) + (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")) + + #t) (define* (configure #:key build target native-inputs inputs outputs (configure-flags '()) out-of-source? @@ -279,33 +327,61 @@ makefiles." ;; Call `configure' with a relative path. Otherwise, GCC's build system ;; (for instance) records absolute source file names, which typically ;; contain the hash part of the `.drv' file, leading to a reference leak. - (zero? (apply system* bash - (string-append srcdir "/configure") - flags)))) + (apply invoke bash + (string-append srcdir "/configure") + flags))) (define* (build #:key (make-flags '()) (parallel-build? #t) #:allow-other-keys) - (zero? (apply system* "make" - `(,@(if parallel-build? - `("-j" ,(number->string (parallel-job-count))) - '()) - ,@make-flags)))) + (apply invoke "make" + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) + +(define* (dump-file-contents directory file-regexp + #:optional (port (current-error-port))) + "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP." + (define (dump file) + (let ((prefix (string-append "\n--- " file " "))) + (display (if (< (string-length prefix) 78) + (string-pad-right prefix 78 #\-) + prefix) + port) + (display "\n\n" port) + (call-with-input-file file + (lambda (log) + (dump-port log port))) + (display "\n" port))) + + (for-each dump (find-files directory file-regexp))) + +(define %test-suite-log-regexp + ;; Name of test suite log files as commonly found in GNU-based build systems + ;; and CMake. + "^(test-?suite\\.log|LastTestFailed\\.log)$") (define* (check #:key target (make-flags '()) (tests? (not target)) (test-target "check") (parallel-tests? #t) + (test-suite-log-regexp %test-suite-log-regexp) #:allow-other-keys) (if tests? - (zero? (apply system* "make" test-target - `(,@(if parallel-tests? - `("-j" ,(number->string (parallel-job-count))) - '()) - ,@make-flags))) - (begin - (format #t "test suite not run~%") - #t))) + (guard (c ((invoke-error? c) + ;; Dump the test suite log to facilitate debugging. + (display "\nTest suite failed, dumping logs.\n" + (current-error-port)) + (dump-file-contents "." test-suite-log-regexp) + (raise c))) + (apply invoke "make" test-target + `(,@(if parallel-tests? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) + (format #t "test suite not run~%")) + #t) (define* (install #:key (make-flags '()) #:allow-other-keys) - (zero? (apply system* "make" "install" make-flags))) + (apply invoke "make" "install" make-flags)) (define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t) #:allow-other-keys) @@ -371,10 +447,8 @@ makefiles." (let ((debug (debug-file file))) (mkdir-p (dirname debug)) (copy-file file debug) - (and (zero? (system* strip-command "--only-keep-debug" debug)) - (begin - (chmod debug #o400) - #t)))) + (invoke strip-command "--only-keep-debug" debug) + (chmod debug #o400))) (define (add-debug-link file) ;; Add a debug link in FILE (info "(binutils) strip"). @@ -384,10 +458,10 @@ makefiles." ;; `bfd_fill_in_gnu_debuglink_section' function.) No reference to ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug ;; file. - (zero? (system* objcopy-command "--enable-deterministic-archives" - (string-append "--add-gnu-debuglink=" - (debug-file file)) - file))) + (invoke objcopy-command "--enable-deterministic-archives" + (string-append "--add-gnu-debuglink=" + (debug-file file)) + file)) (define (strip-dir dir) (format #t "stripping binaries in ~s with ~s and flags ~s~%" @@ -397,17 +471,29 @@ makefiles." debug-output objcopy-command)) (for-each (lambda (file) - (and (or (elf-file? file) (ar-file? file)) - (or (not debug-output) - (make-debug-file file)) - - ;; Ensure the file is writable. - (begin (make-file-writable file) #t) - - (zero? (apply system* strip-command - (append strip-flags (list file)))) - (or (not debug-output) - (add-debug-link file)))) + (when (or (elf-file? file) (ar-file? file)) + ;; If an error occurs while processing a file, issue a + ;; warning and continue to the next file. + (guard (c ((invoke-error? c) + (format (current-error-port) + "warning: ~a: program ~s exited\ +~@[ with non-zero exit status ~a~]\ +~@[ terminated by signal ~a~]~%" + file + (invoke-error-program c) + (invoke-error-exit-status c) + (invoke-error-term-signal c)))) + (when debug-output + (make-debug-file file)) + + ;; Ensure the file is writable. + (make-file-writable file) + + (apply invoke strip-command + (append strip-flags (list file))) + + (when debug-output + (add-debug-link file))))) (find-files dir (lambda (file stat) ;; Ignore symlinks such as: @@ -415,15 +501,17 @@ makefiles." (eq? 'regular (stat:type stat))) #:stat lstat))) - (or (not strip-binaries?) - (every strip-dir - (append-map (match-lambda - ((_ . dir) - (filter-map (lambda (d) - (let ((sub (string-append dir "/" d))) - (and (directory-exists? sub) sub))) - strip-directories))) - outputs)))) + (when strip-binaries? + (for-each + strip-dir + (append-map (match-lambda + ((_ . dir) + (filter-map (lambda (d) + (let ((sub (string-append dir "/" d))) + (and (directory-exists? sub) sub))) + strip-directories))) + outputs))) + #t) (define* (validate-runpath #:key (validate-runpath? #t) @@ -466,10 +554,11 @@ phase after stripping." (filter-map (sub-directory output) elf-directories))) outputs))) - (every* validate dirs)) - (begin - (format (current-error-port) "skipping RUNPATH validation~%") - #t))) + (unless (every* validate dirs) + (error "RUNPATH validation failed"))) + (format (current-error-port) "skipping RUNPATH validation~%")) + + #t) (define* (validate-documentation-location #:key outputs #:allow-other-keys) @@ -549,47 +638,45 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (apply throw args)))))) (define (maybe-compress-directory directory regexp) - (or (not (directory-exists? directory)) - (match (find-files directory regexp) - (() ;nothing to compress - #t) - ((files ...) ;one or more files - (format #t - "compressing documentation in '~a' with ~s and flags ~s~%" - directory documentation-compressor - documentation-compressor-flags) - (call-with-values - (lambda () - (partition symbolic-link? files)) - (lambda (symlinks regular-files) - ;; Compress the non-symlink files, and adjust symlinks to refer - ;; to the compressed files. Leave files that have hard links - ;; unchanged ('gzip' would refuse to compress them anyway.) - ;; Also, do not retarget symbolic links pointing to other - ;; symbolic links, since these are not compressed. - (and (every retarget-symlink - (filter (lambda (symlink) - (and (not (points-to-symlink? symlink)) - (string-match regexp symlink))) - symlinks)) - (zero? - (apply system* documentation-compressor - (append documentation-compressor-flags - (remove has-links? regular-files))))))))))) + (when (directory-exists? directory) + (match (find-files directory regexp) + (() ;nothing to compress + #t) + ((files ...) ;one or more files + (format #t + "compressing documentation in '~a' with ~s and flags ~s~%" + directory documentation-compressor + documentation-compressor-flags) + (call-with-values + (lambda () + (partition symbolic-link? files)) + (lambda (symlinks regular-files) + ;; Compress the non-symlink files, and adjust symlinks to refer + ;; to the compressed files. Leave files that have hard links + ;; unchanged ('gzip' would refuse to compress them anyway.) + ;; Also, do not retarget symbolic links pointing to other + ;; symbolic links, since these are not compressed. + (for-each retarget-symlink + (filter (lambda (symlink) + (and (not (points-to-symlink? symlink)) + (string-match regexp symlink))) + symlinks)) + (apply invoke documentation-compressor + (append documentation-compressor-flags + (remove has-links? regular-files))))))))) (define (maybe-compress output) - (and (maybe-compress-directory (string-append output "/share/man") - "\\.[0-9]+$") - (maybe-compress-directory (string-append output "/share/info") - "\\.info(-[0-9]+)?$"))) + (maybe-compress-directory (string-append output "/share/man") + "\\.[0-9]+$") + (maybe-compress-directory (string-append output "/share/info") + "\\.info(-[0-9]+)?$")) (if compress-documentation? (match outputs (((names . directories) ...) - (every maybe-compress directories))) - (begin - (format #t "not compressing documentation~%") - #t))) + (for-each maybe-compress directories))) + (format #t "not compressing documentation~%")) + #t) (define* (delete-info-dir-file #:key outputs #:allow-other-keys) "Delete any 'share/info/dir' file from OUTPUTS." @@ -672,6 +759,7 @@ which cannot be found~%" (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack + bootstrap patch-usr-bin-file patch-source-shebangs configure patch-generated-file-shebangs build check install @@ -704,17 +792,26 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." ;; 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)) - - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases)) + (for-each (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)) + + ;; 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/gnu-dist.scm b/guix/build/gnu-dist.scm index ad69c6cf16..bf1c63cb85 100644 --- a/guix/build/gnu-dist.scm +++ b/guix/build/gnu-dist.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,24 +42,22 @@ (begin (format #t "bootstrapping with `~a'...~%" file) - (zero? - (system* (string-append "./" file)))) + (invoke (string-append "./" file))) (try-files files ... (else fallback ...))))))) (try-files "bootstrap" "bootstrap.sh" "autogen" "autogen.sh" (else (format #t "bootstrapping with `autoreconf'...~%") - (zero? (system* "autoreconf" "-vfi")))))) + (invoke "autoreconf" "-vfi"))))) (define* (build #:key build-before-dist? make-flags (dist-target "distcheck") #:allow-other-keys #:rest args) - (and (or (not build-before-dist?) - (let ((build (assq-ref %standard-phases 'build))) - (apply build args))) - (begin - (format #t "building target `~a'~%" dist-target) - (zero? (apply system* "make" dist-target make-flags))))) + (when build-before-dist? + (let ((build (assq-ref %standard-phases 'build))) + (apply build args))) + (format #t "building target `~a'~%" dist-target) + (apply invoke "make" dist-target make-flags)) (define* (install-dist #:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 3114067aa9..7c833a616f 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -261,6 +261,7 @@ files in OUTPUTS." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'patch-generated-file-shebangs) (replace 'unpack unpack) diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm index fed529b193..bb019967e5 100644 --- a/guix/build/gremlin.scm +++ b/guix/build/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,7 +35,7 @@ elf-dynamic-info elf-dynamic-info? - elf-dynamic-info-sopath + elf-dynamic-info-soname elf-dynamic-info-needed elf-dynamic-info-rpath elf-dynamic-info-runpath diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 3afc37e16d..268d59c1be 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -266,6 +266,7 @@ given Haskell package." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (add-before 'configure 'setup-compiler setup-compiler) (add-before 'install 'haddock haddock) (add-after 'install 'register register) diff --git a/guix/build/hg.scm b/guix/build/hg.scm index ae4574de57..ea51eb670b 100644 --- a/guix/build/hg.scm +++ b/guix/build/hg.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,19 +34,20 @@ "Fetch CHANGESET from URL into DIRECTORY. CHANGESET must be a valid Mercurial changeset identifier. Return #t on success, #f otherwise." - (and (zero? (system* hg-command - "clone" url - "--rev" changeset - ;; Disable TLS certificate verification. The hash of - ;; the checkout is known in advance anyway. - "--insecure" - directory)) - (with-directory-excursion directory - (begin - ;; The contents of '.hg' vary as a function of the current - ;; status of the Mercurial repo. Since we want a fixed - ;; output, this directory needs to be taken out. - (delete-file-recursively ".hg") - #t)))) + (invoke hg-command + "clone" url + "--rev" changeset + ;; Disable TLS certificate verification. The hash of + ;; the checkout is known in advance anyway. + "--insecure" + directory) + + ;; The contents of '.hg' vary as a function of the current + ;; status of the Mercurial repo. Since we want a fixed + ;; output, this directory needs to be taken out. + (with-directory-excursion directory + (delete-file-recursively ".hg")) + + #t) ;;; hg.scm ends here diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 3580deda07..563def88e9 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -60,6 +60,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (replace 'build build) (delete 'check) diff --git a/guix/build/ocaml-build-system.scm b/guix/build/ocaml-build-system.scm index f77251ca09..d10431d8ef 100644 --- a/guix/build/ocaml-build-system.scm +++ b/guix/build/ocaml-build-system.scm @@ -103,6 +103,7 @@ ;; Everything is as with the GNU Build System except for the `configure' ;; , `build', `check' and `install' phases. (modify-phases gnu:%standard-phases + (delete 'bootstrap) (add-before 'configure 'ocaml-findlib-environment ocaml-findlib-environment) (add-before 'install 'prepare-install prepare-install) diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm index b2024e4406..c5f5baa3a9 100644 --- a/guix/build/perl-build-system.scm +++ b/guix/build/perl-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,7 +50,7 @@ "INSTALLDIRS=site" "NO_PERLLOCAL=1" ,@make-maker-flags)) (else (error "no Build.PL or Makefile.PL found"))))) (format #t "running `perl' with arguments ~s~%" args) - (zero? (apply system* "perl" args)))) + (apply invoke "perl" args))) (define-syntax-rule (define-w/gnu-fallback* (name args ...) body ...) (define* (name args ... #:rest rest) @@ -58,24 +59,24 @@ (apply (assoc-ref gnu:%standard-phases 'name) rest)))) (define-w/gnu-fallback* (build) - (zero? (system* "./Build"))) + (invoke "./Build")) (define-w/gnu-fallback* (check #:key target (tests? (not target)) (test-flags '()) #:allow-other-keys) (if tests? - (zero? (apply system* "./Build" "test" test-flags)) - (begin - (format #t "test suite not run~%") - #t))) + (apply invoke "./Build" "test" test-flags) + (format #t "test suite not run~%")) + #t) (define-w/gnu-fallback* (install) - (zero? (system* "./Build" "install"))) + (invoke "./Build" "install")) (define %standard-phases ;; Everything is as with the GNU Build System except for the `configure', ;; `build', `check', and `install' phases. (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'install install) (replace 'check check) (replace 'build build) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index dd07986b94..376ea81f1a 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -1,9 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015 Mark H Weaver <mhw@netris.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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,14 +121,15 @@ (format #t "running \"python setup.py\" with command ~s and parameters ~s~%" command params) (if use-setuptools? - (zero? (apply system* "python" "-c" setuptools-shim - command params)) - (zero? (apply system* "python" "./setup.py" command params)))) + (apply invoke "python" "-c" setuptools-shim + command params) + (apply invoke "python" "./setup.py" command params))) (error "no setup.py found"))) (define* (build #:key use-setuptools? #:allow-other-keys) "Build a given Python package." - (call-setuppy "build" '() use-setuptools?)) + (call-setuppy "build" '() use-setuptools?) + #t) (define* (check #:key tests? test-target use-setuptools? #:allow-other-keys) "Run the test suite of a given Python package." @@ -137,15 +139,12 @@ ;; (given with `package_dir`). This will by copied to the output, too, ;; so we need to remove. (let ((before (find-files "build" "\\.egg-info$" #:directories? #t))) - (if (call-setuppy test-target '() use-setuptools?) - (let* ((after (find-files "build" "\\.egg-info$" #:directories? #t)) - (inter (lset-difference eqv? after before))) - (for-each delete-file-recursively inter) - #t) - #f)) - (begin - (format #t "test suite not run~%") - #t))) + (call-setuppy test-target '() use-setuptools?) + (let* ((after (find-files "build" "\\.egg-info$" #:directories? #t)) + (inter (lset-difference string=? after before))) + (for-each delete-file-recursively inter))) + (format #t "test suite not run~%")) + #t) (define (get-python-version python) (let* ((version (last (string-split python #\-))) @@ -182,7 +181,8 @@ when running checks after installing the package." "--root=/") '()) configure-flags))) - (call-setuppy "install" params use-setuptools?))) + (call-setuppy "install" params use-setuptools?) + #t)) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) @@ -211,7 +211,8 @@ when running checks after installing the package." (let ((files (list-of-files dir))) (for-each (cut wrap-program <> var) files))) - bindirs))) + bindirs) + #t)) (define* (rename-pth-file #:key name inputs outputs #:allow-other-keys) "Rename easy-install.pth to NAME.pth to avoid conflicts between packages @@ -243,10 +244,21 @@ installed with setuptools." #t)) #t)) +(define* (enable-bytecode-determinism #:rest _) + "Improve determinism of pyc files." + ;; Set DETERMINISTIC_BUILD to override the embedded mtime in pyc files. + (setenv "DETERMINISTIC_BUILD" "1") + ;; Use deterministic hashes for strings, bytes, and datetime objects. + (setenv "PYTHONHASHSEED" "0") + #t) + (define %standard-phases ;; 'configure' phase is not needed. (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) diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 24aa73d4f2..4d8ac5b479 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:export (%standard-phases r-build)) @@ -34,12 +35,19 @@ ;; Code: (define (invoke-r command params) - (zero? (apply system* "R" "CMD" command params))) + (apply invoke "R" "CMD" command params)) (define (pipe-to-r command params) (let ((port (apply open-pipe* OPEN_WRITE "R" params))) (display command port) - (zero? (status:exit-val (close-pipe port))))) + (let ((code (status:exit-val (close-pipe port)))) + (unless (zero? code) + (raise (condition ((@@ (guix build utils) &invoke-error) + (program "R") + (arguments (string-append params " " command)) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code))))))))) (define (generate-site-path inputs) (string-join (map (match-lambda @@ -68,13 +76,12 @@ (pkg-name (car (scandir libdir (negate (cut member <> '("." "..")))))) (testdir (string-append libdir pkg-name "/" test-target)) (site-path (string-append libdir ":" (generate-site-path inputs)))) - (if (and tests? (file-exists? testdir)) - (begin - (setenv "R_LIBS_SITE" site-path) - (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " - "lib.loc = \"" libdir "\")") - '("--no-save" "--slave"))) - #t))) + (when (and tests? (file-exists? testdir)) + (setenv "R_LIBS_SITE" site-path) + (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\")") + '("--no-save" "--slave"))) + #t)) (define* (install #:key outputs inputs (configure-flags '()) #:allow-other-keys) @@ -99,6 +106,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'build) (delete 'check) ; tests must be run after installation diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 09ae2390a5..abef6937bc 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -308,6 +308,7 @@ extended with definitions for VARS." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (replace 'unpack unpack) (add-before 'build 'extract-gemspec extract-gemspec) diff --git a/guix/build/scons-build-system.scm b/guix/build/scons-build-system.scm index a8760968d8..eb013f03b6 100644 --- a/guix/build/scons-build-system.scm +++ b/guix/build/scons-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,27 +32,27 @@ (define* (build #:key outputs (scons-flags '()) (parallel-build? #t) #:allow-other-keys) (let ((out (assoc-ref outputs "out"))) (mkdir-p out) - (zero? (apply system* "scons" - (append (if parallel-build? - (list "-j" (number->string - (parallel-job-count))) - (list)) - scons-flags))))) + (apply invoke "scons" + (append (if parallel-build? + (list "-j" (number->string + (parallel-job-count))) + (list)) + scons-flags)))) (define* (check #:key tests? test-target (scons-flags '()) #:allow-other-keys) "Run the test suite of a given SCons application." - (cond (tests? - (zero? (apply system* "scons" test-target scons-flags))) - (else - (format #t "test suite not run~%") - #t))) + (if tests? + (apply invoke "scons" test-target scons-flags) + (format #t "test suite not run~%")) + #t) (define* (install #:key outputs (scons-flags '()) #:allow-other-keys) "Install a given SCons application." - (zero? (apply system* "scons" "install" scons-flags))) + (apply invoke "scons" "install" scons-flags)) (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 31c30edaf5..252d1d4ee5 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,23 +35,24 @@ (password #f)) "Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a valid Subversion revision. Return #t on success, #f otherwise." - (and (zero? (apply system* svn-command - "checkout" "--non-interactive" - ;; Trust the server certificate. This is OK as we - ;; verify the checksum later. This can be removed when - ;; ca-certificates package is added. - "--trust-server-cert" "-r" (number->string revision) - `(,@(if (and user-name password) - (list (string-append "--username=" user-name) - (string-append "--password=" password)) - '()) - ,url ,directory))) - (with-directory-excursion directory - (begin - ;; The contents of '.svn' vary as a function of the current status - ;; of the repo. Since we want a fixed output, this directory needs - ;; to be taken out. - (delete-file-recursively ".svn") - #t)))) + (apply invoke svn-command + "checkout" "--non-interactive" + ;; Trust the server certificate. This is OK as we + ;; verify the checksum later. This can be removed when + ;; ca-certificates package is added. + "--trust-server-cert" "-r" (number->string revision) + `(,@(if (and user-name password) + (list (string-append "--username=" user-name) + (string-append "--password=" password)) + '()) + ,url ,directory)) + + ;; The contents of '.svn' vary as a function of the current status + ;; of the repo. Since we want a fixed output, this directory needs + ;; to be taken out. + (with-directory-excursion directory + (delete-file-recursively ".svn")) + + #t) ;;; svn.scm ends here diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index f6b9b96b87..1c393ecd9d 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -34,11 +34,11 @@ ;; Code: (define (compile-with-latex format file) - (zero? (system* format - "-interaction=batchmode" - "-output-directory=build" - (string-append "&" format) - file))) + (invoke format + "-interaction=batchmode" + "-output-directory=build" + (string-append "&" format) + file)) (define* (configure #:key inputs #:allow-other-keys) (let* ((out (string-append (getcwd) "/.texlive-union")) @@ -81,6 +81,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (delete 'check) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index d7ed3d5177..c58a1afd1c 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,8 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-60) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -61,6 +63,7 @@ delete-file-recursively file-name-predicate find-files + false-if-file-not-found search-path-as-list set-path-environment-variable @@ -85,7 +88,14 @@ fold-port-matches remove-store-references wrap-program + invoke + invoke-error? + invoke-error-program + invoke-error-arguments + invoke-error-exit-status + invoke-error-term-signal + invoke-error-stop-signal locale-category->string)) @@ -396,6 +406,15 @@ also be included. If FAIL-ON-ERROR? is true, raise an exception upon error." stat) string<?))) +(define-syntax-rule (false-if-file-not-found exp) + "Evaluate EXP but return #f if it raises to 'system-error with ENOENT." + (catch 'system-error + (lambda () exp) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + ;;; ;;; Search paths. @@ -581,13 +600,25 @@ 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)))) +(define-condition-type &invoke-error &error + invoke-error? + (program invoke-error-program) + (arguments invoke-error-arguments) + (exit-status invoke-error-exit-status) + (term-signal invoke-error-term-signal) + (stop-signal invoke-error-stop-signal)) + (define (invoke program . args) - "Invoke PROGRAM with the given ARGS. Raise an error if the exit -code is non-zero; otherwise return #t." - (let ((status (apply system* program args))) - (unless (zero? status) - (error (format #f "program ~s exited with non-zero code" program) - status)) + "Invoke PROGRAM with the given ARGS. Raise an exception +if the exit code is non-zero; otherwise return #t." + (let ((code (apply system* program args))) + (unless (zero? code) + (raise (condition (&invoke-error + (program program) + (arguments args) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code)))))) #t)) diff --git a/guix/build/waf-build-system.scm b/guix/build/waf-build-system.scm index 85f0abcfd6..f0364e867d 100644 --- a/guix/build/waf-build-system.scm +++ b/guix/build/waf-build-system.scm @@ -70,6 +70,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/download.scm b/guix/download.scm index 5b2c4cd42d..988117885c 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -507,12 +507,14 @@ own. This helper makes it easier to deal with \"tar bombs\"." ;; Use ungrafted tar/gzip so that the resulting tarball doesn't depend on ;; whether grafts are enabled. (gexp->derivation (or name file-name) - #~(begin - (mkdir #$output) - (setenv "PATH" (string-append #$gzip "/bin")) - (chdir #$output) - (zero? (system* (string-append #$tar "/bin/tar") - "xf" #$drv))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir #$output) + (setenv "PATH" (string-append #$gzip "/bin")) + (chdir #$output) + (invoke (string-append #$tar "/bin/tar") + "xf" #$drv))) #:graft? #f #:local-build? #t))) @@ -540,11 +542,13 @@ own. This helper makes it easier to deal with \"zip bombs\"." ;; Use ungrafted unzip so that the resulting tarball doesn't depend on ;; whether grafts are enabled. (gexp->derivation (or name file-name) - #~(begin - (mkdir #$output) - (chdir #$output) - (zero? (system* (string-append #$unzip "/bin/unzip") - #$drv))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir #$output) + (chdir #$output) + (invoke (string-append #$unzip "/bin/unzip") + #$drv))) #:graft? #f #:local-build? #t))) diff --git a/guix/gexp.scm b/guix/gexp.scm index 338c339da9..153b29bd42 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1120,6 +1120,8 @@ last one is created from the given <scheme-file> object." "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." + (define total (length modules)) + (define build-utils-hack? ;; To avoid a full rebuild, we limit the fix below to the case where ;; MODULE-PATH is different from %LOAD-PATH. This happens when building @@ -1141,31 +1143,37 @@ they can refer to each other." (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' (use-modules (ice-9 ftw) + (ice-9 format) + (srfi srfi-1) (srfi srfi-26) (system base compile)) (define (regular? file) (not (member file '("." "..")))) - (define (process-directory directory output) + (define (process-entry entry output processed) + (if (file-is-directory? entry) + (let ((output (string-append output "/" (basename entry)))) + (mkdir-p output) + (process-directory entry output processed)) + (let* ((base (basename entry ".scm")) + (output (string-append output "/" base ".go"))) + (format #t "[~2@a/~2@a] Compiling '~a'...~%" + (+ 1 processed) (ungexp total) entry) + (compile-file entry + #:output-file output + #:opts %auto-compilation-options) + (+ 1 processed)))) + + (define (process-directory directory output processed) (let ((entries (map (cut string-append directory "/" <>) (scandir directory regular?)))) - (for-each (lambda (entry) - (if (file-is-directory? entry) - (let ((output (string-append output "/" - (basename entry)))) - (mkdir-p output) - (process-directory entry output)) - (let* ((base (string-drop-right - (basename entry) - 4)) ;.scm - (output (string-append output "/" base - ".go"))) - (compile-file entry - #:output-file output - #:opts - %auto-compilation-options)))) - entries))) + (fold (cut process-entry <> output <>) + processed + entries))) + + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) (else _IOLBF))) (ungexp-splicing (if build-utils-hack? @@ -1210,7 +1218,7 @@ they can refer to each other." (mkdir (ungexp output)) (chdir (ungexp modules)) - (process-directory "." (ungexp output))))) + (process-directory "." (ungexp output) 0)))) ;; TODO: Pass MODULES as an environment variable. (gexp->derivation name build diff --git a/guix/packages.scm b/guix/packages.scm index e0ab72086c..a6f9936d63 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> @@ -520,9 +520,9 @@ specifies modules in scope when evaluating SNIPPET." ;; Use '--force' so that patches that do not apply perfectly are ;; rejected. Use '--no-backup-if-mismatch' to prevent making ;; "*.orig" file if a patch is applied with offset. - (zero? (system* (string-append #+patch "/bin/patch") - "--force" "--no-backup-if-mismatch" - #+@flags "--input" patch))) + (invoke (string-append #+patch "/bin/patch") + "--force" "--no-backup-if-mismatch" + #+@flags "--input" patch)) (define (first-file directory) ;; Return the name of the first file in DIRECTORY. @@ -547,64 +547,74 @@ specifies modules in scope when evaluating SNIPPET." #+decomp "/bin")) ;; SOURCE may be either a directory or a tarball. - (and (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory) - #t) - #+(if (string=? decompression-type "unzip") - #~(zero? (system* "unzip" #+source)) - #~(zero? (system* (string-append #+tar "/bin/tar") - "xvf" #+source)))) - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) - - (and (every apply-patch '#+patches) - #+@(if snippet - #~((let ((module (make-fresh-user-module))) - (module-use-interfaces! - module - (map resolve-interface '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module))) - #~()) - - (begin (chdir "..") #t) - - (unless tar-supports-sort? - (call-with-output-file ".file_list" - (lambda (port) - (for-each (lambda (name) - (format port "~a~%" name)) - (find-files directory - #:directories? #t - #:fail-on-error? #t))))) - (zero? (apply system* - (string-append #+tar "/bin/tar") - "cvf" #$output - ;; The bootstrap xz does not support - ;; threaded compression (introduced in - ;; 5.2.0), but it ignores the extra flag. - (string-append "--use-compress-program=" - #+xz "/bin/xz --threads=0") - ;; avoid non-determinism in the archive - "--mtime=@0" - "--owner=root:0" - "--group=root:0" - (if tar-supports-sort? - `("--sort=name" - ,directory) - '("--no-recursion" - "--files-from=.file_list")))))))))) + (if (file-is-directory? #+source) + (let* ((store (%store-directory)) + (len (+ 1 (string-length store))) + (base (string-drop #+source len)) + (dash (string-index base #\-)) + (directory (string-drop base (+ 1 dash)))) + (mkdir directory) + (copy-recursively #+source directory)) + #+(if (string=? decompression-type "unzip") + #~(invoke "unzip" #+source) + #~(invoke (string-append #+tar "/bin/tar") + "xvf" #+source))) + + (let ((directory (first-file "."))) + (format (current-error-port) + "source is under '~a'~%" directory) + (chdir directory) + + (for-each apply-patch '#+patches) + + (let ((result #+(if snippet + #~(let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+snippet + #:to 'value + #:opts %auto-compilation-options + #:env module)) + #~#t))) + ;; Issue a warning unless the result is #t. + (unless (eqv? result #t) + (format (current-error-port) "\ +## WARNING: the snippet returned `~s'. Return values other than #t +## are deprecated. Please migrate this package so that its snippet +## reports errors by raising an exception, and otherwise returns #t.~%" + result)) + (unless result + (error "snippet returned false"))) + + (chdir "..") + + (unless tar-supports-sort? + (call-with-output-file ".file_list" + (lambda (port) + (for-each (lambda (name) + (format port "~a~%" name)) + (find-files directory + #:directories? #t + #:fail-on-error? #t))))) + (apply invoke + (string-append #+tar "/bin/tar") + "cvf" #$output + ;; The bootstrap xz does not support + ;; threaded compression (introduced in + ;; 5.2.0), but it ignores the extra flag. + (string-append "--use-compress-program=" + #+xz "/bin/xz --threads=0") + ;; avoid non-determinism in the archive + "--mtime=@0" + "--owner=root:0" + "--group=root:0" + (if tar-supports-sort? + `("--sort=name" + ,directory) + '("--no-recursion" + "--files-from=.file_list"))))))) (let ((name (tarxz-name original-file-name))) (gexp->derivation name build diff --git a/guix/ui.scm b/guix/ui.scm index 8d351607d8..45f438fc45 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com> @@ -41,6 +41,12 @@ #:use-module ((guix licenses) #:select (license? license-name)) #:use-module ((guix build syscalls) #:select (free-disk-space terminal-columns)) + #:use-module ((guix build utils) + #:select (invoke-error? invoke-error-program + invoke-error-arguments + invoke-error-exit-status + invoke-error-term-signal + invoke-error-stop-signal)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -670,6 +676,16 @@ or remove one of them from the profile.") directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) + ((invoke-error? c) + (leave (G_ "program exited\ +~@[ with non-zero exit status ~a~]\ +~@[ terminated by signal ~a~]\ +~@[ stopped by signal ~a~]: ~s~%") + (invoke-error-exit-status c) + (invoke-error-term-signal c) + (invoke-error-stop-signal c) + (cons (invoke-error-program c) + (invoke-error-arguments c)))) ((and (error-location? c) (message-condition? c)) (format (current-error-port) (G_ "~a: error: ~a~%") |