diff options
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/ant-build-system.scm | 3 | ||||
-rw-r--r-- | guix/build/cargo-build-system.scm | 5 | ||||
-rw-r--r-- | guix/build/clojure-build-system.scm | 3 | ||||
-rw-r--r-- | guix/build/debug-link.scm | 12 | ||||
-rw-r--r-- | guix/build/dub-build-system.scm | 3 | ||||
-rw-r--r-- | guix/build/dune-build-system.scm | 4 | ||||
-rw-r--r-- | guix/build/emacs-utils.scm | 13 | ||||
-rw-r--r-- | guix/build/java-utils.scm | 3 | ||||
-rw-r--r-- | guix/build/kconfig.scm | 181 | ||||
-rw-r--r-- | guix/build/pyproject-build-system.scm | 381 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 9 |
11 files changed, 597 insertions, 20 deletions
diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index fae1b47ec5..d29912bf59 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -19,7 +19,6 @@ (define-module (guix build ant-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (sxml simple) #:use-module (ice-9 match) @@ -201,7 +200,7 @@ dependencies of this jar file." repack them. This is necessary to ensure that archives are reproducible." (define (repack-archive jar) (format #t "repacking ~a\n" jar) - (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) + (let* ((dir (mkdtemp "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF"))) (with-directory-excursion dir (invoke "jar" "xf" jar)) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 0a95672b00..41766228c2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> -;;; Copyright © 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019-2022 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Marius Bakke <marius@gnu.org> ;;; @@ -135,7 +135,8 @@ Cargo.toml file present at its root." ;; so that we can generate any cargo checksums. ;; The --strip-components argument is needed to prevent creating ;; an extra directory within `crate-dir`. - (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1"))))) + (format #t "Unpacking ~a~%" name) + (invoke "tar" "xf" path "-C" crate-dir "--strip-components" "1"))))) inputs) ;; Configure cargo to actually use this new directory. diff --git a/guix/build/clojure-build-system.scm b/guix/build/clojure-build-system.scm index cacbefb386..2cb153b6db 100644 --- a/guix/build/clojure-build-system.scm +++ b/guix/build/clojure-build-system.scm @@ -22,7 +22,6 @@ ant-build)) #:use-module (guix build clojure-utils) #:use-module (guix build java-utils) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -129,7 +128,7 @@ and repack them. This is necessary to ensure that archives are reproducible." ;; Note: .class files need to be strictly newer than source files, ;; otherwise the Clojure compiler will recompile sources. (let* ((early-1980 315619200) ; 1980-01-02 UTC - (dir (mkdtemp! "jar-contents.XXXXXX")) + (dir (mkdtemp "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF"))) (with-directory-excursion dir (invoke "jar" "xf" jar)) diff --git a/guix/build/debug-link.scm b/guix/build/debug-link.scm index f3284f74c4..80941df2fc 100644 --- a/guix/build/debug-link.scm +++ b/guix/build/debug-link.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -175,7 +175,15 @@ directories." outputs)) (append-map (lambda (directory) - (filter elf-file? + (filter (lambda (file) + (catch 'system-error + (lambda () + (elf-file? file)) + (lambda args + ;; FILE might be a dangling symlink. + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) (with-error-to-port (%make-void-port "w") (lambda () (find-files directory))))) diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm index 9ee0433ffd..c9bc2af3a5 100644 --- a/guix/build/dub-build-system.scm +++ b/guix/build/dub-build-system.scm @@ -20,7 +20,6 @@ (define-module (guix build dub-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) @@ -52,7 +51,7 @@ to do this (instead of just using /gnu/store as the directory) because we want to hide the libraries in subdirectories lib/dub/... instead of polluting the user's profile root." - (let* ((dir (mkdtemp! "/tmp/dub.XXXXXX")) + (let* ((dir (mkdtemp "/tmp/dub.XXXXXX")) (vendor-dir (string-append dir "/vendor"))) (setenv "HOME" dir) (mkdir vendor-dir) diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index e9ccc71057..f311cd37f1 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -42,13 +42,13 @@ build-flags))) #t) -(define* (check #:key (test-flags '()) (test-target "test") tests? +(define* (check #:key (test-flags '()) tests? (jbuild? #f) (package #f) (dune-release-flags '()) #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "runtest" test-target + (apply invoke program "runtest" (append (if package (list "-p" package) dune-release-flags) test-flags)))) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index b2280ae70c..850b1f5f2a 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -75,10 +75,15 @@ true, evaluate using dynamic scoping." (string-append "--visit=" file) (string-append "--eval=" (expr->string expr)))) -(define (emacs-batch-disable-compilation file) +(define* (emacs-batch-disable-compilation file #:key native?) + "Disable byte compilation for FILE. +If NATIVE?, only disable native compilation." (emacs-batch-edit-file file - '(progn - (add-file-local-variable 'no-byte-compile t) + `(progn + (add-file-local-variable ',(if native? + 'no-native-compile + 'no-byte-compile) + t) (basic-save-buffer)))) (define-condition-type &emacs-batch-error &error @@ -220,7 +225,7 @@ useful to avoid double quotes being added when the replacement is provided as a string." ((_ file (variable replacement modifier ...) ...) (emacs-substitute-sexps file - ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\>") + ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\_>") replacement modifier ...) ...)))) diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm index 87c3ac43c9..6025c81667 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -21,7 +21,6 @@ (define-module (guix build java-utils) #:use-module (guix build utils) - #:use-module (guix build syscalls) #:use-module (guix build maven pom) #:use-module (guix build maven plugin) #:use-module (ice-9 match) @@ -83,7 +82,7 @@ fetched." "Unpack the jar archive, add the pom file, and repack it. This is necessary to ensure that maven can find dependencies." (format #t "adding ~a to ~a\n" pom-file jar) - (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) + (let* ((dir (mkdtemp "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF")) (pom (get-pom pom-file)) (artifact (pom-artifactid pom)) diff --git a/guix/build/kconfig.scm b/guix/build/kconfig.scm new file mode 100644 index 0000000000..0c9ef6baff --- /dev/null +++ b/guix/build/kconfig.scm @@ -0,0 +1,181 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de> +;;; +;;; 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 kconfig) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (modify-defconfig + verify-config)) + +;; Commentary: +;; +;; Builder-side code to modify configurations for the Kconfig build system as +;; used by Linux and U-Boot. +;; +;; Code: + +(define (pair->config-string pair) + "Convert a PAIR back to a config-string." + (let* ((key (first pair)) + (value (cdr pair))) + (if (string? key) + (if (string? value) + (string-append key "=" value) + (string-append "# " key " is not set")) + value))) + +(define (config-string->pair config-string) + "Parse a configuration string like \"CONFIG_EXAMPLE=m\" into a key-value pair. +An error is thrown for invalid configurations. + +\"CONFIG_A=y\" -> '(\"CONFIG_A\" . \"y\") +\"CONFIG_B=\\\"\\\"\" -> '(\"CONFIG_B\" . \"\\\"\\\"\") +\"CONFIG_C=\" -> '(\"CONFIG_C\" . \"\") +\"# CONFIG_E is not set\" -> '(\"CONFIG_E\" . #f) +\"CONFIG_D\" -> '(\"CONFIG_D\" . #f) +\"# Any comment\" -> '(#f . \"# Any comment\") +\"\" -> '(#f . \"\") +\"# CONFIG_E=y\" -> (error \"Invalid configuration\") +\"CONFIG_E is not set\" -> (error \"Invalid configuration\") +\"Anything else\" -> (error \"Invalid configuration\")" + (define config-regexp + (make-regexp + ;; (match:substring (string-match "=(.*)" "=") 1) returns "", but the + ;; pattern "=(.+)?" makes it return #f instead. From a "CONFIG_A=" we like + ;; to get "", which later emits "CONFIG_A=" again. + (string-append "^ *(#[\\t ]*)?(CONFIG_[a-zA-Z0-9_]+)([\\t ]*=" + "[\\t ]*(.*)|([\\t ]+is[\\t ]+not[\\t ]+set))?$"))) + + (define config-comment-regexp + (make-regexp "^([\\t ]*(#.*)?)$")) + + (let ((match (regexp-exec config-regexp (string-trim-right config-string)))) + (if match + (let* ((comment (match:substring match 1)) + (key (match:substring match 2)) + (unset (match:substring match 5)) + (value (and (not comment) + (not unset) + (match:substring match 4)))) + (if (eq? (not comment) (not unset)) + ;; The key is uncommented and set or commented and unset. + (cons key value) + ;; The key is set or unset ambigiously. + (error (format #f "invalid configuration, did you mean \"~a\"?" + (pair->config-string (cons key #f))) + config-string))) + ;; This is not a valid or ambigious config-string, but maybe a + ;; comment. + (if (regexp-exec config-comment-regexp config-string) + (cons #f config-string) ;keep valid comments + (error "Invalid configuration" config-string))))) + +(define (defconfig->alist defconfig) + "Convert the content of a DEFCONFIG (or .config) file into an alist." + (with-input-from-file defconfig + (lambda () + (let loop ((alist '()) + (line (read-line))) + (if (eof-object? line) + ;; Building the alist is done, now check for duplicates. + ;; Note: the filter invocation is used to remove comments. + (let loop ((keys (map first (filter first alist))) + (duplicates '())) + (if (null? keys) + ;; The search for duplicates is done. + ;; Return the alist or throw an error on duplicates. + (if (null? duplicates) + (reverse alist) + (error + (format #f "duplicate configurations in ~a" defconfig) + (reverse duplicates))) + ;; Continue the search for duplicates. + (loop (cdr keys) + (if (member (first keys) (cdr keys)) + (cons (first keys) duplicates) + duplicates)))) + ;; Build the alist. + (loop (cons (config-string->pair line) alist) + (read-line))))))) + +(define (modify-defconfig defconfig configs) + "This function can modify a given DEFCONFIG (or .config) file by adding, +changing or removing the list of strings in CONFIGS. This allows customization +of Kconfig based projects like the kernel Linux or the bootloader 'Das U-Boot'. + +These are examples for CONFIGS to add, change or remove configurations to/from +DEFCONFIG: + +'(\"CONFIG_A=\\\"a\\\"\" + \"CONFIG_B=0\" + \"CONFIG_C=y\" + \"CONFIG_D=m\" + \"CONFIG_E=\" + \"# CONFIG_G is not set\" + ;; For convenience this abbrevation can be used for not set configurations. + \"CONFIG_F\") + +Instead of a list, CONFIGS can be a string with one configuration per line." + ;; Normalize CONFIGS to a list of configuration pairs. + (let* ((config-pairs (map config-string->pair + (append-map (cut string-split <> #\newline) + (if (string? configs) + (list configs) + configs)))) + ;; Generate a blocklist from all valid keys in config-pairs. + (blocklist (delete #f (map first config-pairs))) + ;; Generate an alist from the defconfig without the keys in blocklist. + (filtered-defconfig-pairs (remove (lambda (pair) + (member (first pair) blocklist)) + (defconfig->alist defconfig)))) + (with-output-to-file defconfig + (lambda () + (for-each (lambda (pair) + (display (pair->config-string pair)) + (newline)) + (append filtered-defconfig-pairs config-pairs)))))) + +(define (verify-config config defconfig) + "Verify that the CONFIG file contains all configurations from the DEFCONFIG +file. When the verification fails, raise an error with the mismatching keys +and their values." + (let* ((config-pairs (defconfig->alist config)) + (defconfig-pairs (defconfig->alist defconfig)) + (mismatching-pairs + (remove (lambda (pair) + ;; Remove all configurations, whose values are #f and + ;; whose keys are not in config-pairs, as not in + ;; config-pairs means unset, ... + (and (not (cdr pair)) + (not (assoc-ref config-pairs (first pair))))) + ;; ... from the defconfig-pairs different to config-pairs. + (lset-difference equal? + ;; Remove comments by filtering with first. + (filter first defconfig-pairs) + config-pairs)))) + (unless (null? mismatching-pairs) + (error (format #f "Mismatching configurations in ~a and ~a" + config defconfig) + (map (lambda (mismatching-pair) + (let* ((key (first mismatching-pair)) + (defconfig-value (cdr mismatching-pair)) + (config-value (assoc-ref config-pairs key))) + (cons key (list (list config-value defconfig-value))))) + mismatching-pairs))))) diff --git a/guix/build/pyproject-build-system.scm b/guix/build/pyproject-build-system.scm new file mode 100644 index 0000000000..c69ccc9d64 --- /dev/null +++ b/guix/build/pyproject-build-system.scm @@ -0,0 +1,381 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> +;;; Copyright © 2022 Marius Bakke <marius@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 pyproject-build-system) + #:use-module ((guix build python-build-system) #:prefix python:) + #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (%standard-phases + add-installed-pythonpath + site-packages + python-version + pyproject-build)) + +;;; Commentary: +;;; +;;; PEP 517-compatible build system for Python packages. +;;; +;;; PEP 517 mandates the use of a TOML file called pyproject.toml at the +;;; project root, describing build and runtime dependencies, as well as the +;;; build system, which can be different from setuptools. This module uses +;;; that file to extract the build system used and call its wheel-building +;;; entry point build_wheel (see 'build). setuptools’ wheel builder is +;;; used as a fallback if either no pyproject.toml exists or it does not +;;; declare a build-system. It supports config_settings through the +;;; standard #:configure-flags argument. +;;; +;;; This wheel, which is just a ZIP file with a file structure defined +;;; by PEP 427 (https://www.python.org/dev/peps/pep-0427/), is then unpacked +;;; and its contents are moved to the appropriate locations in 'install. +;;; +;;; Then entry points, as defined by the PyPa Entry Point Specification +;;; (https://packaging.python.org/specifications/entry-points/) are read +;;; from a file called entry_points.txt in the package’s site-packages +;;; subdirectory and scripts are written to bin/. These are not part of a +;;; wheel and expected to be created by the installing utility. +;;; TODO: Add support for PEP-621 entry points. +;;; +;;; Caveats: +;;; - There is no support for in-tree build backends. +;;; +;;; Code: +;;; + +;; Re-export these variables from python-build-system as many packages +;; rely on these. +(define python-version python:python-version) +(define site-packages python:site-packages) +(define add-installed-pythonpath python:add-installed-pythonpath) + +;; Base error type. +(define-condition-type &python-build-error &error python-build-error?) + +;; Raised when 'check cannot find a valid test system in the inputs. +(define-condition-type &test-system-not-found &python-build-error + test-system-not-found?) + +;; Raised when multiple wheels are created by 'build. +(define-condition-type &cannot-extract-multiple-wheels &python-build-error + cannot-extract-multiple-wheels?) + +;; Raised, when no wheel has been built by the build system. +(define-condition-type &no-wheels-built &python-build-error no-wheels-built?) + +(define* (build #:key outputs build-backend configure-flags #:allow-other-keys) + "Build a given Python package." + + (define (pyproject.toml->build-backend file) + "Look up the build backend in a pyproject.toml file." + (call-with-input-file file + (lambda (in) + (let loop + ((line (read-line in 'concat))) + (if (eof-object? line) #f + (let ((m (string-match "build-backend = [\"'](.+)[\"']" line))) + (if m + (match:substring m 1) + (loop (read-line in 'concat))))))))) + + (let* ((wheel-output (assoc-ref outputs "wheel")) + (wheel-dir (if wheel-output wheel-output "dist")) + ;; There is no easy way to get data from Guile into Python via + ;; s-expressions, but we have JSON serialization already, which Python + ;; also supports out-of-the-box. + (config-settings (call-with-output-string + (cut write-json configure-flags <>))) + ;; python-setuptools’ default backend supports setup.py *and* + ;; pyproject.toml. Allow overriding this automatic detection via + ;; build-backend. + (auto-build-backend (if (file-exists? "pyproject.toml") + (pyproject.toml->build-backend + "pyproject.toml") + #f)) + ;; Use build system detection here and not in importer, because a) we + ;; have alot of legacy packages and b) the importer cannot update arbitrary + ;; fields in case a package switches its build system. + (use-build-backend (or build-backend + auto-build-backend + "setuptools.build_meta"))) + (format #t + "Using '~a' to build wheels, auto-detected '~a', override '~a'.~%" + use-build-backend auto-build-backend build-backend) + (mkdir-p wheel-dir) + ;; Call the PEP 517 build function, which drops a .whl into wheel-dir. + (invoke "python" "-c" + "import sys, importlib, json +config_settings = json.loads (sys.argv[3]) +builder = importlib.import_module(sys.argv[1]) +builder.build_wheel(sys.argv[2], config_settings=config_settings)" + use-build-backend + wheel-dir + config-settings))) + +(define* (check #:key tests? test-backend test-flags #:allow-other-keys) + "Run the test suite of a given Python package." + (if tests? + ;; Unfortunately with PEP 517 there is no common method to specify test + ;; systems. Guess test system based on inputs instead. + (let* ((pytest (which "pytest")) + (nosetests (which "nosetests")) + (nose2 (which "nose2")) + (have-setup-py (file-exists? "setup.py")) + (use-test-backend + (or test-backend + ;; Prefer pytest + (if pytest 'pytest #f) + (if nosetests 'nose #f) + (if nose2 'nose2 #f) + ;; But fall back to setup.py, which should work for most + ;; packages. XXX: would be nice not to depend on setup.py here? + ;; fails more often than not to find any tests at all. Maybe + ;; we can run `python -m unittest`? + (if have-setup-py 'setup.py #f)))) + (format #t "Using ~a~%" use-test-backend) + (match use-test-backend + ('pytest + (apply invoke pytest "-vv" test-flags)) + ('nose + (apply invoke nosetests "-v" test-flags)) + ('nose2 + (apply invoke nose2 "-v" "--pretty-assert" test-flags)) + ('setup.py + (apply invoke "python" "setup.py" + (if (null? test-flags) + '("test" "-v") + test-flags))) + ;; The developer should explicitly disable tests in this case. + (else (raise (condition (&test-system-not-found)))))) + (format #t "test suite not run~%"))) + +(define* (install #:key inputs outputs #:allow-other-keys) + "Install a wheel file according to PEP 427" + ;; See https://www.python.org/dev/peps/pep-0427/#installing-a-wheel-distribution-1-0-py32-none-any-whl + (let ((site-dir (site-packages inputs outputs)) + (python (assoc-ref inputs "python")) + (out (assoc-ref outputs "out"))) + (define (extract file) + "Extract wheel (ZIP file) into site-packages directory" + ;; Use Python’s zipfile to avoid extra dependency + (invoke "python" "-m" "zipfile" "-e" file site-dir)) + + (define python-hashbang + (string-append "#!" python "/bin/python")) + + (define* (merge-directories source destination + #:optional (post-move #f)) + "Move all files in SOURCE into DESTINATION, merging the two directories." + (format #t "Merging directory ~a into ~a~%" source destination) + (for-each (lambda (file) + (format #t "~a/~a -> ~a/~a~%" + source file destination file) + (mkdir-p destination) + (rename-file (string-append source "/" file) + (string-append destination "/" file)) + (when post-move + (post-move file))) + (scandir source + (negate (cut member <> '("." ".."))))) + (rmdir source)) + + (define (expand-data-directory directory) + "Move files from all .data subdirectories to their respective\ndestinations." + ;; Python’s distutils.command.install defines this mapping from source to + ;; destination mapping. + (let ((source (string-append directory "/scripts")) + (destination (string-append out "/bin"))) + (when (file-exists? source) + (merge-directories source destination + (lambda (f) + (let ((dest-path (string-append destination + "/" f))) + (chmod dest-path #o755) + ;; PEP 427 recommends that installers rewrite + ;; this odd shebang. + (substitute* dest-path + (("#!python") + python-hashbang))))))) + ;; Data can be contained in arbitrary directory structures. Most + ;; commonly it is used for share/. + (let ((source (string-append directory "/data")) + (destination out)) + (when (file-exists? source) + (merge-directories source destination))) + (let* ((distribution (car (string-split (basename directory) #\-))) + (source (string-append directory "/headers")) + (destination (string-append out "/include/python" + (python-version python) + "/" distribution))) + (when (file-exists? source) + (merge-directories source destination)))) + + (define (list-directories base predicate) + ;; Cannot use find-files here, because it’s recursive. + (scandir base + (lambda (name) + (let ((stat (lstat (string-append base "/" name)))) + (and (not (member name '("." ".."))) + (eq? (stat:type stat) 'directory) + (predicate name stat)))))) + + (let* ((wheel-output (assoc-ref outputs "wheel")) + (wheel-dir (if wheel-output wheel-output "dist")) + (wheels (map (cut string-append wheel-dir "/" <>) + (scandir wheel-dir + (cut string-suffix? ".whl" <>))))) + (cond + ((> (length wheels) 1) + ;; This code does not support multiple wheels yet, because their + ;; outputs would have to be merged properly. + (raise (condition (&cannot-extract-multiple-wheels)))) + ((= (length wheels) 0) + (raise (condition (&no-wheels-built))))) + (for-each extract wheels)) + (let ((datadirs (map (cut string-append site-dir "/" <>) + (list-directories site-dir + (file-name-predicate "\\.data$"))))) + (for-each (lambda (directory) + (expand-data-directory directory) + (rmdir directory)) datadirs)))) + +(define* (compile-bytecode #:key inputs outputs #:allow-other-keys) + "Compile installed byte-code in site-packages." + (let* ((site-dir (site-packages inputs 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))))))) + (if <3.7? + ;; These versions don’t have the hash invalidation modes and do + ;; not produce reproducible bytecode files. + (format #t "Skipping bytecode compilation for Python version ~a < 3.7~%" + (python-version python)) + (invoke "python" "-m" "compileall" + "--invalidation-mode=unchecked-hash" site-dir)))) + +(define* (create-entrypoints #:key inputs outputs #:allow-other-keys) + "Implement Entry Points Specification +(https://packaging.python.org/specifications/entry-points/) by PyPa, +which creates runnable scripts in bin/ from entry point specification +file entry_points.txt. This is necessary, because wheels do not contain +these binaries and installers are expected to create them." + + (define (entry-points.txt->entry-points file) + "Specialized parser for Python configfile-like files, in particular +entry_points.txt. Returns a list of console_script and gui_scripts +entry points." + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in)) + (inside #f) + (result '())) + (if (eof-object? line) + result + (let* ((group-match (string-match "^\\[(.+)\\]$" line)) + (group-name (if group-match + (match:substring group-match 1) + #f)) + (next-inside (if (not group-name) + inside + (or (string=? group-name + "console_scripts") + (string=? group-name "gui_scripts")))) + (item-match (string-match + "^([^ =]+)\\s*=\\s*([^:]+):(.+)$" line))) + (if (and inside item-match) + (loop (read-line in) + next-inside + (cons (list (match:substring item-match 1) + (match:substring item-match 2) + (match:substring item-match 3)) + result)) + (loop (read-line in) next-inside result)))))))) + + (define (create-script path name module function) + "Create a Python script from an entry point’s NAME, MODULE and FUNCTION +and return write it to PATH/NAME." + (let ((interpreter (which "python")) + (file-path (string-append path "/" name))) + (format #t "Creating entry point for '~a.~a' at '~a'.~%" + module function file-path) + (call-with-output-file file-path + (lambda (port) + ;; Technically the script could also include search-paths, + ;; but having a generic 'wrap phases also handles manually + ;; written entry point scripts. + (format port "#!~a +# Auto-generated entry point script. +import sys +import ~a as mod +sys.exit (mod.~a ())~%" interpreter module function))) + (chmod file-path #o755))) + + (let* ((site-dir (site-packages inputs outputs)) + (out (assoc-ref outputs "out")) + (bin-dir (string-append out "/bin")) + (entry-point-files (find-files site-dir "^entry_points.txt$"))) + (mkdir-p bin-dir) + (for-each (lambda (f) + (for-each (lambda (ep) + (apply create-script + (cons bin-dir ep))) + (entry-points.txt->entry-points f))) + entry-point-files))) + +(define* (set-SOURCE-DATE-EPOCH* #:rest _) + "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/." + ;; Use a post-1980 timestamp because the Zip format used in wheels do + ;; not support timestamps before 1980. + (setenv "SOURCE_DATE_EPOCH" "315619200")) + +(define %standard-phases + ;; The build phase only builds C extensions and copies the Python sources, + ;; 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 python:%standard-phases + (replace 'set-SOURCE-DATE-EPOCH set-SOURCE-DATE-EPOCH*) + (replace 'build build) + (replace 'install install) + (delete 'check) + ;; Must be before tests, so they can use installed packages’ entry points. + (add-before 'wrap 'create-entrypoints create-entrypoints) + (add-after 'wrap 'check check) + (add-before 'check 'compile-bytecode compile-bytecode))) + +(define* (pyproject-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Python package, applying all of PHASES in order." + (apply python:python-build #:inputs inputs #:phases phases args)) + +;;; pyproject-build-system.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index e081aaca44..0358960ff5 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,10 +46,12 @@ MS_NOEXEC MS_REMOUNT MS_NOATIME + MS_NODIRATIME MS_STRICTATIME MS_RELATIME MS_BIND MS_MOVE + MS_REC MS_SHARED MS_LAZYTIME MNT_FORCE @@ -542,8 +544,10 @@ the last argument of `mknod'." (define MS_NOEXEC 8) (define MS_REMOUNT 32) (define MS_NOATIME 1024) +(define MS_NODIRATIME 2048) (define MS_BIND 4096) (define MS_MOVE 8192) +(define MS_REC 16384) (define MS_SHARED 1048576) (define MS_RELATIME 2097152) (define MS_STRICTATIME 16777216) @@ -645,7 +649,8 @@ the remaining unprocessed options." ("nodev" => MS_NODEV) ("noexec" => MS_NOEXEC) ("relatime" => MS_RELATIME) - ("noatime" => MS_NOATIME))))))) + ("noatime" => MS_NOATIME) + ("nodiratime" => MS_NODIRATIME))))))) (define (mount-flags mount) "Return the mount flags of MOUNT, a <mount> record, as an inclusive or of @@ -878,7 +883,7 @@ fdatasync(2) on the underlying file descriptor." (ST_NODEV => MS_NODEV) (ST_NOEXEC => MS_NOEXEC) (ST_NOATIME => MS_NOATIME) - (ST_NODIRATIME => 0) ;FIXME + (ST_NODIRATIME => MS_NODIRATIME) (ST_RELATIME => MS_RELATIME)))) (define-c-struct %statfs ;<bits/statfs.h> |