summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cargo.scm2
-rw-r--r--guix/build-system/gnu.scm18
-rw-r--r--guix/build-system/meson.scm2
-rw-r--r--guix/build-system/python.scm8
-rw-r--r--guix/build-system/texlive.scm10
-rw-r--r--guix/build/copy-build-system.scm2
-rw-r--r--guix/build/emacs-build-system.scm16
-rw-r--r--guix/build/gnu-build-system.scm218
-rw-r--r--guix/build/gremlin.scm117
-rw-r--r--guix/build/lisp-utils.scm2
-rw-r--r--guix/build/maven/pom.scm2
-rw-r--r--guix/build/meson-build-system.scm2
-rw-r--r--guix/build/minify-build-system.scm11
-rw-r--r--guix/build/python-build-system.scm128
-rw-r--r--guix/build/rpath.scm59
-rw-r--r--guix/build/ruby-build-system.scm25
-rw-r--r--guix/build/texlive-build-system.scm42
-rw-r--r--guix/build/utils.scm187
-rw-r--r--guix/gexp.scm29
-rw-r--r--guix/packages.scm218
-rw-r--r--guix/profiles.scm48
-rw-r--r--guix/scripts/pack.scm27
-rw-r--r--guix/store/roots.scm2
-rw-r--r--guix/tests.scm43
-rw-r--r--guix/utils.scm43
25 files changed, 779 insertions, 482 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index 6c8edf6bac..ed69746a3b 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -217,7 +217,7 @@ any dependent crates. This can be a benefits:
- It avoids waiting for quadratic builds from source: cargo always builds
dependencies within the current workspace. This is largely due to Rust not
having a stable ABI and other resolutions that cargo applies. This means that
- if we have a depencency chain of X -> Y -> Z and we build each definition
+ if we have a dependency chain of X -> Y -> Z and we build each definition
independently the following will happen:
* Cargo will build and test crate Z
* Cargo will build crate Z in Y's workspace, then build and test Y
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 6b481ad45c..abff7d6998 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -215,7 +215,7 @@ use `--strip-all' as the arguments to `strip'."
(arguments
(let ((a (default-keyword-arguments (package-arguments p)
'(#:configure-flags '()
- #:strip-flags '("--strip-debug")))))
+ #:strip-flags '("--strip-unneeded")))))
(substitute-keyword-arguments a
((#:configure-flags flags)
`(cons* "--disable-shared" "LDFLAGS=-static" ,flags))
@@ -324,10 +324,15 @@ standard packages used as implicit inputs of the GNU build system."
;; Regexp matching license files.
"^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")
+(define %bootstrap-scripts
+ ;; Typical names of Autotools "bootstrap" scripts.
+ '("bootstrap" "bootstrap.sh" "autogen.sh"))
+
(define* (gnu-build store name input-drvs
#:key (guile #f)
(outputs '("out"))
(search-paths '())
+ (bootstrap-scripts (list 'quote %bootstrap-scripts))
(configure-flags ''())
(make-flags ''())
(out-of-source? #f)
@@ -337,11 +342,12 @@ standard packages used as implicit inputs of the GNU build system."
(parallel-tests? #t)
(patch-shebangs? #t)
(strip-binaries? #t)
- (strip-flags ''("--strip-debug"
+ (strip-flags ''("--strip-unneeded"
"--enable-deterministic-archives"))
(strip-directories ''("lib" "lib64" "libexec"
"bin" "sbin"))
(validate-runpath? #t)
+ (make-dynamic-linker-cache? #t)
(license-file-regexp %license-file-regexp)
(phases '%standard-phases)
(locale "en_US.utf8")
@@ -400,6 +406,7 @@ packages that must not be referenced."
search-paths)
#:phases ,phases
#:locale ,locale
+ #:bootstrap-scripts ,bootstrap-scripts
#:configure-flags ,configure-flags
#:make-flags ,make-flags
#:out-of-source? ,out-of-source?
@@ -410,6 +417,7 @@ packages that must not be referenced."
#:patch-shebangs? ,patch-shebangs?
#:strip-binaries? ,strip-binaries?
#:validate-runpath? ,validate-runpath?
+ #:make-dynamic-linker-cache? ,make-dynamic-linker-cache?
#:license-file-regexp ,license-file-regexp
#:strip-flags ,strip-flags
#:strip-directories ,strip-directories)))
@@ -484,6 +492,7 @@ is one of `host' or `target'."
(search-paths '())
(native-search-paths '())
+ (bootstrap-scripts (list 'quote %bootstrap-scripts))
(configure-flags ''())
(make-flags ''())
(out-of-source? #f)
@@ -492,11 +501,12 @@ is one of `host' or `target'."
(parallel-build? #t) (parallel-tests? #t)
(patch-shebangs? #t)
(strip-binaries? #t)
- (strip-flags ''("--strip-debug"
+ (strip-flags ''("--strip-unneeded"
"--enable-deterministic-archives"))
(strip-directories ''("lib" "lib64" "libexec"
"bin" "sbin"))
(validate-runpath? #t)
+ (make-dynamic-linker-cache? #t)
(license-file-regexp %license-file-regexp)
(phases '%standard-phases)
(locale "en_US.utf8")
@@ -567,6 +577,7 @@ platform."
native-search-paths)
#:phases ,phases
#:locale ,locale
+ #:bootstrap-scripts ,bootstrap-scripts
#:configure-flags ,configure-flags
#:make-flags ,make-flags
#:out-of-source? ,out-of-source?
@@ -577,6 +588,7 @@ platform."
#:patch-shebangs? ,patch-shebangs?
#:strip-binaries? ,strip-binaries?
#:validate-runpath? ,validate-runpath?
+ #:make-dynamic-linker-cache? ,make-dynamic-linker-cache?
#:license-file-regexp ,license-file-regexp
#:strip-flags ,strip-flags
#:strip-directories ,strip-directories))))
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index b68bcb80de..e04223381e 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -55,7 +55,7 @@
"Return the default meson package."
;; Lazily resolve the binding to avoid a circular dependency.
(let ((module (resolve-interface '(gnu packages build-tools))))
- (module-ref module 'meson-for-build)))
+ (module-ref module 'meson)))
(define* (lower name
#:key source inputs native-inputs outputs system target
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index e39c06528e..2bb6fa87ca 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +20,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build-system python)
+ #:use-module ((gnu packages) #:select (search-auxiliary-file))
+ #:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix memoization)
@@ -70,6 +73,10 @@ extension, such as '.tar.gz'."
(let ((python (resolve-interface '(gnu packages python))))
(module-ref python 'python-2)))
+(define sanity-check.py
+ ;; The script used to validate the installation of a Python package.
+ (search-auxiliary-file "python/sanity-check.py"))
+
(define* (package-with-explicit-python python old-prefix new-prefix
#:key variant-property)
"Return a procedure of one argument, P. The procedure creates a package with
@@ -156,6 +163,7 @@ pre-defined variants."
;; Keep the standard inputs of 'gnu-build-system'.
,@(standard-packages)))
(build-inputs `(("python" ,python)
+ ("sanity-check.py" ,(local-file sanity-check.py))
,@native-inputs))
(outputs outputs)
(build python-build)
diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm
index 8bbca0ccb7..a8545757be 100644
--- a/guix/build-system/texlive.scm
+++ b/guix/build-system/texlive.scm
@@ -59,13 +59,17 @@ name for the checkout directory."
(file-name (string-append name "-" version "-checkout"))
(sha256 hash)))
-(define (texlive-ref component id)
+(define* (texlive-ref component #:optional id)
"Return a <svn-reference> object for the package ID, which is part of the
-given Texlive COMPONENT."
+given Texlive COMPONENT. If ID is not provided, COMPONENT is used as the top
+level package ID."
(svn-reference
(url (string-append "svn://www.tug.org/texlive/tags/"
%texlive-tag "/Master/texmf-dist/"
- "source/" component "/" id))
+ "source/" component
+ (if id
+ (string-append "/" id)
+ "")))
(revision %texlive-revision)))
(define %texlive-build-system-modules
diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm
index a86f0cde29..ac4a62a074 100644
--- a/guix/build/copy-build-system.scm
+++ b/guix/build/copy-build-system.scm
@@ -58,7 +58,7 @@ In the above, FILTERS are optional.
one of the elements in the list.
- With `#:include-regexp`, install subpaths matching the regexps in the list.
- The `#:exclude*` FILTERS work similarly. Without `#:include*` flags,
- install every subpath but the files matching the `#:exlude*` filters.
+ install every subpath but the files matching the `#:exclude*` filters.
If both `#:include*` and `#:exclude*` are specified, the exclusion is done
on the inclusion list.
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 26ea59bc25..79a1a42c4a 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -105,23 +105,9 @@ environment variable\n" source-directory)))
"Substitute the absolute \"/bin/\" directory with the right location in the
store in '.el' files."
- (define (file-contains-nul-char? file)
- (call-with-input-file file
- (lambda (in)
- (let loop ((line (read-line in 'concat)))
- (cond
- ((eof-object? line) #f)
- ((string-index line #\nul) #t)
- (else (loop (read-line in 'concat))))))
- #:binary #t))
-
(let* ((out (assoc-ref outputs "out"))
(site-lisp (string-append out %install-dir))
- ;; (ice-9 regex) uses libc's regexp routines, which cannot deal with
- ;; strings containing NULs. Filter out such files. TODO: Remove
- ;; this workaround when <https://bugs.gnu.org/30116> is fixed.
- (el-files (remove file-contains-nul-char?
- (find-files (getcwd) "\\.el$"))))
+ (el-files (find-files (getcwd) "\\.el$")))
(define (substitute-program-names)
(substitute* el-files
(("\"/bin/([^.]\\S*)\"" _ cmd-name)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 2e7dff2034..66edd2de2d 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,7 +1,8 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -57,23 +58,26 @@
"Set the 'SOURCE_DATE_EPOCH' environment variable. This is used by tools
that incorporate timestamps as a way to tell them to use a fixed timestamp.
See https://reproducible-builds.org/specs/source-date-epoch/."
- (setenv "SOURCE_DATE_EPOCH" "1")
- #t)
+ (setenv "SOURCE_DATE_EPOCH" "1"))
(define (first-subdirectory directory)
- "Return the file name of the first sub-directory of DIRECTORY."
+ "Return the file name of the first sub-directory of DIRECTORY or false, when
+there are none."
(match (scandir directory
(lambda (file)
(and (not (member file '("." "..")))
(file-is-directory? (string-append directory "/"
file)))))
- ((first . _) first)))
+ ((first . _) first)
+ (_ #f)))
(define* (set-paths #:key target inputs native-inputs
(search-paths '()) (native-search-paths '())
#:allow-other-keys)
(define input-directories
- (match inputs
+ ;; The "source" input can be a directory, but we don't want it for search
+ ;; paths. See <https://issues.guix.gnu.org/44924>.
+ (match (alist-delete "source" inputs)
(((_ . dir) ...)
dir)))
@@ -113,9 +117,7 @@ See https://reproducible-builds.org/specs/source-date-epoch/."
#:separator separator
#:type type
#:pattern pattern)))
- native-search-paths))
-
- #t)
+ native-search-paths)))
(define* (install-locale #:key
(locale "en_US.utf8")
@@ -134,15 +136,13 @@ chance to be set."
(setenv (locale-category->string locale-category) locale)
(format (current-error-port) "using '~a' locale for category ~s~%"
- locale (locale-category->string locale-category))
- #t)
+ locale (locale-category->string locale-category)))
(lambda args
;; This is known to fail for instance in early bootstrap where locales
;; are not available.
(format (current-error-port)
"warning: failed to install '~a' locale: ~a~%"
- locale (strerror (system-error-errno args)))
- #t)))
+ locale (strerror (system-error-errno args))))))
(define* (unpack #:key source #:allow-other-keys)
"Unpack SOURCE in the working directory, and change directory within the
@@ -158,17 +158,21 @@ working directory."
(copy-recursively source "."
#: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)
+ (cond
+ ((string-suffix? ".zip" source)
+ (invoke "unzip" source))
+ ((tarball? source)
+ (invoke "tar" "xvf" source))
+ (else
+ (let ((name (strip-store-file-name source))
+ (command (compressor source)))
+ (copy-file source name)
+ (when command
+ (invoke command "--decompress" name)))))
+ ;; Attempt to change into child directory.
+ (and=> (first-subdirectory ".") chdir))))
+
+(define* (bootstrap #:key bootstrap-scripts
#:allow-other-keys)
"If the code uses Autotools and \"configure\" is missing, run
\"autoreconf\". Otherwise do nothing."
@@ -205,8 +209,7 @@ working directory."
(invoke "autoreconf" "-vif")
(format #t "no 'configure.ac' or anything like that, \
doing nothing~%"))))
- (format #t "GNU build system bootstrapping not needed~%"))
- #t)
+ (format #t "GNU build system bootstrapping not needed~%")))
;; See <http://bugs.gnu.org/17840>.
(define* (patch-usr-bin-file #:key native-inputs inputs
@@ -220,8 +223,7 @@ things like the ABI being used."
(for-each (lambda (file)
(when (executable-file? file)
(patch-/usr/bin/file file)))
- (find-files "." "^configure$")))
- #t)
+ (find-files "." "^configure$"))))
(define* (patch-source-shebangs #:key source #:allow-other-keys)
"Patch shebangs in all source files; this includes non-executable
@@ -233,8 +235,7 @@ $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))
- #t)
+ #:stat lstat)))
(define (patch-generated-file-shebangs . rest)
"Patch shebangs in generated files, including `SHELL' variables in
@@ -249,9 +250,7 @@ makefiles."
#:stat lstat))
;; Patch `SHELL' in generated makefiles.
- (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))
-
- #t)
+ (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
(define* (configure #:key build target native-inputs inputs outputs
(configure-flags '()) out-of-source?
@@ -381,8 +380,7 @@ makefiles."
`("-j" ,(number->string (parallel-job-count)))
'())
,@make-flags)))
- (format #t "test suite not run~%"))
- #t)
+ (format #t "test suite not run~%")))
(define* (install #:key (make-flags '()) #:allow-other-keys)
(apply invoke "make" "install" make-flags))
@@ -415,8 +413,7 @@ makefiles."
(for-each (lambda (dir)
(let ((files (list-of-files dir)))
(for-each (cut patch-shebang <> path) files)))
- output-bindirs)))
- #t)
+ output-bindirs))))
(define* (strip #:key target outputs (strip-binaries? #t)
(strip-command (if target
@@ -425,7 +422,7 @@ makefiles."
(objcopy-command (if target
(string-append target "-objcopy")
"objcopy"))
- (strip-flags '("--strip-debug"
+ (strip-flags '("--strip-unneeded"
"--enable-deterministic-archives"))
(strip-directories '("lib" "lib64" "libexec"
"bin" "sbin"))
@@ -514,8 +511,7 @@ makefiles."
(let ((sub (string-append dir "/" d)))
(and (directory-exists? sub) sub)))
strip-directories)))
- outputs)))
- #t)
+ outputs))))
(define* (validate-runpath #:key
(validate-runpath? #t)
@@ -560,9 +556,7 @@ phase after stripping."
outputs)))
(unless (every* validate dirs)
(error "RUNPATH validation failed")))
- (format (current-error-port) "skipping RUNPATH validation~%"))
-
- #t)
+ (format (current-error-port) "skipping RUNPATH validation~%")))
(define* (validate-documentation-location #:key outputs
#:allow-other-keys)
@@ -582,8 +576,7 @@ and 'man/'. This phase moves directories to the right place if needed."
(match outputs
(((names . directories) ...)
- (for-each validate-output directories)))
- #t)
+ (for-each validate-output directories))))
(define* (reset-gzip-timestamps #:key outputs #:allow-other-keys)
"Reset embedded timestamps in gzip files found in OUTPUTS."
@@ -599,8 +592,7 @@ and 'man/'. This phase moves directories to the right place if needed."
(match outputs
(((names . directories) ...)
- (for-each process-directory directories)))
- #t)
+ (for-each process-directory directories))))
(define* (compress-documentation #:key outputs
(compress-documentation? #t)
@@ -616,7 +608,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
(let ((target (readlink link)))
(delete-file link)
(symlink (string-append target compressed-documentation-extension)
- link)))
+ (string-append link compressed-documentation-extension))))
(define (has-links? file)
;; Return #t if FILE has hard links.
@@ -679,8 +671,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
(match outputs
(((names . directories) ...)
(for-each maybe-compress directories)))
- (format #t "not compressing documentation~%"))
- #t)
+ (format #t "not compressing documentation~%")))
(define* (delete-info-dir-file #:key outputs #:allow-other-keys)
"Delete any 'share/info/dir' file from OUTPUTS."
@@ -689,8 +680,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
(let ((info-dir-file (string-append directory "/share/info/dir")))
(when (file-exists? info-dir-file)
(delete-file info-dir-file)))))
- outputs)
- #t)
+ outputs))
(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
@@ -730,8 +720,74 @@ which cannot be found~%"
(("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
(string-append "TryExec="
(which binary) rest)))))))))
- outputs)
- #t)
+ outputs))
+
+(define* (make-dynamic-linker-cache #:key outputs
+ (make-dynamic-linker-cache? #t)
+ #:allow-other-keys)
+ "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the
+OUTPUTS. This reduces application startup time by avoiding the 'stat' storm
+that traversing all the RUNPATH entries entails."
+ (define (make-cache-for-output directory)
+ (define bin-directories
+ (filter-map (lambda (sub-directory)
+ (let ((directory (string-append directory "/"
+ sub-directory)))
+ (and (directory-exists? directory)
+ directory)))
+ '("bin" "sbin" "libexec")))
+
+ (define programs
+ ;; Programs that can benefit from the ld.so cache.
+ (append-map (lambda (directory)
+ (if (directory-exists? directory)
+ (find-files directory
+ (lambda (file stat)
+ (and (executable-file? file)
+ (elf-file? file))))
+ '()))
+ bin-directories))
+
+ (define library-path
+ ;; Directories containing libraries that PROGRAMS depend on,
+ ;; recursively.
+ (delete-duplicates
+ (append-map (lambda (program)
+ (map dirname (file-needed/recursive program)))
+ programs)))
+
+ (define cache-file
+ (string-append directory "/etc/ld.so.cache"))
+
+ (define ld.so.conf
+ (string-append (or (getenv "TMPDIR") "/tmp")
+ "/ld.so.conf"))
+
+ (unless (null? library-path)
+ (mkdir-p (dirname cache-file))
+ (guard (c ((invoke-error? c)
+ ;; Do not treat 'ldconfig' failure as an error.
+ (format (current-error-port)
+ "warning: 'ldconfig' failed:~%")
+ (report-invoke-error c (current-error-port))))
+ ;; Create a config file to tell 'ldconfig' where to look for the
+ ;; libraries that PROGRAMS need.
+ (call-with-output-file ld.so.conf
+ (lambda (port)
+ (for-each (lambda (directory)
+ (display directory port)
+ (newline port))
+ library-path)))
+
+ (invoke "ldconfig" "-f" ld.so.conf "-C" cache-file)
+ (format #t "created '~a' from ~a library search path entries~%"
+ cache-file (length library-path)))))
+
+ (if make-dynamic-linker-cache?
+ (match outputs
+ (((_ . directories) ...)
+ (for-each make-cache-for-output directories)))
+ (format #t "ld.so cache not built~%")))
(define %license-file-regexp
;; Regexp matching license files.
@@ -796,8 +852,7 @@ which cannot be found~%"
package))
(map (cut string-append source "/" <>) files)))
(format (current-error-port)
- "failed to find license files~%"))
- #t))
+ "failed to find license files~%"))))
(define %standard-phases
;; Standard build phases, as a list of symbol/procedure pairs.
@@ -813,6 +868,7 @@ which cannot be found~%"
validate-documentation-location
delete-info-dir-file
patch-dot-desktop-files
+ make-dynamic-linker-cache
install-license-files
reset-gzip-timestamps
compress-documentation)))
@@ -840,26 +896,30 @@ in order. Return #t if all the PHASES succeeded, #f otherwise."
(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))
-
- ;; 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)))
+ (define (end-of-phase success?)
+ (let ((end (current-time time-monotonic)))
+ (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
+ name success?
+ (elapsed-time end start))
+
+ ;; Dump the environment variables as a shell script,
+ ;; for handy debugging.
+ (system "export > $NIX_BUILD_TOP/environment-variables")))
+
+ (format #t "starting phase `~a'~%" name)
+ (with-throw-handler #t
+ (lambda ()
+ (apply proc args)
+ (end-of-phase #t))
+ (lambda args
+ ;; This handler executes before the stack is unwound.
+ ;; The exception is automatically re-thrown from here,
+ ;; and we should get a proper backtrace.
+ (format (current-error-port)
+ "error: in phase '~a': uncaught exception:
+~{~s ~}~%" name args)
+ (end-of-phase #f))))))
+ phases)))
diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index e8ea66dfb3..a2d2169ddc 100644
--- a/guix/build/gremlin.scm
+++ b/guix/build/gremlin.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -41,6 +41,17 @@
elf-dynamic-info-runpath
expand-origin
+ file-dynamic-info
+ file-runpath
+ file-needed
+ file-needed/recursive
+
+ missing-runpath-error?
+ missing-runpath-error-file
+ runpath-too-long-error?
+ runpath-too-long-error-file
+ set-file-runpath
+
validate-needed-in-runpath
strip-runpath))
@@ -232,6 +243,63 @@ string table if the type is a string."
dynamic-entry-value))
'()))))))
+(define (file-dynamic-info file)
+ "Return the <elf-dynamic-info> record of FILE, or #f if FILE lacks dynamic
+info."
+ (call-with-input-file file
+ (lambda (port)
+ (elf-dynamic-info (parse-elf (get-bytevector-all port))))))
+
+(define (file-runpath file)
+ "Return the DT_RUNPATH dynamic entry of FILE as a list of strings, or #f if
+FILE lacks dynamic info."
+ (and=> (file-dynamic-info file) elf-dynamic-info-runpath))
+
+(define (file-needed file)
+ "Return the list of DT_NEEDED dynamic entries of FILE, or #f if FILE lacks
+dynamic info."
+ (and=> (file-dynamic-info file) elf-dynamic-info-needed))
+
+(define (file-needed/recursive file)
+ "Return two values: the list of absolute .so file names FILE depends on,
+recursively, and the list of .so file names that could not be found. File
+names are resolved by searching the RUNPATH of the file that NEEDs them.
+
+This is similar to the info returned by the 'ldd' command."
+ (let loop ((files (list file))
+ (result '())
+ (not-found '()))
+ (match files
+ (()
+ (values (reverse result)
+ (reverse (delete-duplicates not-found))))
+ ((file . rest)
+ (match (file-dynamic-info file)
+ (#f
+ (loop rest result not-found))
+ (info
+ (let ((runpath (elf-dynamic-info-runpath info))
+ (needed (elf-dynamic-info-needed info)))
+ (if (and runpath needed)
+ (let* ((runpath (map (cute expand-origin <> (dirname file))
+ runpath))
+ (resolved (map (cut search-path runpath <>)
+ needed))
+ (failed (filter-map (lambda (needed resolved)
+ (and (not resolved)
+ (not (libc-library? needed))
+ needed))
+ needed resolved))
+ (needed (remove (lambda (value)
+ (or (not value)
+ ;; XXX: quadratic
+ (member value result)))
+ resolved)))
+ (loop (append rest needed)
+ (append needed result)
+ (append failed not-found)))
+ (loop rest result not-found)))))))))
+
(define %libc-libraries
;; List of libraries as of glibc 2.21 (there are more but those are
;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.)
@@ -364,4 +432,49 @@ according to DT_NEEDED."
(false-if-exception (close-port port))
(apply throw key args))))
-;;; gremlin.scm ends here
+
+(define-condition-type &missing-runpath-error &elf-error
+ missing-runpath-error?
+ (file missing-runpath-error-file))
+
+(define-condition-type &runpath-too-long-error &elf-error
+ runpath-too-long-error?
+ (file runpath-too-long-error-file))
+
+(define (set-file-runpath file path)
+ "Set the value of the DT_RUNPATH dynamic entry of FILE, which must name an
+ELF file, to PATH, a list of strings. Raise a &missing-runpath-error or
+&runpath-too-long-error when appropriate."
+ (define (call-with-input+output-file file proc)
+ (let ((port (open-file file "r+b")))
+ (guard (c (#t (close-port port) (raise c)))
+ (proc port)
+ (close-port port))))
+
+ (call-with-input+output-file file
+ (lambda (port)
+ (let* ((elf (parse-elf (get-bytevector-all port)))
+ (entries (dynamic-entries elf (dynamic-link-segment elf)))
+ (runpath (find (lambda (entry)
+ (= DT_RUNPATH (dynamic-entry-type entry)))
+ entries))
+ (path (string->utf8 (string-join path ":"))))
+ (unless runpath
+ (raise (condition (&missing-runpath-error (elf elf)
+ (file file)))))
+
+ ;; There might be padding left beyond RUNPATH in the string table, but
+ ;; we don't know, so assume there's no padding.
+ (unless (<= (bytevector-length path)
+ (bytevector-length
+ (string->utf8 (dynamic-entry-value runpath))))
+ (raise (condition (&runpath-too-long-error (elf #f #;elf)
+ (file file)))))
+
+ (seek port (dynamic-entry-offset runpath) SEEK_SET)
+ (put-bytevector port path)
+ (put-u8 port 0)))))
+
+;;; Local Variables:
+;;; eval: (put 'call-with-input+output-file 'scheme-indent-function 1)
+;;; End:
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 8a02cb68dd..17d2637f87 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -281,7 +281,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
type
compress?
#:allow-other-keys)
- "Generate an executable by using asdf operation TYPE, containing whithin the
+ "Generate an executable by using asdf operation TYPE, containing within the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure
references to those libraries are retained."
diff --git a/guix/build/maven/pom.scm b/guix/build/maven/pom.scm
index c92d409d2b..dd61f659c2 100644
--- a/guix/build/maven/pom.scm
+++ b/guix/build/maven/pom.scm
@@ -243,7 +243,7 @@ to re-declare the namespaces in the top-level element."
(define* (fix-pom-dependencies pom-file inputs
#:key with-plugins? with-build-dependencies?
(excludes '()) (local-packages '()))
- "Open @var{pom-file}, and override its content, rewritting its dependencies
+ "Open @var{pom-file}, and override its content, rewriting its dependencies
to set their version to the latest version available in the @var{inputs}.
@var{#:with-plugins?} controls whether plugins are also overridden.
diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
index 8043a84abb..cc2ba83889 100644
--- a/guix/build/meson-build-system.scm
+++ b/guix/build/meson-build-system.scm
@@ -100,7 +100,7 @@ for example libraries only needed for the tests."
(find-files dir elf-pred))
existing-elf-dirs))))
(for-each strip-runpath elf-list)))))
- (for-each handle-output outputs)
+ (for-each handle-output (alist-delete "debug" outputs))
#t)
(define %standard-phases
diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm
index 92158a033f..f7f51af301 100644
--- a/guix/build/minify-build-system.scm
+++ b/guix/build/minify-build-system.scm
@@ -23,6 +23,7 @@
#:use-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:export (%standard-phases
minify-build
@@ -42,14 +43,17 @@
(minified (open-pipe* OPEN_READ "uglify-js" file)))
(call-with-output-file installed
(cut dump-port minified <>))
- #t))
+ (match (close-pipe minified)
+ (0 #t)
+ (status
+ (error "uglify-js failed" status)))))
(define* (build #:key javascript-files
#:allow-other-keys)
(let ((files (or javascript-files
(find-files "src" "\\.js$"))))
(mkdir-p "guix/build")
- (every (cut minify <> #:directory "guix/build/") files)))
+ (for-each (cut minify <> #:directory "guix/build/") files)))
(define* (install #:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@@ -60,8 +64,7 @@
(if (not (zero? (stat:size (stat file))))
(install-file file js)
(error "File is empty: " file)))
- (find-files "guix/build" "\\.min\\.js$")))
- #t)
+ (find-files "guix/build" "\\.min\\.js$"))))
(define %standard-phases
(modify-phases gnu:%standard-phases
diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 09bd8465c8..1fc97d1398 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -6,6 +6,10 @@
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2019, 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,6 +31,7 @@
#:use-module (guix build utils)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%standard-phases
@@ -128,6 +133,15 @@
(apply invoke "python" "./setup.py" command params)))
(error "no setup.py found")))
+(define* (sanity-check #:key tests? inputs outputs #:allow-other-keys)
+ "Ensure packages depending on this package via setuptools work properly,
+their advertised endpoints work and their top level modules are importable
+without errors."
+ (let ((sanity-check.py (assoc-ref inputs "sanity-check.py")))
+ ;; Make sure the working directory is empty (i.e. no Python modules in it)
+ (with-directory-excursion "/tmp"
+ (invoke "python" sanity-check.py (site-packages inputs outputs)))))
+
(define* (build #:key use-setuptools? #:allow-other-keys)
"Build a given Python package."
(call-setuppy "build" '() use-setuptools?)
@@ -154,37 +168,58 @@
(major+minor (take components 2)))
(string-join major+minor ".")))
+(define (python-output outputs)
+ "Return the path of the python output, if there is one, or fall-back to out."
+ (or (assoc-ref outputs "python")
+ (assoc-ref outputs "out")))
+
(define (site-packages inputs outputs)
"Return the path of the current output's Python site-package."
- (let* ((out (assoc-ref outputs "out"))
+ (let* ((out (python-output outputs))
(python (assoc-ref inputs "python")))
- (string-append out "/lib/python"
- (python-version python)
- "/site-packages/")))
+ (string-append out "/lib/python" (python-version python) "/site-packages")))
(define (add-installed-pythonpath inputs outputs)
- "Prepend the Python site-package of OUTPUT to PYTHONPATH. This is useful
-when running checks after installing the package."
- (let ((old-path (getenv "PYTHONPATH"))
- (add-path (site-packages inputs outputs)))
- (setenv "PYTHONPATH"
- (string-append add-path
- (if old-path (string-append ":" old-path) "")))
- #t))
+ "Prepend the site-package of OUTPUT to GUIX_PYTHONPATH. This is useful when
+running checks after installing the package."
+ (setenv "GUIX_PYTHONPATH" (string-append (site-packages inputs outputs) ":"
+ (getenv "GUIX_PYTHONPATH"))))
+
+(define* (add-install-to-pythonpath #:key inputs outputs #:allow-other-keys)
+ "A phase that just wraps the 'add-installed-pythonpath' procedure."
+ (add-installed-pythonpath inputs outputs))
-(define* (install #:key outputs (configure-flags '()) use-setuptools?
+(define* (add-install-to-path #:key outputs #:allow-other-keys)
+ "Adding Python scripts to PATH is also often useful in tests."
+ (setenv "PATH" (string-append (assoc-ref outputs "out")
+ "/bin:"
+ (getenv "PATH"))))
+
+(define* (install #:key inputs outputs (configure-flags '()) use-setuptools?
#:allow-other-keys)
"Install a given Python package."
- (let* ((out (assoc-ref outputs "out"))
- (params (append (list (string-append "--prefix=" out))
+ (let* ((out (python-output outputs))
+ (python (assoc-ref inputs "python"))
+ (major-minor (map string->number
+ (take (string-split (python-version python) #\.) 2)))
+ (<3.7? (match major-minor
+ ((major minor)
+ (or (< major 3) (and (= major 3) (< minor 7))))))
+ (params (append (list (string-append "--prefix=" out)
+ "--no-compile")
(if use-setuptools?
;; distutils does not accept these flags
(list "--single-version-externally-managed"
- "--root=/")
+ "--root=/")
'())
configure-flags)))
(call-setuppy "install" params use-setuptools?)
- #t))
+ ;; Rather than produce potentially non-reproducible .pyc files on Pythons
+ ;; older than 3.7, whose 'compileall' module lacks the
+ ;; '--invalidation-mode' option, do not generate any.
+ (unless <3.7?
+ (invoke "python" "-m" "compileall" "--invalidation-mode=unchecked-hash"
+ out))))
(define* (wrap #:key inputs outputs #:allow-other-keys)
(define (list-of-files dir)
@@ -194,25 +229,19 @@ when running checks after installing the package."
(define bindirs
(append-map (match-lambda
- ((_ . dir)
- (list (string-append dir "/bin")
- (string-append dir "/sbin"))))
+ ((_ . dir)
+ (list (string-append dir "/bin")
+ (string-append dir "/sbin"))))
outputs))
- (let* ((out (assoc-ref outputs "out"))
- (python (assoc-ref inputs "python"))
- (var `("PYTHONPATH" prefix
- ,(cons (string-append out "/lib/python"
- (python-version python)
- "/site-packages")
- (search-path-as-string->list
- (or (getenv "PYTHONPATH") ""))))))
+ (let* ((var `("GUIX_PYTHONPATH" prefix
+ ,(search-path-as-string->list
+ (or (getenv "GUIX_PYTHONPATH") "")))))
(for-each (lambda (dir)
(let ((files (list-of-files dir)))
(for-each (cut wrap-program <> var)
files)))
- bindirs)
- #t))
+ bindirs)))
(define* (rename-pth-file #:key name inputs outputs #:allow-other-keys)
"Rename easy-install.pth to NAME.pth to avoid conflicts between packages
@@ -220,16 +249,11 @@ installed with setuptools."
;; Even if the "easy-install.pth" is not longer created, we kept this phase.
;; There still may be packages creating an "easy-install.pth" manually for
;; some good reason.
- (let* ((out (assoc-ref outputs "out"))
- (python (assoc-ref inputs "python"))
- (site-packages (string-append out "/lib/python"
- (python-version python)
- "/site-packages"))
+ (let* ((site-packages (site-packages inputs outputs))
(easy-install-pth (string-append site-packages "/easy-install.pth"))
(new-pth (string-append site-packages "/" name ".pth")))
(when (file-exists? easy-install-pth)
- (rename-file easy-install-pth new-pth))
- #t))
+ (rename-file easy-install-pth new-pth))))
(define* (ensure-no-mtimes-pre-1980 #:rest _)
"Ensure that there are no mtimes before 1980-01-02 in the source tree."
@@ -241,25 +265,38 @@ installed with setuptools."
(ftw "." (lambda (file stat flag)
(unless (<= early-1980 (stat:mtime stat))
(utime file early-1980 early-1980))
- #t))
- #t))
+ #t))))
(define* (enable-bytecode-determinism #:rest _)
"Improve determinism of pyc files."
;; Use deterministic hashes for strings, bytes, and datetime objects.
(setenv "PYTHONHASHSEED" "0")
- #t)
+ ;; Prevent Python from creating .pyc files when loading modules (such as
+ ;; when running a test suite).
+ (setenv "PYTHONDONTWRITEBYTECODE" "1"))
+
+(define* (ensure-no-cythonized-files #:rest _)
+ "Check the source code for @code{.c} files which may have been pre-generated
+by Cython."
+ (for-each
+ (lambda (file)
+ (let ((generated-file
+ (string-append (string-drop-right file 3) "c")))
+ (when (file-exists? generated-file)
+ (format #t "Possible Cythonized file found: ~a~%" generated-file))))
+ (find-files "." "\\.pyx$")))
(define %standard-phases
;; 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.
+ ;; while the install phase copies then byte-compiles the sources to the
+ ;; prefix directory. The check phase is moved after the installation phase
+ ;; to ease testing the built package.
(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)
+ (add-after 'enable-bytecode-determinism 'ensure-no-cythonized-files
+ ensure-no-cythonized-files)
(delete 'bootstrap)
(delete 'configure) ;not needed
(replace 'build build)
@@ -267,6 +304,9 @@ installed with setuptools."
(replace 'install install)
(add-after 'install 'check check)
(add-after 'install 'wrap wrap)
+ (add-before 'check 'add-install-to-pythonpath add-install-to-pythonpath)
+ (add-before 'check 'add-install-to-path add-install-to-path)
+ (add-after 'check 'sanity-check sanity-check)
(add-before 'strip 'rename-pth-file rename-pth-file)))
(define* (python-build #:key inputs (phases %standard-phases)
diff --git a/guix/build/rpath.scm b/guix/build/rpath.scm
deleted file mode 100644
index 75a1fef5ef..0000000000
--- a/guix/build/rpath.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix build rpath)
- #:use-module (ice-9 popen)
- #:use-module (ice-9 rdelim)
- #:export (%patchelf
- file-rpath
- augment-rpath))
-
-;;; Commentary:
-;;;
-;;; Tools to manipulate the RPATH and RUNPATH of ELF binaries. Currently they
-;;; rely on PatchELF.
-;;;
-;;; Code:
-
-(define %patchelf
- ;; The `patchelf' command.
- (make-parameter "patchelf"))
-
-(define %not-colon
- (char-set-complement (char-set #\:)))
-
-(define (file-rpath file)
- "Return the RPATH (or RUNPATH) of FILE as a list of directory names, or #f
-on failure."
- (let* ((p (open-pipe* OPEN_READ (%patchelf) "--print-rpath" file))
- (l (read-line p)))
- (and (zero? (close-pipe p))
- (string-tokenize l %not-colon))))
-
-(define (augment-rpath file dir)
- "Add DIR to the front of the RPATH and RUNPATH of FILE. Return the new
-RPATH as a list, or #f on failure."
- (let* ((rpath (or (file-rpath file) '()))
- (rpath* (cons dir rpath)))
- (format #t "~a: changing RPATH from ~s to ~s~%"
- file rpath rpath*)
- (and (zero? (system* (%patchelf) "--set-rpath"
- (string-join rpath* ":") file))
- rpath*)))
-
-;;; rpath.scm ends here
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index c957a61115..9aceb187a4 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Pjotr Prins <pjotr.public01@thebird.nl>
;;; Copyright © 2015, 2016 Ben Woodcroft <donttrustben@gmail.com>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -73,13 +74,19 @@ directory."
(define* (replace-git-ls-files #:key source #:allow-other-keys)
"Many gemspec files downloaded from outside rubygems.org use `git ls-files`
-to list of the files to be included in the built gem. However, since this
+to list the files to be included in the built gem. However, since this
operation is not deterministic, we replace it with `find`."
- (when (not (gem-archive? source))
+ (unless (gem-archive? source)
(let ((gemspec (first-gemspec)))
+ ;; Do not include the freshly built .gem itself as it causes problems.
+ ;; Strip the first 2 characters ("./") to more exactly match the output
+ ;; given by 'git ls-files'. This is useful to prevent breaking regexps
+ ;; that could be used to filter the list of files.
(substitute* gemspec
- (("`git ls-files`") "`find . -type f |sort`")
- (("`git ls-files -z`") "`find . -type f -print0 |sort -z`"))))
+ (("`git ls-files`")
+ "`find . -type f -not -regex '.*\\.gem$' | sort | cut -c3-`")
+ (("`git ls-files -z`")
+ "`find . -type f -not -regex '.*\\.gem$' -print0 | sort -z | cut -zc3-`"))))
#t)
(define* (extract-gemspec #:key source #:allow-other-keys)
@@ -129,11 +136,7 @@ is #f."
#:allow-other-keys)
"Install the gem archive SOURCE to the output store item. Additional
GEM-FLAGS are passed to the 'gem' invocation, if present."
- (let* ((ruby-version
- (match:substring (string-match "ruby-(.*)\\.[0-9]$"
- (assoc-ref inputs "ruby"))
- 1))
- (out (assoc-ref outputs "out"))
+ (let* ((out (assoc-ref outputs "out"))
(vendor-dir (string-append out "/lib/ruby/vendor_ruby"))
(gem-file (first-matching-file "\\.gem$"))
(gem-file-basename (basename gem-file))
@@ -144,8 +147,8 @@ GEM-FLAGS are passed to the 'gem' invocation, if present."
(setenv "GEM_VENDOR" vendor-dir)
(or (zero?
- ;; 'zero? system*' allows the custom error handling to function as
- ;; expected, while 'invoke' raises its own exception.
+ ;; 'zero? system*' allows the custom error handling to function as
+ ;; expected, while 'invoke' raises its own exception.
(apply system* "gem" "install" gem-file
"--verbose"
"--local" "--ignore-dependencies" "--vendor"
diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm
index 841c631dae..4c255700bb 100644
--- a/guix/build/texlive-build-system.scm
+++ b/guix/build/texlive-build-system.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,39 +41,11 @@
(string-append "&" format)
file))
-(define* (configure #:key inputs #:allow-other-keys)
- (let* ((out (string-append (getcwd) "/.texlive-union"))
- (texmf.cnf (string-append out "/share/texmf-dist/web2c/texmf.cnf")))
- ;; Build a modifiable union of all inputs (but exclude bash)
- (match inputs
- (((names . directories) ...)
- (union-build out (filter directory-exists? directories)
- #:create-all-directories? #t
- #:log-port (%make-void-port "w"))))
-
- ;; The configuration file "texmf.cnf" is provided by the
- ;; "texlive-bin" package. We take it and override only the
- ;; setting for TEXMFROOT and TEXMF. This file won't be consulted
- ;; by default, though, so we still need to set TEXMFCNF.
- (substitute* texmf.cnf
- (("^TEXMFROOT = .*")
- (string-append "TEXMFROOT = " out "/share\n"))
- (("^TEXMF = .*")
- "TEXMF = $TEXMFROOT/share/texmf-dist\n"))
- (setenv "TEXMFCNF" (dirname texmf.cnf))
- (setenv "TEXMF" (string-append out "/share/texmf-dist"))
-
- ;; Don't truncate lines.
- (setenv "error_line" "254") ; must be less than 255
- (setenv "half_error_line" "238") ; must be less than error_line - 15
- (setenv "max_print_line" "1000"))
- (mkdir "build")
- #t)
-
(define* (build #:key inputs build-targets tex-format #:allow-other-keys)
- (every (cut compile-with-latex tex-format <>)
- (if build-targets build-targets
- (scandir "." (cut string-suffix? ".ins" <>)))))
+ (mkdir "build")
+ (for-each (cut compile-with-latex tex-format <>)
+ (if build-targets build-targets
+ (scandir "." (cut string-suffix? ".ins" <>)))))
(define* (install #:key outputs tex-directory #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@@ -81,13 +54,12 @@
(mkdir-p target)
(for-each delete-file (find-files "." "\\.(log|aux)$"))
(for-each (cut install-file <> target)
- (find-files "build" ".*"))
- #t))
+ (find-files "build" ".*"))))
(define %standard-phases
(modify-phases gnu:%standard-phases
(delete 'bootstrap)
- (replace 'configure configure)
+ (delete 'configure)
(replace 'build build)
(delete 'check)
(replace 'install install)))
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 419c10195b..6c37021673 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -1,10 +1,12 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 © 2015, 2018, 2021 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -49,9 +51,14 @@
package-name->name+version
parallel-job-count
+ compressor
+ tarball?
+ %xz-parallel-args
+
directory-exists?
executable-file?
symbolic-link?
+ call-with-temporary-output-file
call-with-ascii-input-file
elf-file?
ar-file?
@@ -134,12 +141,39 @@
;;;
+;;; Compression helpers.
+;;;
+
+(define (compressor file-name)
+ "Return the name of the compressor package/binary used to compress or
+decompress FILE-NAME, based on its file extension, else false."
+ (cond ((string-suffix? "gz" file-name) "gzip")
+ ((string-suffix? "Z" file-name) "gzip")
+ ((string-suffix? "bz2" file-name) "bzip2")
+ ((string-suffix? "lz" file-name) "lzip")
+ ((string-suffix? "zip" file-name) "unzip")
+ ((string-suffix? "xz" file-name) "xz")
+ (else #f))) ;no compression used/unknown file extension
+
+(define (tarball? file-name)
+ "True when FILE-NAME has a tar file extension."
+ (string-match "\\.(tar(\\..*)?|tgz|tbz)$" file-name))
+
+(define (%xz-parallel-args)
+ "The xz arguments required to enable bit-reproducible, multi-threaded
+compression."
+ (list "--memlimit=50%"
+ (format #f "--threads=~a" (max 2 (parallel-job-count)))))
+
+
+;;;
;;; Directories.
;;;
(define (%store-directory)
"Return the directory name of the store."
- (or (getenv "NIX_STORE")
+ (or (getenv "NIX_STORE_DIR") ;outside of builder
+ (getenv "NIX_STORE") ;inside builder, set by the daemon
"/gnu/store"))
(define (store-file-name? file)
@@ -197,6 +231,22 @@ introduce the version part."
"Return #t if FILE is a symbolic link (aka. \"symlink\".)"
(eq? (stat:type (lstat file)) 'symlink))
+(define (call-with-temporary-output-file proc)
+ "Call PROC with a name of a temporary file and open output port to that
+file; close the file and delete it when leaving the dynamic extent of this
+call."
+ (let* ((directory (or (getenv "TMPDIR") "/tmp"))
+ (template (string-append directory "/guix-file.XXXXXX"))
+ (out (mkstemp! template)))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (proc template out))
+ (lambda ()
+ (false-if-exception (close out))
+ (false-if-exception (delete-file template))))))
+
(define (call-with-ascii-input-file file proc)
"Open FILE as an ASCII or binary file, and pass the resulting port to
PROC. FILE is closed when PROC's dynamic extent is left. Return the
@@ -322,11 +372,13 @@ name."
#:key
(log (current-output-port))
(follow-symlinks? #f)
- keep-mtime?)
+ (copy-file copy-file)
+ keep-mtime? keep-permissions?)
"Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS?
-is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the
-modification time of the files in SOURCE on those of DESTINATION. Write
-verbose output to the LOG port."
+is true; otherwise, just preserve them. Call COPY-FILE to copy regular files.
+When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on
+those of DESTINATION. When KEEP-PERMISSIONS? is true, preserve file
+permissions. Write verbose output to the LOG port."
(define strip-source
(let ((len (string-length source)))
(lambda (file)
@@ -343,16 +395,21 @@ verbose output to the LOG port."
(symlink target dest)))
(else
(copy-file file dest)
- (when keep-mtime?
- (set-file-time dest stat))))))
+ (when keep-permissions?
+ (chmod dest (stat:perms stat)))))
+ (when keep-mtime?
+ (set-file-time dest stat))))
(lambda (dir stat result) ; down
(let ((target (string-append destination
(strip-source dir))))
- (mkdir-p target)
- (when keep-mtime?
- (set-file-time target stat))))
+ (mkdir-p target)))
(lambda (dir stat result) ; up
- result)
+ (let ((target (string-append destination
+ (strip-source dir))))
+ (when keep-mtime?
+ (set-file-time target stat))
+ (when keep-permissions?
+ (chmod target (stat:perms stat)))))
(const #t) ; skip
(lambda (file stat errno result)
(format (current-error-port) "i/o error: ~a: ~a~%"
@@ -365,6 +422,16 @@ verbose output to the LOG port."
stat
lstat)))
+(define-syntax-rule (warn-on-error expr file)
+ (catch 'system-error
+ (lambda ()
+ expr)
+ (lambda args
+ (format (current-error-port)
+ "warning: failed to delete ~a: ~a~%"
+ file (strerror
+ (system-error-errno args))))))
+
(define* (delete-file-recursively dir
#:key follow-mounts?)
"Delete DIR recursively, like `rm -rf', without following symlinks. Don't
@@ -375,10 +442,10 @@ errors."
(or follow-mounts?
(= dev (stat:dev stat))))
(lambda (file stat result) ; leaf
- (delete-file file))
+ (warn-on-error (delete-file file) file))
(const #t) ; down
(lambda (dir stat result) ; up
- (rmdir dir))
+ (warn-on-error (rmdir dir) dir))
(const #t) ; skip
(lambda (file stat errno result)
(format (current-error-port)
@@ -746,6 +813,31 @@ PROC's result is returned."
(lambda (key . args)
(false-if-exception (delete-file template))))))
+(define (unused-private-use-code-point s)
+ "Find a code point within a Unicode Private Use Area that is not
+present in S, and return the corresponding character object. If one
+cannot be found, return false."
+ (define (scan lo hi)
+ (and (<= lo hi)
+ (let ((c (integer->char lo)))
+ (if (string-index s c)
+ (scan (+ lo 1) hi)
+ c))))
+ (or (scan #xE000 #xF8FF)
+ (scan #xF0000 #xFFFFD)
+ (scan #x100000 #x10FFFD)))
+
+(define (replace-char c1 c2 s)
+ "Return a string which is equal to S except with all instances of C1
+replaced by C2. If C1 and C2 are equal, return S."
+ (if (char=? c1 c2)
+ s
+ (string-map (lambda (c)
+ (if (char=? c c1)
+ c2
+ c))
+ s)))
+
(define (substitute file pattern+procs)
"PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
line of FILE, and for each PATTERN that it matches, call the corresponding
@@ -764,16 +856,26 @@ end of a line; by itself it won't match the terminating newline of a line."
(let loop ((line (read-line in 'concat)))
(if (eof-object? line)
#t
- (let ((line (fold (lambda (r+p line)
- (match r+p
- ((regexp . proc)
- (match (list-matches regexp line)
- ((and m+ (_ _ ...))
- (proc line m+))
- (_ line)))))
- line
- rx+proc)))
- (display line out)
+ ;; Work around the fact that Guile's regexp-exec does not handle
+ ;; NUL characters (a limitation of the underlying GNU libc's
+ ;; regexec) by temporarily replacing them by an unused private
+ ;; Unicode code point.
+ ;; TODO: Use SRFI-115 instead, once available in Guile.
+ (let* ((nul* (or (and (string-index line #\nul)
+ (unused-private-use-code-point line))
+ #\nul))
+ (line* (replace-char #\nul nul* line))
+ (line1* (fold (lambda (r+p line)
+ (match r+p
+ ((regexp . proc)
+ (match (list-matches regexp line)
+ ((and m+ (_ _ ...))
+ (proc line m+))
+ (_ line)))))
+ line*
+ rx+proc))
+ (line1 (replace-char nul* #\nul line1*)))
+ (display line1 out)
(loop (read-line in 'concat)))))))))
@@ -800,7 +902,7 @@ sub-expression. For example:
((\"hello\")
\"good morning\\n\")
((\"foo([a-z]+)bar(.*)$\" all letters end)
- (string-append \"baz\" letter end)))
+ (string-append \"baz\" letters end)))
Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
morning\". Anytime a line of FILE matches the second regexp, ALL is bound to
@@ -853,29 +955,45 @@ match the terminating newline of a line."
;;;
(define* (dump-port in out
+ #:optional len
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
- "Read as much data as possible from IN and write it to OUT, using chunks of
-BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
-transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
-transferred and the continuation of the transfer as a thunk."
+ "Read LEN bytes from IN or as much data as possible if LEN is #f, and write
+it to OUT, using chunks of BUFFER-SIZE bytes. Call PROGRESS at the beginning
+and after each successful transfer of BUFFER-SIZE bytes or less, passing it
+the total number of bytes transferred and the continuation of the transfer as
+a thunk."
(define buffer
(make-bytevector buffer-size))
(define (loop total bytes)
(or (eof-object? bytes)
+ (and len (= total len))
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
- (get-bytevector-n! in buffer 0 buffer-size)))))))
+ (get-bytevector-n! in buffer 0
+ (if len
+ (min (- len total) buffer-size)
+ buffer-size))))))))
;; Make sure PROGRESS is called when we start so that it can measure
;; throughput.
(progress 0
(lambda ()
- (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
+ (loop 0 (get-bytevector-n! in buffer 0
+ (if len
+ (min len buffer-size)
+ buffer-size))))))
+
+(define AT_SYMLINK_NOFOLLOW
+ ;; Guile 2.0 did not define this constant, hence this hack.
+ (let ((variable (module-variable the-root-module 'AT_SYMLINK_NOFOLLOW)))
+ (if variable
+ (variable-ref variable)
+ 256))) ;for GNU/Linux
(define (set-file-time file stat)
"Set the atime/mtime of FILE to that specified by STAT."
@@ -883,7 +1001,8 @@ transferred and the continuation of the transfer as a thunk."
(stat:atime stat)
(stat:mtime stat)
(stat:atimensec stat)
- (stat:mtimensec stat)))
+ (stat:mtimensec stat)
+ AT_SYMLINK_NOFOLLOW))
(define (get-char* p)
;; We call it `get-char', but that's really a binary version
@@ -1307,7 +1426,7 @@ not supported."
(lambda ()
(call-with-ascii-input-file prog
(lambda (p)
- (format out header)
+ (display header out)
(dump-port p out)
(close out)
(chmod template mode)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 764c89a187..2735d25d0c 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1559,7 +1559,8 @@ last one is created from the given <scheme-file> object."
(guile (%guile-for-build))
(module-path %load-path)
(extensions '())
- (deprecation-warnings #f))
+ (deprecation-warnings #f)
+ (optimization-level 1))
"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
@@ -1583,6 +1584,13 @@ TARGET, a GNU triplet."
(system base target)
(system base compile))
+ (define optimizations-for-level
+ (or (and=> (false-if-exception
+ (resolve-interface '(system base optimize)))
+ (lambda (iface)
+ (module-ref iface 'optimizations-for-level))) ;Guile 3.0
+ (const '())))
+
(define (regular? file)
(not (member file '("." ".."))))
@@ -1598,17 +1606,14 @@ TARGET, a GNU triplet."
(ungexp (* total 2))
entry)
- (ungexp-splicing
- (if target
- (gexp ((with-target (ungexp target)
- (lambda ()
- (compile-file entry
- #:output-file output
- #:opts
- %auto-compilation-options)))))
- (gexp ((compile-file entry
- #:output-file output
- #:opts %auto-compilation-options)))))
+ (with-target (ungexp (or target (gexp %host-type)))
+ (lambda ()
+ (compile-file entry
+ #:output-file output
+ #:opts
+ `(,@%auto-compilation-options
+ ,@(optimizations-for-level
+ (ungexp optimization-level))))))
(+ 1 processed))))
diff --git a/guix/packages.scm b/guix/packages.scm
index 9305dabcec..67ef6ea146 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,10 +1,11 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.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, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +23,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix packages)
+ #:use-module ((guix build utils) #:select (compressor tarball?
+ strip-store-file-name))
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix store)
@@ -608,20 +611,7 @@ specifies modules in scope when evaluating SNIPPET."
((package) package)
(#f #f)))))
- (define decompression-type
- (cond ((string-suffix? "gz" source-file-name) "gzip")
- ((string-suffix? "Z" source-file-name) "gzip")
- ((string-suffix? "bz2" source-file-name) "bzip2")
- ((string-suffix? "lz" source-file-name) "lzip")
- ((string-suffix? "zip" source-file-name) "unzip")
- (else "xz")))
-
- (define original-file-name
- ;; Remove the store prefix plus the slash, hash, and hyphen.
- (let* ((sans (string-drop source-file-name
- (+ (string-length (%store-prefix)) 1)))
- (dash (string-index sans #\-)))
- (string-drop sans (+ 1 dash))))
+ (define original-file-name (strip-store-file-name source-file-name))
(define (numeric-extension? file-name)
;; Return true if FILE-NAME ends with digits.
@@ -634,11 +624,9 @@ specifies modules in scope when evaluating SNIPPET."
(define (tarxz-name file-name)
;; Return a '.tar.xz' file name based on 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)))))
+ (let ((base (if (numeric-extension? file-name)
+ original-file-name
+ (file-sans-extension file-name))))
(string-append base
(if (equal? (file-extension base) "tar")
".xz"
@@ -652,17 +640,24 @@ specifies modules in scope when evaluating SNIPPET."
(lower-object patch system))))
(mlet %store-monad ((tar -> (lookup-input "tar"))
+ (gzip -> (lookup-input "gzip"))
+ (bzip2 -> (lookup-input "bzip2"))
+ (lzip -> (lookup-input "lzip"))
(xz -> (lookup-input "xz"))
(patch -> (lookup-input "patch"))
(locales -> (lookup-input "locales"))
- (decomp -> (lookup-input decompression-type))
+ (comp -> (and=> (compressor source-file-name)
+ lookup-input))
(patches (sequence %store-monad
(map instantiate-patch patches))))
(define build
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (ice-9 ftw)
+ (ice-9 match)
+ (ice-9 regex)
(srfi srfi-1)
+ (srfi srfi-26)
(guix build utils))
;; The --sort option was added to GNU tar in version 1.28, released
@@ -688,66 +683,8 @@ specifies modules in scope when evaluating SNIPPET."
(lambda (name)
(not (member name '("." "..")))))))
- ;; Encoding/decoding errors shouldn't be silent.
- (fluid-set! %default-port-conversion-strategy 'error)
-
- (when #+locales
- ;; First of all, install a UTF-8 locale so that UTF-8 file names
- ;; are correctly interpreted. During bootstrap, LOCALES is #f.
- (setenv "LOCPATH"
- (string-append #+locales "/lib/locale/"
- #+(and locales
- (version-major+minor
- (package-version locales)))))
- (setlocale LC_ALL "en_US.utf8"))
-
- (setenv "PATH" (string-append #+xz "/bin" ":"
- #+decomp "/bin"))
-
- ;; SOURCE may be either a directory or a tarball.
- (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 "..")
-
+ (define (repack directory output)
+ ;; Write to OUTPUT a compressed tarball containing DIRECTORY.
(unless tar-supports-sort?
(call-with-output-file ".file_list"
(lambda (port)
@@ -756,22 +693,95 @@ specifies modules in scope when evaluating SNIPPET."
(find-files directory
#:directories? #t
#:fail-on-error? #t)))))
- (apply invoke
- (string-append #+tar "/bin/tar")
- "cvfa" #$output
+
+ (apply invoke #+(file-append tar "/bin/tar")
+ "cvfa" output
;; Avoid non-determinism in the archive. Set the mtime
;; to 1 as is the case in the store (software like gzip
;; behaves differently when it stumbles upon mtime = 0).
"--mtime=@1"
- "--owner=root:0"
- "--group=root:0"
+ "--owner=root:0" "--group=root:0"
(if tar-supports-sort?
- `("--sort=name"
- ,directory)
+ `("--sort=name" ,directory)
'("--no-recursion"
- "--files-from=.file_list")))))))
+ "--files-from=.file_list"))))
- (let ((name (tarxz-name original-file-name)))
+ ;; Encoding/decoding errors shouldn't be silent.
+ (fluid-set! %default-port-conversion-strategy 'error)
+
+ (when #+locales
+ ;; First of all, install a UTF-8 locale so that UTF-8 file names
+ ;; are correctly interpreted. During bootstrap, LOCALES is #f.
+ (setenv "LOCPATH"
+ (string-append #+locales "/lib/locale/"
+ #+(and locales
+ (version-major+minor
+ (package-version locales)))))
+ (setlocale LC_ALL "en_US.utf8"))
+
+ (setenv "PATH"
+ (string-append #+xz "/bin"
+ (if #+comp
+ (string-append ":" #+comp "/bin")
+ "")))
+
+ (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args)))
+
+ ;; SOURCE may be either a directory, a tarball or a simple file.
+ (let ((name (strip-store-file-name #+source))
+ (command (and=> #+comp (cut string-append <> "/bin/"
+ (compressor #+source)))))
+ (if (file-is-directory? #+source)
+ (copy-recursively #+source name)
+ (cond
+ ((tarball? #+source)
+ (invoke (string-append #+tar "/bin/tar") "xvf" #+source))
+ ((and=> (compressor #+source) (cut string= "unzip" <>))
+ ;; Note: Referring to the store unzip here (#+unzip)
+ ;; would introduce a cycle.
+ ("unzip" (invoke "unzip" #+source)))
+ (else
+ (copy-file #+source name)
+ (when command
+ (invoke command "--decompress" name))))))
+
+ (let* ((file (first-file "."))
+ (directory (if (file-is-directory? file)
+ file
+ ".")))
+ (format (current-error-port) "source is at '~a'~%" file)
+
+ (with-directory-excursion directory
+
+ (for-each 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))
+ #~#t))
+
+ ;; If SOURCE is a directory (such as a checkout), return a
+ ;; directory. Otherwise create a tarball.
+ (cond
+ ((file-is-directory? #+source)
+ (copy-recursively directory #$output
+ #:log (%make-void-port "w")))
+ ((not #+comp)
+ (copy-file file #$output))
+ (else
+ (repack directory #$output)))))))
+
+ (let ((name (if (or (checkout? original-file-name)
+ (not (compressor original-file-name)))
+ original-file-name
+ (tarxz-name original-file-name))))
(gexp->derivation name build
#:graft? #f
#:system system
@@ -1408,6 +1418,22 @@ TARGET."
(bag (package->bag package system target)))
(bag-grafts store bag)))
+(define-inlinable (derivation=? drv1 drv2)
+ "Return true if DRV1 and DRV2 are equal."
+ (or (eq? drv1 drv2)
+ (string=? (derivation-file-name drv1)
+ (derivation-file-name drv2))))
+
+(define (input=? input1 input2)
+ "Return true if INPUT1 and INPUT2 are equivalent."
+ (match input1
+ ((label1 drv1 . outputs1)
+ (match input2
+ ((label2 drv2 . outputs2)
+ (and (string=? label1 label2)
+ (equal? outputs1 outputs2)
+ (derivation=? drv1 drv2)))))))
+
(define* (bag->derivation store bag
#:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
@@ -1426,9 +1452,12 @@ error reporting."
p))
(_ '()))
inputs))))
-
+ ;; It's possible that INPUTS contains packages that are not 'eq?' but
+ ;; that lead to the same derivation. Delete those duplicates to avoid
+ ;; issues down the road, such as duplicate entries in '%build-inputs'.
(apply (bag-build bag)
- store (bag-name bag) input-drvs
+ store (bag-name bag)
+ (delete-duplicates input-drvs input=?)
#:search-paths paths
#:outputs (bag-outputs bag) #:system system
(bag-arguments bag)))))
@@ -1466,8 +1495,9 @@ This is an internal procedure."
(apply (bag-build bag)
store (bag-name bag)
- #:native-drvs build-drvs
- #:target-drvs (append host-drvs target-drvs)
+ #:native-drvs (delete-duplicates build-drvs input=?)
+ #:target-drvs (delete-duplicates (append host-drvs target-drvs)
+ input=?)
#:search-paths paths
#:native-search-paths npaths
#:outputs (bag-outputs bag)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ea8bc6e593..36cb30c191 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1610,53 +1610,6 @@ the entries in MANIFEST."
`((type . profile-hook)
(hook . manual-database))))
-(define (texlive-configuration manifest)
- "Return a derivation that builds a TeXlive configuration for the entries in
-MANIFEST."
- (define entry->texlive-input
- (match-lambda
- (($ <manifest-entry> name version output thing deps)
- (if (string-prefix? "texlive-" name)
- (cons (gexp-input thing output)
- (append-map entry->texlive-input deps))
- '()))))
- (define build
- (with-imported-modules '((guix build utils)
- (guix build union))
- #~(begin
- (use-modules (guix build utils)
- (guix build union))
-
- ;; Build a modifiable union of all texlive inputs. We do this so
- ;; that TeX live can resolve the parent and grandparent directories
- ;; correctly. There might be a more elegant way to accomplish this.
- (union-build #$output
- '#$(append-map entry->texlive-input
- (manifest-entries manifest))
- #:create-all-directories? #t
- #:log-port (%make-void-port "w"))
- (let ((texmf.cnf (string-append
- #$output
- "/share/texmf-dist/web2c/texmf.cnf")))
- (when (file-exists? texmf.cnf)
- (substitute* texmf.cnf
- (("^TEXMFROOT = .*")
- (string-append "TEXMFROOT = " #$output "/share\n"))
- (("^TEXMF = .*")
- "TEXMF = $TEXMFROOT/share/texmf-dist\n"))))
- #t)))
-
- (with-monad %store-monad
- (if (any (cut string-prefix? "texlive-" <>)
- (map manifest-entry-name (manifest-entries manifest)))
- (gexp->derivation "texlive-configuration" build
- #:substitutable? #f
- #:local-build? #t
- #:properties
- `((type . profile-hook)
- (hook . texlive-configuration)))
- (return #f))))
-
(define %default-profile-hooks
;; This is the list of derivation-returning procedures that are called by
;; default when making a non-empty profile.
@@ -1668,7 +1621,6 @@ MANIFEST."
glib-schemas
gtk-icon-themes
gtk-im-modules
- texlive-configuration
xdg-desktop-database
xdg-mime-database))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8ecdcb823f..169cbc2500 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
;;;
;;; This file is part of GNU Guix.
@@ -26,6 +27,7 @@
#:use-module (guix scripts)
#:use-module (guix ui)
#:use-module (guix gexp)
+ #:use-module ((guix build utils) #:select (%xz-parallel-args))
#:use-module (guix utils)
#:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity))
@@ -77,29 +79,34 @@
compressor?
(name compressor-name) ;string (e.g., "gzip")
(extension compressor-extension) ;string (e.g., ".lz")
- (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n"))
+ (command compressor-command)) ;gexp (e.g., #~(list "/gnu/store/…/gzip"
+ ; "-9n" ))
(define %compressors
;; Available compression tools.
(list (compressor "gzip" ".gz"
- #~(#+(file-append gzip "/bin/gzip") "-9n"))
+ #~(list #+(file-append gzip "/bin/gzip") "-9n"))
(compressor "lzip" ".lz"
- #~(#+(file-append lzip "/bin/lzip") "-9"))
+ #~(list #+(file-append lzip "/bin/lzip") "-9"))
(compressor "xz" ".xz"
- #~(#+(file-append xz "/bin/xz") "-e"))
+ #~(append (list #+(file-append xz "/bin/xz")
+ "-e")
+ (%xz-parallel-args)))
(compressor "bzip2" ".bz2"
- #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
+ #~(list #+(file-append bzip2 "/bin/bzip2") "-9"))
(compressor "zstd" ".zst"
;; The default level 3 compresses better than gzip in a
;; fraction of the time, while the highest level 19
;; (de)compresses more slowly and worse than xz.
- #~(#+(file-append zstd "/bin/zstd") "-3"))
+ #~(list #+(file-append zstd "/bin/zstd") "-3"))
(compressor "none" "" #f)))
;; This one is only for use in this module, so don't put it in %compressors.
(define bootstrap-xz
(compressor "bootstrap-xz" ".xz"
- #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e")))
+ #~(append (list #+(file-append %bootstrap-coreutils&co "/bin/xz")
+ "-e")
+ (%xz-parallel-args))))
(define (lookup-compressor name)
"Return the compressor object called NAME. Error out if it could not be
@@ -283,7 +290,7 @@ added to the pack."
#+@(if (compressor-command compressor)
#~("-I"
(string-join
- '#+(compressor-command compressor)))
+ #+(compressor-command compressor)))
#~())
"--format=gnu"
@@ -556,11 +563,13 @@ the image."
,@(source-module-closure
`((guix docker)
(guix build store-copy)
+ (guix build utils) ;for %xz-parallel-args
(guix profiles)
(guix search-paths))
#:select? not-config?))
#~(begin
(use-modules (guix docker) (guix build store-copy)
+ (guix build utils)
(guix profiles) (guix search-paths)
(srfi srfi-1) (srfi srfi-19)
(ice-9 match))
@@ -617,7 +626,7 @@ the image."
#~(list (string-append #$profile "/"
#$entry-point)))
#:extra-files directives
- #:compressor '#+(compressor-command compressor)
+ #:compressor #+(compressor-command compressor)
#:creation-time (make-time time-utc 0 1))))))
(gexp->derivation (string-append name ".tar"
diff --git a/guix/store/roots.scm b/guix/store/roots.scm
index 58653507f8..222f69c5c0 100644
--- a/guix/store/roots.scm
+++ b/guix/store/roots.scm
@@ -50,7 +50,7 @@
(define (gc-roots)
"Return the list of garbage collector roots (\"GC roots\"). This includes
-\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that
+\"regular\" roots found in %GC-ROOTS-DIRECTORY as well as indirect roots that
are user-controlled symlinks stored anywhere on the file system."
(define (regular? file)
(match file
diff --git a/guix/tests.scm b/guix/tests.scm
index fc3d521163..da75835099 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -20,12 +20,13 @@
#:use-module ((guix config) #:select (%storedir %localstatedir))
#:use-module (guix store)
#:use-module (guix derivations)
+ #:use-module (guix gexp)
#: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 ((guix build utils) #:select (mkdir-p compressor))
#:use-module ((gcrypt hash) #:hide (sha256))
#:use-module (guix build-system gnu)
#:use-module (gnu packages base)
@@ -60,7 +61,9 @@
dummy-package
dummy-origin
- gnu-make-for-tests))
+ gnu-make-for-tests
+
+ test-file))
;;; Commentary:
;;;
@@ -435,6 +438,42 @@ default values, and with EXTRA-FIELDS set as specified."
(native-inputs '()) ;no need for 'pkg-config'
(inputs %bootstrap-inputs-for-tests))))
+
+;;;
+;;; Test utility procedures.
+
+(define (test-file store name content)
+ "Create a simple file in STORE with CONTENT (a string), compressed according
+to its file name extension. Return both its file name and its hash."
+ (let* ((ext (string-index-right name #\.))
+ (name-sans-ext (if ext
+ (string-take name (string-index-right name #\.))
+ name))
+ (comp (compressor name))
+ (command #~(if #+comp
+ (string-append #+%bootstrap-coreutils&co
+ "/bin/" #+comp)
+ #f))
+ (f (with-imported-modules '((guix build utils))
+ (computed-file name
+ #~(begin
+ (use-modules (guix build utils)
+ (rnrs io simple))
+ (with-output-to-file #+name-sans-ext
+ (lambda _
+ (format #t #+content)))
+ (when #+command
+ (invoke #+command #+name-sans-ext))
+ (copy-file #+name #$output)))))
+ (file-drv (run-with-store store (lower-object f)))
+ (file (derivation->output-path file-drv))
+ (file-drv-outputs (derivation-outputs file-drv))
+ (_ (build-derivations store (list file-drv)))
+ (file-hash (derivation-output-hash
+ (assoc-ref file-drv-outputs "out"))))
+ (values file file-hash)))
+
+;;;
;; Local Variables:
;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
diff --git a/guix/utils.scm b/guix/utils.scm
index a85e2f495c..edc3503c10 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -35,7 +36,9 @@
#:use-module (rnrs io ports) ;need 'port-position' etc.
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization)
- #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
+ #:use-module ((guix build utils)
+ #:select (dump-port mkdir-p delete-file-recursively
+ call-with-temporary-output-file %xz-parallel-args))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (guix diagnostics) ;<location>, &error-location, etc.
#:use-module (ice-9 format)
@@ -59,7 +62,9 @@
&fix-hint
fix-hint?
- condition-fix-hint)
+ condition-fix-hint
+
+ call-with-temporary-output-file)
#:export (strip-keyword-arguments
default-keyword-arguments
substitute-keyword-arguments
@@ -97,7 +102,6 @@
tarball-sans-extension
compressed-file?
switch-symlinks
- call-with-temporary-output-file
call-with-temporary-directory
with-atomic-file-output
@@ -225,7 +229,7 @@ a symbol such as 'xz."
(match compression
((or #f 'none) (values input '()))
('bzip2 (filtered-port `(,%bzip2 "-dc") input))
- ('xz (filtered-port `(,%xz "-dc") input))
+ ('xz (filtered-port `(,%xz "-dc" ,@(%xz-parallel-args)) input))
('gzip (filtered-port `(,%gzip "-dc") input))
('lzip (values (lzip-port 'make-lzip-input-port input)
'()))
@@ -233,6 +237,18 @@ a symbol such as 'xz."
'()))
(_ (error "unsupported compression scheme" compression))))
+(define (compressed-port compression input)
+ "Return an input port where INPUT is compressed according to COMPRESSION,
+a symbol such as 'xz."
+ (match compression
+ ((or #f 'none) (values input '()))
+ ('bzip2 (filtered-port `(,%bzip2 "-c") input))
+ ('xz (filtered-port `(,%xz "-c" ,@(%xz-parallel-args)) input))
+ ('gzip (filtered-port `(,%gzip "-c") input))
+ ('lzip (values (lzip-port 'make-lzip-input-port/compressed input)
+ '()))
+ (_ (error "unsupported compression scheme" compression))))
+
(define (call-with-decompressed-port compression port proc)
"Call PROC with a wrapper around PORT, a file port, that decompresses data
read from PORT according to COMPRESSION, a symbol such as 'xz."
@@ -286,7 +302,8 @@ program--e.g., '(\"--fast\")."
(match compression
((or #f 'none) (values output '()))
('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output))
- ('xz (filtered-output-port `(,%xz "-c" ,@options) output))
+ ('xz (filtered-output-port `(,%xz "-c" ,@(%xz-parallel-args)
+ ,@options) output))
('gzip (filtered-output-port `(,%gzip "-c" ,@options) output))
('lzip (values (lzip-port 'make-lzip-output-port output)
'()))
@@ -719,22 +736,6 @@ REPLACEMENT."
(substring str start index)
pieces))))))))
-(define (call-with-temporary-output-file proc)
- "Call PROC with a name of a temporary file and open output port to that
-file; close the file and delete it when leaving the dynamic extent of this
-call."
- (let* ((directory (or (getenv "TMPDIR") "/tmp"))
- (template (string-append directory "/guix-file.XXXXXX"))
- (out (mkstemp! template)))
- (dynamic-wind
- (lambda ()
- #t)
- (lambda ()
- (proc template out))
- (lambda ()
- (false-if-exception (close out))
- (false-if-exception (delete-file template))))))
-
(define (call-with-temporary-directory proc)
"Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-11 00:45:18 +0000