diff options
author | Efraim Flashner <efraim@flashner.co.il> | 2021-12-19 15:15:11 +0200 |
---|---|---|
committer | Efraim Flashner <efraim@flashner.co.il> | 2021-12-19 15:15:11 +0200 |
commit | 6ccf8ea81f95963c0b7f945648106576008ee105 (patch) | |
tree | f39f596e6c3e98ff1e9f1de0ad41c977e9dd37c1 /guix/build | |
parent | fcaed5b81e893f34d77527fbef389ca628ca882d (diff) | |
parent | 9f916d14765b00309c742fcbff0cfabdd10dcf05 (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/download.scm | 26 | ||||
-rw-r--r-- | guix/build/emacs-build-system.scm | 7 | ||||
-rw-r--r-- | guix/build/emacs-utils.scm | 2 | ||||
-rw-r--r-- | guix/build/glib-or-gtk-build-system.scm | 168 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 6 | ||||
-rw-r--r-- | guix/build/haskell-build-system.scm | 46 | ||||
-rw-r--r-- | guix/build/julia-build-system.scm | 84 | ||||
-rw-r--r-- | guix/build/linux-module-build-system.scm | 35 | ||||
-rw-r--r-- | guix/build/meson-build-system.scm | 18 | ||||
-rw-r--r-- | guix/build/minetest-build-system.scm | 25 | ||||
-rw-r--r-- | guix/build/po.scm | 117 | ||||
-rw-r--r-- | guix/build/qt-utils.scm | 8 | ||||
-rw-r--r-- | guix/build/renpy-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 97 | ||||
-rw-r--r-- | guix/build/union.scm | 7 |
15 files changed, 478 insertions, 170 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index c8ddadfdd4..7c310e94f1 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -36,7 +36,7 @@ #:use-module (srfi srfi-26) #:autoload (ice-9 ftw) (scandir) #:autoload (guix base16) (bytevector->base16-string) - #:autoload (guix swh) (swh-download-directory) + #:autoload (guix swh) (swh-download-directory %verify-swh-certificate?) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -646,6 +646,8 @@ and write the output to FILE." #:verify-certificate? verify-certificate? #:timeout timeout))) + (format #t "Retrieving Disarchive spec from ~a ...~%" + (uri->string uri)) (let ((specification (read port))) (close-port port) specification)))) @@ -674,10 +676,23 @@ and write the output to FILE." (match (fetch-specification uris) (#f (format #t "could not find its Disarchive specification~%") #f) - (spec (parameterize ((%disarchive-log-port (current-output-port))) + (spec (parameterize ((%disarchive-log-port (current-output-port)) + (%verify-swh-certificate? verify-certificate?)) (false-if-exception* (disarchive-assemble spec file #:resolver resolve)))))))) +(define (internet-archive-uri uri) + "Return a URI corresponding to an Internet Archive backup of URI, or #f if +URI does not denote a Web URI." + (and (memq (uri-scheme uri) '(http https)) + (let* ((now (time-utc->date (current-time time-utc))) + (date (date->string now "~Y~m~d~H~M~S"))) + ;; Note: the date in the URL can be anything and web.archive.org + ;; automatically redirects to the closest date. + (build-uri 'https #:host "web.archive.org" + #:path (string-append "/web/" date "/" + (uri->string uri)))))) + (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) @@ -769,7 +784,12 @@ otherwise simply ignore them." (setvbuf (current-error-port) 'line) - (let try ((uri (append uri content-addressed-uris))) + (let try ((uri (append uri content-addressed-uris + (match uri + ((first . _) + (or (and=> (internet-archive-uri first) list) + '())) + (() '()))))) (match uri ((uri tail ...) (or (fetch uri file) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index ba2c1b4aad..ab77e57f33 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -53,8 +53,7 @@ ;; These are the default inclusion/exclusion regexps for the install phase. (define %default-include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) -(define %default-exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$" - "^[^/]*tests?\\.el$")) +(define %default-exclude '("^\\.dir-locals\\.el$" "^[^/]*tests?\\.el$")) (define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack)) @@ -111,7 +110,7 @@ environment variable\n" source-directory)) (define* (build #:key outputs inputs #:allow-other-keys) "Compile .el files." - (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) + (let* ((emacs (search-input-file inputs "/bin/emacs")) (out (assoc-ref outputs "out"))) (setenv "SHELL" "sh") (parameterize ((%emacs emacs)) @@ -220,7 +219,7 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (define* (make-autoloads #:key outputs inputs #:allow-other-keys) "Generate the autoloads file." - (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) + (let* ((emacs (search-input-file inputs "/bin/emacs")) (out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (elpa-name (package-name->name+version elpa-name-ver)) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 5f7ba71244..64ef40e25a 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> -;;; Copyright © 2019 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index 8d3c3684d3..475a94ae4f 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases + %gdk-pixbuf-loaders-cache-file + generate-gdk-pixbuf-loaders-cache glib-or-gtk-build)) ;; Commentary: @@ -51,12 +54,24 @@ "Check for the existence of \"libdir/gtk-v.0\" in INPUTS. Return a list with all found directories." (let* ((version - (if (string-match "gtk\\+-3" - (or (assoc-ref inputs "gtk+") - (assoc-ref inputs "source") - "gtk+-3")) ; we default to version 3 - "3.0" - "2.0")) + (cond + ((string-match "gtk-4" + (or (assoc-ref inputs "gtk") + (assoc-ref inputs "source") + "")) + "4.0") + ((string-match "gtk\\+-3" + (or (assoc-ref inputs "gtk+") + (assoc-ref inputs "source") + "")) + "3.0") + ((string-match "gtk\\+-2" + (or (assoc-ref inputs "gtk+") + (assoc-ref inputs "source") + "")) + "2.0") + (else + "4.0"))) ; We default to version 4.0. (gtk-module (lambda (input prev) (let* ((in (match input @@ -144,68 +159,34 @@ add a dependency of that output on GLib and GTK+." (define (sh) (force %sh)) (define handle-output (match-lambda - ((output . directory) - (unless (member output glib-or-gtk-wrap-excluded-outputs) - (let* ((bindir (string-append directory "/bin")) - (libexecdir (string-append directory "/libexec")) - (bin-list (filter (negate wrapped-program?) - (append (find-files bindir ".*") - (find-files libexecdir ".*")))) - (datadirs (data-directories - (alist-cons output directory inputs))) - (gtk-mod-dirs (gtk-module-directories - (alist-cons output directory inputs))) - (gio-mod-dirs (gio-module-directories - (alist-cons output directory inputs))) - (data-env-var - (if (not (null? datadirs)) - `("XDG_DATA_DIRS" ":" prefix ,datadirs) - #f)) - (gtk-mod-env-var - (if (not (null? gtk-mod-dirs)) - `("GTK_PATH" ":" prefix ,gtk-mod-dirs) - #f)) - (gio-mod-env-var - (if (not (null? gio-mod-dirs)) - `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs) - #f))) - (cond - ((and data-env-var gtk-mod-env-var gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var - gtk-mod-env-var - gio-mod-env-var) - bin-list)) - ((and data-env-var gtk-mod-env-var (not gio-mod-env-var)) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var - gtk-mod-env-var) - bin-list)) - ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var - gio-mod-env-var) - bin-list)) - ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - gio-mod-env-var - gtk-mod-env-var) - bin-list)) - ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var)) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var) - bin-list)) - ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var)) - (for-each (cut wrap-program <> #:sh (sh) - gtk-mod-env-var) - bin-list)) - ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - gio-mod-env-var) - bin-list)))))))) - - (for-each handle-output outputs) - #t) + ((output . directory) + (unless (member output glib-or-gtk-wrap-excluded-outputs) + (let* ((bindir (string-append directory "/bin")) + (libexecdir (string-append directory "/libexec")) + (bin-list (filter (negate wrapped-program?) + (append (find-files bindir ".*") + (find-files libexecdir ".*")))) + (datadirs (data-directories + (alist-cons output directory inputs))) + (gtk-mod-dirs (gtk-module-directories + (alist-cons output directory inputs))) + (gio-mod-dirs (gio-module-directories + (alist-cons output directory inputs))) + (env-vars `(,@(if (not (null? datadirs)) + (list `("XDG_DATA_DIRS" ":" prefix ,datadirs)) + '()) + ,@(if (not (null? gtk-mod-dirs)) + (list `("GTK_PATH" ":" prefix ,gtk-mod-dirs)) + '()) + ,@(if (not (null? gio-mod-dirs)) + (list `("GIO_EXTRA_MODULES" ":" + prefix ,gio-mod-dirs)) + '())))) + (for-each (lambda (program) + (apply wrap-program program #:sh (sh) env-vars)) + bin-list)))))) + + (for-each handle-output outputs)) (define* (compile-glib-schemas #:key outputs #:allow-other-keys) "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas @@ -218,11 +199,58 @@ if needed." (not (file-exists? (string-append schemasdir "/gschemas.compiled")))) (invoke "glib-compile-schemas" schemasdir))))) - outputs) - #t) + outputs)) + +;; This file is to be generated by the +;; `generate-gdk-pixbuf-loaders-cache' build phase defined below. +(define %gdk-pixbuf-loaders-cache-file + "lib/gdk-pixbuf-2.0/2.10.0/loaders.cache") + +(define (generate-gdk-pixbuf-loaders-cache directories outputs) + "Generate the loaders.cache file used by gdk-pixbuf to locate the available +loaders among DIRECTORIES, and set the GDK_PIXBUF_MODULE_FILE environment +variable. The cache file is installed under OUTPUTS. Return the first cache +file name if one was created else #f." + (let* ((loaders (append-map + (cut find-files <> "^libpixbufloader-.*\\.so$") + directories)) + (outputs* (map (cut string-append <> "/" + %gdk-pixbuf-loaders-cache-file) + outputs)) + (loaders.cache (first outputs*)) + (loaders.cache-copies (cdr outputs*))) + (if (not (null? loaders)) + (begin + (mkdir-p (dirname loaders.cache)) + (setenv "GDK_PIXBUF_MODULE_FILE" loaders.cache) + (apply invoke "gdk-pixbuf-query-loaders" "--update-cache" loaders) + (for-each (lambda (f) + (mkdir-p (dirname f)) + (copy-file loaders.cache f)) + loaders.cache-copies) + loaders.cache) + #f))) + +(define* (generate-gdk-pixbuf-loaders-cache-file #:key inputs outputs + #:allow-other-keys) + "Build phase that Wraps the GENERATE-GDK-PIXBUF-LOADERS-CACHE procedure." + ;; Conditionally compute the cache file if the gdk-pixbuf command is + ;; available on PATH (it comes with gdk-pixbuf). + (when (which "gdk-pixbuf-query-loaders") + (let ((loaders.cache (generate-gdk-pixbuf-loaders-cache + (map cdr inputs) + (filter-map identity + (list + (assoc-ref outputs "out") + (assoc-ref outputs "bin") + (assoc-ref outputs "lib")))))) + (when loaders.cache + (format #t "GDK_PIXBUF_MODULE_FILE set to `~a'~%" loaders.cache))))) (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'generate-gdk-pixbuf-loaders-cache-file + generate-gdk-pixbuf-loaders-cache-file) (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas) (add-after 'install 'glib-or-gtk-wrap wrap-all-programs))) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 645d2fe680..4768ee8562 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -152,8 +152,10 @@ dependencies, so it should be self-contained." ;; Make sure we're building for the correct architecture and OS targets ;; that Guix targets. - (setenv "GOARCH" goarch) - (setenv "GOOS" goos) + (setenv "GOARCH" (or goarch + (getenv "GOHOSTARCH"))) + (setenv "GOOS" (or goos + (getenv "GOHOSTOS"))) (match goarch ("arm" (setenv "GOARM" "7")) diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 28253ce2f0..ef6cb316ee 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org> ;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,13 +64,14 @@ ((file-exists? "Setup.lhs") "Setup.lhs") (else - #f)))) + #f))) + (pkgdb (string-append "-package-db=" %tmp-db-dir))) (if setup-file (begin (format #t "running \"runhaskell Setup.hs\" with command ~s \ and parameters ~s~%" command params) - (apply invoke "runhaskell" setup-file command params)) + (apply invoke "runhaskell" pkgdb setup-file command params)) (error "no Setup.hs nor Setup.lhs found")))) (define* (configure #:key outputs inputs tests? (configure-flags '()) @@ -141,17 +143,6 @@ and parameters ~s~%" (find-files lib "\\.a$")))) #t) -(define (grep rx port) - "Given a regular-expression RX including a group, read from PORT until the -first match and return the content of the group." - (let ((line (read-line port))) - (if (eof-object? line) - #f - (let ((rx-result (regexp-exec rx line))) - (if rx-result - (match:substring rx-result 1) - (grep rx port)))))) - (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." (let* ((haskell (assoc-ref inputs "haskell")) @@ -173,15 +164,8 @@ first match and return the content of the group." "Generate the GHC package database." (let* ((haskell (assoc-ref inputs "haskell")) (name-version (strip-store-file-name haskell)) - (input-dirs (match inputs - (((_ . dir) ...) - dir) - (_ '()))) ;; Silence 'find-files' (see 'evaluate-search-paths') - (conf-dirs (with-null-error-port - (search-path-as-list - `(,(string-append "lib/" name-version)) - input-dirs #:pattern ".*\\.conf.d$"))) + (conf-dirs (search-path-as-string->list (getenv "GHC_PACKAGE_PATH"))) (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs))) (mkdir-p %tmp-db-dir) (for-each (lambda (file) @@ -233,6 +217,8 @@ given Haskell package." (if (not (vhash-assoc id seen)) (let ((dep-conf (string-append src "/" id ".conf")) (dep-conf* (string-append dest "/" id ".conf"))) + (when (not (file-exists? dep-conf)) + (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file))) (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead? (loop (vhash-cons id #t seen) (append lst (conf-depends dep-conf)))) @@ -241,12 +227,13 @@ given Haskell package." (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) - (name-verion (strip-store-file-name haskell)) + (name-version (strip-store-file-name haskell)) + (version (last (string-split name-version #\-))) (lib (string-append (or (assoc-ref outputs "lib") out) "/lib")) (config-dir (string-append lib - "/" name-verion + "/ghc-" version "/" name ".conf.d")) - (id-rx (make-regexp "^id: *(.*)$")) + (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) (config-file (string-append out "/" name ".conf")) (params (list (string-append "--gen-pkg-config=" config-file)))) @@ -254,8 +241,15 @@ given Haskell package." ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let ((config-file-name+id - (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (let* ((contents (call-with-input-file config-file read-string)) + (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1))) + + (when (or + (and + (string? config-file-name+id) + (string-null? config-file-name+id)) + (not config-file-name+id)) + (error (format #f "The package id for ~a is empty. This is a bug." config-file))) ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the ;; "haddock-interfaces" field and removing the optional "haddock-html" diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index d74acf2a05..b4e0044567 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,9 +22,11 @@ (define-module (guix build julia-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 popen) #:export (%standard-phases julia-create-package-toml julia-build)) @@ -37,7 +41,7 @@ (invoke "julia" "-e" code)) ;; subpath where we store the package content -(define %package-path "/share/julia/packages/") +(define %package-path "/share/julia/loadpath/") (define (project.toml->name file) "Look for Julia package name in the TOML file FILE (usually named @@ -51,6 +55,18 @@ Project.toml)." (if m (match:substring m 1) (loop (read-line in 'concat))))))))) +(define (project.toml->uuid file) + "Look for Julia package uuid in the TOML file FILE (usually named +Project.toml)." + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #f + (let ((m (string-match "uuid\\s*=\\s*\"(.*)\"" line))) + (if m (match:substring m 1) + (loop (read-line in 'concat))))))))) + (define* (install #:key source inputs outputs julia-package-name #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -59,8 +75,7 @@ Project.toml)." julia-package-name (project.toml->name "Project.toml"))))) (mkdir-p package-dir) - (copy-recursively (getcwd) package-dir)) - #t) + (copy-recursively (getcwd) package-dir))) (define* (precompile #:key source inputs outputs julia-package-name #:allow-other-keys) @@ -73,7 +88,7 @@ Project.toml)." (setenv "JULIA_DEPOT_PATH" builddir) ;; Add new package dir to the load path. (setenv "JULIA_LOAD_PATH" - (string-append builddir "packages/" ":" + (string-append builddir "loadpath/" ":" (or (getenv "JULIA_LOAD_PATH") ""))) ;; Actual precompilation: @@ -84,27 +99,63 @@ Project.toml)." ;; element of DEPOT_PATH. Once the cache file exists, this hack is not ;; needed anymore (like in the check phase). If the user install new ;; packages, those will be installed and precompiled in the home dir. - (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package))) - #t) + (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " + package)))) (define* (check #:key tests? source inputs outputs julia-package-name - #:allow-other-keys) + parallel-tests? #:allow-other-keys) (when tests? (let* ((out (assoc-ref outputs "out")) (package (or julia-package-name (project.toml->name "Project.toml"))) - (builddir (string-append out "/share/julia/"))) + (builddir (string-append out "/share/julia/")) + (job-count (if parallel-tests? + (parallel-job-count) + 1)) + ;; The --proc argument of Julia *adds* extra processors rather than + ;; specify the exact count to use, so zero must be specified to + ;; disable parallel processing... + (additional-procs (max 0 (1- job-count)))) ;; With a patch, SOURCE_DATE_EPOCH is honored (setenv "SOURCE_DATE_EPOCH" "1") (setenv "JULIA_DEPOT_PATH" builddir) (setenv "JULIA_LOAD_PATH" - (string-append builddir "packages/" ":" + (string-append builddir "loadpath/" ":" (or (getenv "JULIA_LOAD_PATH") ""))) + (setenv "JULIA_CPU_THREADS" (number->string job-count)) (setenv "HOME" "/tmp") - (invoke "julia" "--depwarn=yes" - (string-append builddir "packages/" - package "/test/runtests.jl")))) - #t) + (apply invoke "julia" + `("--depwarn=yes" + ,@(if parallel-tests? + ;; XXX: ... but '--procs' doesn't accept 0 as a valid + ;; value, so just omit the argument entirely. + (list (string-append "--procs=" + (number->string additional-procs))) + '()) + ,(string-append builddir "loadpath/" + package "/test/runtests.jl")))))) + +(define* (link-depot #:key source inputs outputs + julia-package-name julia-package-uuid #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (package-name (or + julia-package-name + (project.toml->name "Project.toml"))) + (package-dir (string-append out %package-path package-name)) + (uuid (or julia-package-uuid (project.toml->uuid "Project.toml"))) + (pipe (open-pipe* OPEN_READ "julia" "-e" + (format #f "using Pkg; +println(Base.version_slug(Base.UUID(\"~a\"), + Base.SHA1(Pkg.GitTools.tree_hash(\".\"))))" uuid))) + (slug (string-trim-right (get-string-all pipe)))) + ;; When installing a package, julia looks first at in the JULIA_DEPOT_PATH + ;; for a path like packages/PACKAGE/XXXX + ;; Where XXXX is a slug encoding the package UUID and SHA1 of the files + ;; Here we create a link with the correct path to enable julia to find the + ;; package + (mkdir-p (string-append out "/share/julia/packages/" package-name)) + (symlink package-dir (string-append out "/share/julia/packages/" + package-name "/" slug)))) (define (julia-create-package-toml outputs source name uuid version @@ -130,14 +181,14 @@ version = \"" version "\" (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n") f)) deps)) - (close-port f)) - #t) + (close-port f))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'check) ; tests must be run after installation (replace 'install install) (add-after 'install 'precompile precompile) + (add-after 'unpack 'link-depot link-depot) (add-after 'install 'check check) ;; TODO: In the future we could add a "system-image-generation" phase ;; where we use PackageCompiler.jl to speed up package loading times @@ -146,11 +197,12 @@ version = \"" version "\" (delete 'patch-usr-bin-file) (delete 'build))) -(define* (julia-build #:key inputs julia-package-name +(define* (julia-build #:key inputs julia-package-name julia-package-uuid (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given Julia package, applying all of PHASES in order." (apply gnu:gnu-build #:inputs inputs #:phases phases #:julia-package-name julia-package-name + #:julia-package-uuid julia-package-uuid args)) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 729ab6154f..18ccf7cd8b 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,7 @@ ;; ;; Code: -;; Copied from make-linux-libre's "configure" phase. +;; Similar to make-linux-libre's "configure" phase. (define* (configure #:key inputs target arch #:allow-other-keys) (setenv "KCONFIG_NOTIMESTAMP" "1") (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) @@ -42,23 +43,28 @@ (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")) (when target + ;; TODO? (setenv "EXTRA_VERSION" ,extra-version) + ;; TODO? kernel ".config". (setenv "CROSS_COMPILE" (string-append target "-")) (format #t "`CROSS_COMPILE' set to `~a'~%" - (getenv "CROSS_COMPILE"))) - ; TODO: (setenv "EXTRA_VERSION" ,extra-version) - ; TODO: kernel ".config". - #t) + (getenv "CROSS_COMPILE")))) -(define* (build #:key inputs make-flags (source-directory ".") #:allow-other-keys) +(define* (build #:key (make-flags '()) (parallel-build? #t) + (source-directory ".") + inputs + #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd) "/" source-directory) - (or make-flags '()))) + (string-append "M=" (canonicalize-path source-directory)) + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) -;; This block was copied from make-linux-libre--only took the "modules_install" -;; part. -(define* (install #:key make-flags (source-directory ".") +;; Similar to the "modules_install" part of make-linux-libre. +(define* (install #:key (make-flags '()) (parallel-build? #t) + (source-directory ".") inputs native-inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -68,7 +74,7 @@ (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd) "/" source-directory) + (string-append "M=" (canonicalize-path source-directory)) ;; Disable depmod because the Guix system's module directory ;; is an union of potentially multiple packages. It is not ;; possible to use depmod to usefully calculate a dependency @@ -79,7 +85,10 @@ (string-append "INSTALL_MOD_PATH=" out) "INSTALL_MOD_STRIP=1" "modules_install" - (or make-flags '())))) + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags)))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index cc2ba83889..61ce45367d 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,16 +64,17 @@ (number->string (parallel-job-count)) "1"))) -(define* (check #:key test-target parallel-tests? tests? +(define* (check #:key tests? test-options parallel-tests? #:allow-other-keys) - (setenv "MESON_TESTTHREADS" - (if parallel-tests? - (number->string (parallel-job-count)) - "1")) (if tests? - (invoke "ninja" test-target) - (format #t "test suite not run~%")) - #t) + (begin + (setenv "MESON_TESTTHREADS" + (if parallel-tests? + (number->string (parallel-job-count)) + "1")) + ;; Always provide "-t 0" to disable the 30 s default timeout. + (apply invoke "meson" "test" "--print-errorlogs" "-t" "0" test-options)) + (format #t "test suite not run~%"))) (define* (install #:rest args) (invoke "ninja" "install")) diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm index 5d7d8d2292..4a7a87ab83 100644 --- a/guix/build/minetest-build-system.scm +++ b/guix/build/minetest-build-system.scm @@ -23,6 +23,7 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (ice-9 exceptions) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module ((guix build copy-build-system) #:prefix copy:) #:export (%standard-phases @@ -40,7 +41,7 @@ ;; See <https://github.com/minetest/minetest/blob/master/doc/lua_api.txt> ;; for an incomple list of files that can be found in mods. #:include ("mod.conf" "modpack.conf" "settingtypes.txt" "depends.txt" - "description.txt") + "description.txt" "config.txt" "_config.txt") #:include-regexp (".lua$" ".png$" ".ogg$" ".obj$" ".b3d$" ".tr$" ".mts$")))) @@ -190,20 +191,24 @@ auth_backend = sqlite3 (define (stop? line) (and (string? line) (string-contains line "ACTION[Server]: singleplayer [127.0.0.1] joins game."))) - (let loop () - (match (read-line port) - ((? error? line) - (error "minetest raised an error: ~a" line)) - ((? stop?) + (let loop ((has-errors? #f)) + (match `(,(read-line port) ,has-errors?) + (((? error? line) _) + (display line) + (newline) + (loop #t)) + (((? stop?) #f) (kill pid SIGINT) (close-port port) (waitpid pid)) - ((? string? line) + (((? eof-object?) #f) + (error "minetest didn't start")) + (((or (? stop?) (? eof-object?)) #t) + (error "minetest raised an error")) + (((? string? line) has-error?) (display line) (newline) - (loop)) - ((? eof-object?) - (error "minetest didn't start")))))))) + (loop has-error?)))))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/po.scm b/guix/build/po.scm index eb9690ad1a..7f88164cd8 100644 --- a/guix/build/po.scm +++ b/guix/build/po.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2019, 2021 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -20,17 +20,23 @@ (define-module (guix build po) #:use-module (ice-9 match) #:use-module (ice-9 peg) + #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) - #:export (read-po-file)) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:export (read-po-file + translate-cross-references)) ;; A small parser for po files -(define-peg-pattern po-file body (* (or comment entry whitespace))) +(define-peg-pattern po-file body (* (or entry whitespace))) (define-peg-pattern whitespace body (or " " "\t" "\n")) (define-peg-pattern comment-chr body (range #\space #\頋)) (define-peg-pattern comment none (and "#" (* comment-chr) "\n")) +(define-peg-pattern flags all (and (ignore "#, ") (* comment-chr) (ignore "\n"))) (define-peg-pattern entry all - (and (ignore (* whitespace)) (ignore "msgid ") msgid - (ignore (* whitespace)) (ignore "msgstr ") msgstr)) + (and (* (or flags comment (ignore (* whitespace)))) + (ignore "msgid ") msgid (ignore (* whitespace)) + (ignore "msgstr ") msgstr)) (define-peg-pattern escape body (or "\\\\" "\\\"" "\\n")) (define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"") "\\n" (and (ignore "\\") "\\") @@ -53,7 +59,24 @@ (append (list "\n" prefix) result))))))) (define (parse-tree->assoc parse-tree) - "Converts a po PARSE-TREE to an association list." + "Converts a po PARSE-TREE to an association list, where the key is the msgid +and the value is the msgstr. The result only contains non fuzzy strings." + (define (comments->flags comments) + (match comments + (('flags flags) + (map (lambda (flag) (string->symbol (string-trim-both flag #\space))) + (string-split flags #\,))) + ((? list? comments) + (fold + (lambda (comment res) + (match comment + ((? string? _) res) + (flags + (append (comments->flags flags) + res)))) + '() + comments)))) + (match parse-tree (() '()) ((entry . parse-tree) @@ -66,10 +89,22 @@ ;; empty msgstr (('entry ('msgid msgid) 'msgstr) (parse-tree->assoc parse-tree)) + (('entry _ ('msgid msgid) 'msgstr) + (parse-tree->assoc parse-tree)) + (('entry ('msgid msgid) ('msgstr msgstr)) + (acons (interpret-newline-escape msgid) + (interpret-newline-escape msgstr) + (parse-tree->assoc parse-tree))) (('entry ('msgid msgid) ('msgstr msgstr)) (acons (interpret-newline-escape msgid) (interpret-newline-escape msgstr) - (parse-tree->assoc parse-tree))))))) + (parse-tree->assoc parse-tree))) + (('entry comments ('msgid msgid) ('msgstr msgstr)) + (if (member 'fuzzy (comments->flags comments)) + (parse-tree->assoc parse-tree) + (acons (interpret-newline-escape msgid) + (interpret-newline-escape msgstr) + (parse-tree->assoc parse-tree)))))))) (define (read-po-file port) "Read a .po file from PORT and return an alist of msgid and msgstr." @@ -77,3 +112,71 @@ po-file (get-string-all port))))) (parse-tree->assoc tree))) + +(define (canonicalize-whitespace str) + "Change whitespace (newlines, etc.) in STR to @code{#\\space}." + (string-map (lambda (chr) + (if (char-set-contains? char-set:whitespace chr) + #\space + chr)) + str)) + +(define xref-regexp + ;; Texinfo cross-reference regexp. + (make-regexp "@(px|x)?ref\\{([^,}]+)")) + +(define (translate-cross-references texi pofile) + "Translate the cross-references that appear in @var{texi}, the initial +translation of a Texinfo file, using the msgid/msgstr pairs from @var{pofile}." + (define translations + (call-with-input-file pofile read-po-file)) + + (define content + (call-with-input-file texi get-string-all)) + + (define matches + (list-matches xref-regexp content)) + + (define translation-map + (fold (match-lambda* + (((msgid . str) result) + (vhash-cons msgid str result))) + vlist-null + translations)) + + (define translated + ;; Iterate over MATCHES and replace cross-references with their + ;; translation found in TRANSLATION-MAP. (We can't use + ;; 'substitute*' because matches can span multiple lines.) + (let loop ((matches matches) + (offset 0) + (result '())) + (match matches + (() + (string-concatenate-reverse + (cons (string-drop content offset) result))) + ((head . tail) + (let ((prefix (match:substring head 1)) + (ref (canonicalize-whitespace (match:substring head 2)))) + (define translated + (string-append "@" (or prefix "") + "ref{" + (match (vhash-assoc ref translation-map) + (#f ref) + ((_ . str) str)))) + + (loop tail + (match:end head) + (append (list translated + (string-take + (string-drop content offset) + (- (match:start head) offset))) + result))))))) + + (format (current-error-port) + "translated ~a cross-references in '~a'~%" + (length matches) texi) + + (call-with-output-file texi + (lambda (port) + (display translated port)))) diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 97145a116d..b9c5a76f34 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot> ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,7 +110,7 @@ (define* (wrap-qt-program program-name #:key (sh (which "bash")) inputs output (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) - "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" + "Wrap the specified program (which must reside in the OUTPUT's \"/bin\" directory) with suitably set environment variables. This is like qt-build-systems's phase \"qt-wrap\", but only the named program @@ -134,7 +135,10 @@ add a dependency of that output on Qt." (define (find-files-to-wrap output-dir) (append-map (lambda (dir) - (if (directory-exists? dir) (find-files dir ".*") (list))) + (if (directory-exists? dir) + (find-files dir (lambda (file stat) + (not (wrapped-program? file)))) + (list))) (list (string-append output-dir "/bin") (string-append output-dir "/sbin") (string-append output-dir "/libexec") diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm index 66683971c5..e4a88456be 100644 --- a/guix/build/renpy-build-system.scm +++ b/guix/build/renpy-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ac1b0c2eea..45f95c509d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,6 +57,9 @@ restart-on-EINTR + device-number + device-number->major+minor + mount? mount-device-number mount-source @@ -67,6 +71,11 @@ mounts mount-points + SWAP_FLAG_PREFER + SWAP_FLAG_PRIO_MASK + SWAP_FLAG_PRIO_SHIFT + SWAP_FLAG_DISCARD + swapon swapoff @@ -116,6 +125,8 @@ with-file-lock with-file-lock/no-wait + set-child-subreaper! + set-thread-name thread-name @@ -176,6 +187,8 @@ terminal-window-size terminal-columns terminal-rows + openpty + login-tty utmpx? utmpx-login-type @@ -418,15 +431,21 @@ expansion-time error is raised if FIELD does not exist in TYPE." "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." (call-with-restart-on-EINTR (lambda () expr))) -(define (syscall->procedure return-type name argument-types) +(define* (syscall->procedure return-type name argument-types + #:key library) "Return a procedure that wraps the C function NAME using the dynamic FFI, -and that returns two values: NAME's return value, and errno. +and that returns two values: NAME's return value, and errno. When LIBRARY is +specified, look up NAME in that library rather than in the global symbol name +space. If an error occurs while creating the binding, defer the error report until the returned procedure is called." (catch #t (lambda () - (let ((ptr (dynamic-func name (dynamic-link)))) + (let ((ptr (dynamic-func name + (if library + (dynamic-link library) + (dynamic-link))))) ;; The #:return-errno? facility was introduced in Guile 2.0.12. (pointer->procedure return-type ptr argument-types #:return-errno? #t))) @@ -450,6 +469,29 @@ the returned procedure is called." ;;; +;;; Block devices. +;;; + +;; Convert between major:minor pairs and packed ‘device number’ representation. +;; XXX These aren't syscalls, but if you squint very hard they are part of the +;; FFI or however you want to justify me not finding a better fit… :-) +(define (device-number major minor) ; see glibc's <sys/sysmacros.h> + "Return the device number for the device with MAJOR and MINOR, for use as +the last argument of `mknod'." + (logior (ash (logand #x00000fff major) 8) + (ash (logand #xfffff000 major) 32) + (logand #x000000ff minor) + (ash (logand #xffffff00 minor) 12))) + +(define (device-number->major+minor device) ; see glibc's <sys/sysmacros.h> + "Return two values: the major and minor device numbers that make up DEVICE." + (values (logior (ash (logand #x00000000000fff00 device) -8) + (ash (logand #xfffff00000000000 device) -32)) + (logior (logand #x00000000000000ff device) + (ash (logand #x00000ffffff00000 device) -12)))) + + +;;; ;;; File systems. ;;; @@ -628,7 +670,7 @@ current process." (define (string->device-number str) (match (string-split str #\:) (((= string->number major) (= string->number minor)) - (+ (* major 256) minor)))) + (device-number major minor)))) (call-with-input-file "/proc/self/mountinfo" (lambda (port) @@ -650,6 +692,13 @@ current process." "Return the mounts points for currently mounted file systems." (map mount-point (mounts))) +;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h + +(define SWAP_FLAG_PREFER #x8000) ;; Set if swap priority is specified. +(define SWAP_FLAG_PRIO_MASK #x7fff) +(define SWAP_FLAG_PRIO_SHIFT 0) +(define SWAP_FLAG_DISCARD #x10000) ;; Discard swap cluster after use. + (define swapon (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) @@ -1386,6 +1435,11 @@ handler if the lock is already held by another process." (define PR_SET_NAME 15) ;<linux/prctl.h> (define PR_GET_NAME 16) +(define PR_SET_CHILD_SUBREAPER 36) + +(define (set-child-subreaper!) + "Set the CHILD_SUBREAPER capability for the current process." + (%prctl PR_SET_CHILD_SUBREAPER 1 0 0 0)) (define %max-thread-name-length ;; Maximum length in bytes of the process name, including the terminating @@ -2259,6 +2313,41 @@ PORT, trying to guess a reasonable value if all else fails. The result is always a positive integer." (terminal-dimension window-size-rows port (const 25))) +(define openpty + (let ((proc (syscall->procedure int "openpty" '(* * * * *) + #:library "libutil"))) + (lambda () + "Return two file descriptors: one for the pseudo-terminal control side, +and one for the controlled side." + (let ((head (make-bytevector (sizeof int))) + (inferior (make-bytevector (sizeof int)))) + (let-values (((ret err) + (proc (bytevector->pointer head) + (bytevector->pointer inferior) + %null-pointer %null-pointer %null-pointer))) + (unless (zero? ret) + (throw 'system-error "openpty" "~A" + (list (strerror err)) + (list err)))) + + (let ((* (lambda (bv) + (bytevector-sint-ref bv 0 (native-endianness) + (sizeof int))))) + (values (* head) (* inferior))))))) + +(define login-tty + (let* ((proc (syscall->procedure int "login_tty" (list int) + #:library "libutil"))) + (lambda (fd) + "Make FD the controlling terminal of the current process (with the +TIOCSCTTY ioctl), redirect standard input, standard output and standard error +output to this terminal, and close FD." + (let-values (((ret err) (proc fd))) + (unless (zero? ret) + (throw 'system-error "login-pty" "~A" + (list (strerror err)) + (list err))))))) + ;;; ;;; utmpx. diff --git a/guix/build/union.scm b/guix/build/union.scm index 961ac3298b..bf75c67c52 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; @@ -99,8 +99,9 @@ identical, #f otherwise." ;; a warning doesn't make sense. For example, "icon-theme.cache" is ;; regenerated by a profile hook which shadows the file provided by ;; individual packages, and "gschemas.compiled" is made available to - ;; applications via 'glib-or-gtk-build-system'. - '("icon-theme.cache" "gschemas.compiled")) + ;; applications via 'glib-or-gtk-build-system'; "etc/ld.so.cache" is created + ;; for most packages. + '("icon-theme.cache" "gschemas.compiled" "ld.so.cache")) (define (warn-about-collision files) "Handle the collision among FILES by emitting a warning and choosing the |