diff options
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/graft.scm | 281 | ||||
-rw-r--r-- | guix/build/julia-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/node-build-system.scm | 207 | ||||
-rw-r--r-- | guix/build/qt-build-system.scm | 68 |
4 files changed, 336 insertions, 222 deletions
diff --git a/guix/build/graft.scm b/guix/build/graft.scm index c119ee71d1..f04c35fa74 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2016, 2021 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,6 +55,52 @@ (string->char-set "0123456789abcdfghijklmnpqrsvwxyz") <>)) +(define (nix-base32-char-or-nul? c) + "Return true if C is a nix-base32 character or NUL, otherwise return false." + (or (nix-base32-char? c) + (char=? c #\nul))) + +(define (possible-utf16-hash? buffer i w) + "Return true if (I - W) is large enough to hold a UTF-16 encoded +nix-base32 hash and if BUFFER contains NULs in all positions where NULs +are to be expected in a UTF-16 encoded hash+dash pattern whose dash is +found at position I. Otherwise, return false." + (and (<= (* 2 hash-length) (- i w)) + (let loop ((j (+ 1 (- i (* 2 hash-length))))) + (or (>= j i) + (and (zero? (bytevector-u8-ref buffer j)) + (loop (+ j 2))))))) + +(define (possible-utf32-hash? buffer i w) + "Return true if (I - W) is large enough to hold a UTF-32 encoded +nix-base32 hash and if BUFFER contains NULs in all positions where NULs +are to be expected in a UTF-32 encoded hash+dash pattern whose dash is +found at position I. Otherwise, return false." + (and (<= (* 4 hash-length) (- i w)) + (let loop ((j (+ 1 (- i (* 4 hash-length))))) + (or (>= j i) + (and (zero? (bytevector-u8-ref buffer j)) + (zero? (bytevector-u8-ref buffer (+ j 1))) + (zero? (bytevector-u8-ref buffer (+ j 2))) + (loop (+ j 4))))))) + +(define (insert-nuls char-size bv) + "Given a bytevector BV, return a bytevector containing the same bytes but +with (CHAR-SIZE - 1) NULs inserted between every two adjacent bytes from BV. +For example, (insert-nuls 4 #u8(1 2 3)) => #u8(1 0 0 0 2 0 0 0 3)." + (if (= char-size 1) + bv + (let* ((len (bytevector-length bv)) + (bv* (make-bytevector (+ 1 (* char-size + (- len 1))) + 0))) + (let loop ((i 0)) + (when (< i len) + (bytevector-u8-set! bv* (* i char-size) + (bytevector-u8-ref bv i)) + (loop (+ i 1)))) + bv*))) + (define* (replace-store-references input output replacement-table #:optional (store (%store-directory))) "Read data from INPUT, replacing store references according to @@ -76,9 +122,9 @@ bytevectors to the same value." (list->vector (map pred (iota 256))) <>)) - (define nix-base32-byte? + (define nix-base32-byte-or-nul? (optimize-u8-predicate - (compose nix-base32-char? + (compose nix-base32-char-or-nul? integer->char))) (define (dash? byte) (= byte 45)) @@ -86,100 +132,153 @@ bytevectors to the same value." (define request-size (expt 2 20)) ; 1 MiB ;; We scan the file for the following 33-byte pattern: 32 bytes of - ;; nix-base32 characters followed by a dash. To accommodate large files, - ;; we do not read the entire file, but instead work on buffers of up to - ;; 'request-size' bytes. To ensure that every 33-byte sequence appears - ;; entirely within exactly one buffer, adjacent buffers must overlap, - ;; i.e. they must share 32 byte positions. We accomplish this by - ;; "ungetting" the last 32 bytes of each buffer before reading the next - ;; buffer, unless we know that we've reached the end-of-file. + ;; nix-base32 characters followed by a dash. When we find such a pattern + ;; whose hash is in REPLACEMENT-TABLE, we perform the required rewrite and + ;; continue scanning. + ;; + ;; To support UTF-16 and UTF-32 store references, the 33 bytes comprising + ;; this hash+dash pattern may optionally be interspersed by extra NUL bytes. + ;; This simple approach works because the characters we are looking for are + ;; restricted to ASCII. UTF-16 hashes are interspersed with single NUL + ;; bytes ("\0"), and UTF-32 hashes are interspersed with triplets of NULs + ;; ("\0\0\0"). Note that we require NULs to be present only *between* the + ;; other bytes, and not at either end, in order to be insensitive to byte + ;; order. + ;; + ;; To accommodate large files, we do not read the entire file at once, but + ;; instead work on buffers of up to REQUEST-SIZE bytes. To ensure that + ;; every hash+dash pattern appears in its entirety in at least one buffer, + ;; adjacent buffers must overlap by one byte less than the maximum size of a + ;; hash+dash pattern. We accomplish this by "ungetting" a suffix of each + ;; buffer before reading the next buffer, unless we know that we've reached + ;; the end-of-file. (let ((buffer (make-bytevector request-size))) - (let loop () - ;; Note: We avoid 'get-bytevector-n' to work around - ;; <http://bugs.gnu.org/17466>. + (define-syntax-rule (byte-at i) + (bytevector-u8-ref buffer i)) + (let outer-loop () (match (get-bytevector-n! input buffer 0 request-size) ((? eof-object?) 'done) (end - ;; We scan the buffer for dashes that might be preceded by a - ;; nix-base32 hash. The key optimization here is that whenever we - ;; find a NON-nix-base32 character at position 'i', we know that it - ;; cannot be part of a hash, so the earliest position where the next - ;; hash could start is i+1 with the following dash at position i+33. - ;; - ;; Since nix-base32 characters comprise only 1/8 of the 256 possible - ;; byte values, and exclude some of the most common letters in - ;; English text (e t o u), in practice we can advance by 33 positions - ;; most of the time. - (let scan-from ((i hash-length) (written 0)) - ;; 'i' is the first position where we look for a dash. 'written' - ;; is the number of bytes in the buffer that have already been - ;; written. + (define (scan-from i w) + ;; Scan the buffer for dashes that might be preceded by nix hashes, + ;; where I is the minimum position where such a dash might be + ;; found, and W is the number of bytes in the buffer that have been + ;; written so far. We assume that I - W >= HASH-LENGTH. + ;; + ;; The key optimization here is that whenever we find a byte at + ;; position I that cannot occur within a nix hash (because it's + ;; neither a nix-base32 character nor NUL), we can infer that the + ;; earliest position where the next hash could start is at I + 1, + ;; and therefore the earliest position for the following dash is + ;; (+ I 1 HASH-LENGTH), which is I + 33. + ;; + ;; Since nix-base32-or-nul characters comprise only about 1/8 of + ;; the 256 possible byte values, and exclude some of the most + ;; common letters in English text (e t o u), we can advance 33 + ;; positions much of the time. (if (< i end) - (let ((byte (bytevector-u8-ref buffer i))) - (cond ((and (dash? byte) - ;; We've found a dash. Note that we do not know - ;; whether the preceeding 32 bytes are nix-base32 - ;; characters, but we do not need to know. If - ;; they are not, the following lookup will fail. - (lookup-replacement - (string-tabulate (lambda (j) - (integer->char - (bytevector-u8-ref buffer - (+ j (- i hash-length))))) - hash-length))) - => (lambda (replacement) - ;; We've found a hash that needs to be replaced. - ;; First, write out all bytes preceding the hash - ;; that have not yet been written. - (put-bytevector output buffer written - (- i hash-length written)) - ;; Now write the replacement string. - (put-bytevector output replacement) - ;; Since the byte at position 'i' is a dash, - ;; which is not a nix-base32 char, the earliest - ;; position where the next hash might start is - ;; i+1, and the earliest position where the - ;; following dash might start is (+ i 1 - ;; hash-length). Also, increase the write - ;; position to account for REPLACEMENT. - (let ((len (bytevector-length replacement))) - (scan-from (+ i 1 len) - (+ i (- len hash-length)))))) - ;; If the byte at position 'i' is a nix-base32 char, - ;; then the dash we're looking for might be as early as - ;; the following byte, so we can only advance by 1. - ((nix-base32-byte? byte) - (scan-from (+ i 1) written)) - ;; If the byte at position 'i' is NOT a nix-base32 - ;; char, then the earliest position where the next hash - ;; might start is i+1, with the following dash at - ;; position (+ i 1 hash-length). + (let ((byte (byte-at i))) + (cond ((dash? byte) + (found-dash i w)) + ((nix-base32-byte-or-nul? byte) + (scan-from (+ i 1) w)) (else - (scan-from (+ i 1 hash-length) written)))) - - ;; We have finished scanning the buffer. Now we determine how - ;; many bytes have not yet been written, and how many bytes to - ;; "unget". If 'end' is less than 'request-size' then we read - ;; less than we asked for, which indicates that we are at EOF, - ;; so we needn't unget anything. Otherwise, we unget up to - ;; 'hash-length' bytes (32 bytes). However, we must be careful - ;; not to unget bytes that have already been written, because - ;; that would cause them to be written again from the next - ;; buffer. In practice, this case occurs when a replacement is - ;; made near or beyond the end of the buffer. When REPLACEMENT - ;; went beyond END, we consume the extra bytes from INPUT. - (begin - (if (> written end) - (get-bytevector-n! input buffer 0 (- written end)) - (let* ((unwritten (- end written)) - (unget-size (if (= end request-size) - (min hash-length unwritten) - 0)) - (write-size (- unwritten unget-size))) - (put-bytevector output buffer written write-size) - (unget-bytevector input buffer (+ written write-size) - unget-size))) - (loop))))))))) + (not-part-of-hash i w)))) + (finish-buffer i w))) + + (define (not-part-of-hash i w) + ;; Position I is known to not be within a nix hash that we must + ;; rewrite. Therefore, the earliest position where the next hash + ;; might start is I + 1, and therefore the earliest position of + ;; the following dash is (+ I 1 HASH-LENGTH). + (scan-from (+ i 1 hash-length) w)) + + (define (found-dash i w) + ;; We know that there is a dash '-' at position I, and that + ;; I - W >= HASH-LENGTH. The immediately preceding bytes *might* + ;; contain a nix-base32 hash, but that is not yet known. Here, + ;; we rule out all but one possible encoding (ASCII, UTF-16, + ;; UTF-32) by counting how many NULs precede the dash. + (cond ((not (zero? (byte-at (- i 1)))) + ;; The dash is *not* preceded by a NUL, therefore it + ;; cannot possibly be a UTF-16 or UTF-32 hash. Proceed + ;; to check for an ASCII hash. + (found-possible-hash 1 i w)) + + ((not (zero? (byte-at (- i 2)))) + ;; The dash is preceded by exactly one NUL, therefore it + ;; cannot be an ASCII or UTF-32 hash. Proceed to check + ;; for a UTF-16 hash. + (if (possible-utf16-hash? buffer i w) + (found-possible-hash 2 i w) + (not-part-of-hash i w))) + + (else + ;; The dash is preceded by at least two NULs, therefore + ;; it cannot be an ASCII or UTF-16 hash. Proceed to + ;; check for a UTF-32 hash. + (if (possible-utf32-hash? buffer i w) + (found-possible-hash 4 i w) + (not-part-of-hash i w))))) + + (define (found-possible-hash char-size i w) + ;; We know that there is a dash '-' at position I, that + ;; I - W >= CHAR-SIZE * HASH-LENGTH, and that the only + ;; possible encoding for the preceding hash is as indicated by + ;; CHAR-SIZE. Here we check to see if the given hash is in + ;; REPLACEMENT-TABLE, and if so, we perform the required + ;; rewrite. + (let* ((hash (string-tabulate + (lambda (j) + (integer->char + (byte-at (- i (* char-size + (- hash-length j)))))) + hash-length)) + (replacement* (lookup-replacement hash)) + (replacement (and replacement* + (insert-nuls char-size replacement*)))) + (cond + ((not replacement) + (not-part-of-hash i w)) + (else + ;; We've found a hash that needs to be replaced. + ;; First, write out all bytes preceding the hash + ;; that have not yet been written. + (put-bytevector output buffer w + (- i (* char-size hash-length) w)) + ;; Now write the replacement string. + (put-bytevector output replacement) + ;; Now compute the new values of W and I and continue. + (let ((w (+ (- i (* char-size hash-length)) + (bytevector-length replacement)))) + (scan-from (+ w hash-length) w)))))) + + (define (finish-buffer i w) + ;; We have finished scanning the buffer. Now we determine how many + ;; bytes have not yet been written, and how many bytes to "unget". + ;; If END is less than REQUEST-SIZE then we read less than we asked + ;; for, which indicates that we are at EOF, so we needn't unget + ;; anything. Otherwise, we unget up to (* 4 HASH-LENGTH) bytes. + ;; However, we must be careful not to unget bytes that have already + ;; been written, because that would cause them to be written again + ;; from the next buffer. In practice, this case occurs when a + ;; replacement is made near or beyond the end of the buffer. When + ;; REPLACEMENT went beyond END, we consume the extra bytes from + ;; INPUT. + (if (> w end) + (get-bytevector-n! input buffer 0 (- w end)) + (let* ((unwritten (- end w)) + (unget-size (if (= end request-size) + (min (* 4 hash-length) + unwritten) + 0)) + (write-size (- unwritten unget-size))) + (put-bytevector output buffer w write-size) + (unget-bytevector input buffer (+ w write-size) + unget-size))) + (outer-loop)) + + (scan-from hash-length 0)))))) (define (rename-matching-files directory mapping) "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index 8f57045a8c..d74acf2a05 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -101,7 +101,7 @@ Project.toml)." (or (getenv "JULIA_LOAD_PATH") ""))) (setenv "HOME" "/tmp") - (invoke "julia" + (invoke "julia" "--depwarn=yes" (string-append builddir "packages/" package "/test/runtests.jl")))) #t) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 7799f03595..a55cab237c 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> +;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org> +;;; Copyright © 2019, 2021 Timothy Sample <samplet@ngyro.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,144 +20,130 @@ (define-module (guix build node-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build json) - #:use-module (guix build union) #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 regex) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%standard-phases node-build)) ;; Commentary: ;; -;; Builder-side code of the standard Node/npm package build procedure. +;; Builder-side code of the standard Node/NPM package install procedure. ;; ;; Code: -(define* (read-package-data #:key (filename "package.json")) - (call-with-input-file filename - (lambda (port) - (read-json port)))) +(define (set-home . _) + (with-directory-excursion ".." + (let loop ((i 0)) + (let ((dir (string-append "npm-home-" (number->string i)))) + (if (directory-exists? dir) + (loop (1+ i)) + (begin + (mkdir dir) + (setenv "HOME" (string-append (getcwd) "/" dir)) + (format #t "set HOME to ~s~%" (getenv "HOME"))))))) + #t) -(define* (build #:key inputs #:allow-other-keys) - (define (build-from-package-json? package-file) - (let* ((package-data (read-package-data #:filename package-file)) - (scripts (assoc-ref package-data "scripts"))) - (assoc-ref scripts "build"))) - "Build a new node module using the appropriate build system." - ;; XXX: Develop a more robust heuristic, allow override - (cond ((file-exists? "gulpfile.js") - (invoke "gulp")) - ((file-exists? "gruntfile.js") - (invoke "grunt")) - ((file-exists? "Makefile") - (invoke "make")) - ((and (file-exists? "package.json") - (build-from-package-json? "package.json")) - (invoke "npm" "run" "build"))) +(define (module-name module) + (let* ((package.json (string-append module "/package.json")) + (package-meta (call-with-input-file package.json read-json))) + (assoc-ref package-meta "name"))) + +(define (index-modules input-paths) + (define (list-modules directory) + (append-map (lambda (x) + (if (string-prefix? "@" x) + (list-modules (string-append directory "/" x)) + (list (string-append directory "/" x)))) + (filter (lambda (x) + (not (member x '("." "..")))) + (or (scandir directory) '())))) + (let ((index (make-hash-table (* 2 (length input-paths))))) + (for-each (lambda (dir) + (let ((nm (string-append dir "/lib/node_modules"))) + (for-each (lambda (module) + (hash-set! index (module-name module) module)) + (list-modules nm)))) + input-paths) + index)) + +(define* (patch-dependencies #:key inputs #:allow-other-keys) + + (define index (index-modules (map cdr inputs))) + + (define (resolve-dependencies package-meta meta-key) + (fold (lambda (key+value acc) + (match key+value + ('@ acc) + ((key . value) (acons key (hash-ref index key value) acc)))) + '() + (or (assoc-ref package-meta meta-key) '()))) + + (with-atomic-file-replacement "package.json" + (lambda (in out) + (let ((package-meta (read-json in))) + (assoc-set! package-meta "dependencies" + (append + '(@) + (resolve-dependencies package-meta "dependencies") + (resolve-dependencies package-meta "peerDependencies"))) + (assoc-set! package-meta "devDependencies" + (append + '(@) + (resolve-dependencies package-meta "devDependencies"))) + (write-json package-meta out)))) #t) -(define* (link-npm-dependencies #:key inputs #:allow-other-keys) - (define (inputs->node-inputs inputs) - "Filter the directory part from INPUTS." - (filter (lambda (input) - (match input - ((name . _) (node-package? name)))) - inputs)) - (define (inputs->directories inputs) - "Extract the directory part from INPUTS." - (match inputs - (((names . directories) ...) - directories))) - (define (make-node-path root) - (string-append root "/lib/node_modules/")) - - (let ((input-node-directories (inputs->directories - (inputs->node-inputs inputs)))) - (union-build "node_modules" - (map make-node-path input-node-directories)) +(define* (configure #:key outputs inputs #:allow-other-keys) + (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "--offline" "--ignore-scripts" "install") #t)) -(define configure link-npm-dependencies) +(define* (build #:key inputs #:allow-other-keys) + (let ((package-meta (call-with-input-file "package.json" read-json))) + (if (and=> (assoc-ref package-meta "scripts") + (lambda (scripts) + (assoc-ref scripts "build"))) + (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "run" "build")) + (format #t "there is no build script to run~%")) + #t)) -(define* (check #:key tests? #:allow-other-keys) +(define* (check #:key tests? inputs #:allow-other-keys) "Run 'npm test' if TESTS?" (if tests? - ;; Should only be enabled once we know that there are tests - (invoke "npm" "test")) + (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "test")) + (format #t "test suite not run~%")) #t) -(define (node-package? name) - "Check if NAME correspond to the name of an Node package." - (string-prefix? "node-" name)) +(define* (repack #:key inputs #:allow-other-keys) + (invoke "tar" "-czf" "../package.tgz" ".") + #t) (define* (install #:key outputs inputs #:allow-other-keys) - "Install the node module to the output store item. The module itself is -installed in a subdirectory of @file{node_modules} and its runtime dependencies -as defined by @file{package.json} are symlinked into a @file{node_modules} -subdirectory of the module's directory. Additionally, binaries are installed in -the @file{bin} directory." - (let* ((out (assoc-ref outputs "out")) - (target (string-append out "/lib")) - (binaries (string-append out "/bin")) - (data (read-package-data)) - (modulename (assoc-ref data "name")) - (binary-configuration (match (assoc-ref data "bin") - (('@ configuration ...) configuration) - ((? string? configuration) configuration) - (#f #f))) - (dependencies (match (assoc-ref data "dependencies") - (('@ deps ...) deps) - (#f #f)))) - (mkdir-p target) - (copy-recursively "." (string-append target "/node_modules/" modulename)) - ;; Remove references to dependencies - (delete-file-recursively - (string-append target "/node_modules/" modulename "/node_modules")) - (cond - ((string? binary-configuration) - (begin - (mkdir-p binaries) - (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) - (string-append binaries "/" modulename)))) - ((list? binary-configuration) - (for-each - (lambda (conf) - (match conf - ((key . value) - (begin - (mkdir-p (dirname (string-append binaries "/" key))) - (symlink (string-append target "/node_modules/" modulename "/" - value) - (string-append binaries "/" key)))))) - binary-configuration))) - (when dependencies - (mkdir-p - (string-append target "/node_modules/" modulename "/node_modules")) - (for-each - (lambda (dependency) - (let ((dependency (car dependency))) - (symlink - (string-append (assoc-ref inputs (string-append "node-" dependency)) - "/lib/node_modules/" dependency) - (string-append target "/node_modules/" modulename - "/node_modules/" dependency)))) - dependencies)) + "Install the node module to the output store item." + (let ((out (assoc-ref outputs "out")) + (npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "--prefix" out + "--global" + "--offline" + "--loglevel" "info" + "--production" + "install" "../package.tgz") #t)) - (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'set-home set-home) + (add-before 'configure 'patch-dependencies patch-dependencies) (replace 'configure configure) (replace 'build build) - (replace 'install install) - (delete 'check) - (add-after 'install 'check check) - (delete 'strip))) + (replace 'check check) + (add-before 'install 'repack repack) + (replace 'install install))) (define* (node-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index 005157b0a4..f59b0c420f 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2019, 2020 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; @@ -49,25 +49,53 @@ (define (variables-for-wrapping base-directories) - (define (collect-sub-dirs base-directories subdirectory) - (filter-map - (lambda (dir) - (let ((directory (string-append dir subdirectory))) - (if (directory-exists? directory) directory #f))) - base-directories)) - - (filter - (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) - (map - (lambda (var-spec) - `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) - (list - ;; these shall match the search-path-specification for Qt and KDE - ;; libraries - '("XDG_DATA_DIRS" "/share") - '("XDG_CONFIG_DIRS" "/etc/xdg") - '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) + (define (collect-sub-dirs base-directories file-type subdirectory + selectors) + ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset + ;; that exists and has at least one of the SELECTORS sub-directories, + ;; unless SELECTORS is the empty list. FILE-TYPE should by 'directory or + ;; 'regular file. For the later, it allows searching for plain files + ;; rather than directories. + (define exists? (match file-type + ('directory directory-exists?) + ('regular file-exists?))) + + (filter-map (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (and (exists? directory) + (or (null? selectors) + (any (lambda (selector) + (exists? + (string-append directory selector))) + selectors)) + directory))) + base-directories)) + + (filter-map + (match-lambda + ((variable file-type directory selectors ...) + (match (collect-sub-dirs base-directories file-type directory + selectors) + (() + #f) + (directories + `(,variable = ,directories))))) + + ;; These shall match the search-path-specification for Qt and KDE + ;; libraries. + (list '("XDG_DATA_DIRS" directory "/share" + + ;; These are "selectors": consider /share if and only if at least + ;; one of these sub-directories exist. This avoids adding + ;; irrelevant packages to XDG_DATA_DIRS just because they have a + ;; /share sub-directory. + "/glib-2.0/schemas" "/sounds" "/themes" + "/cursors" "/wallpapers" "/icons" "/mime") + '("XDG_CONFIG_DIRS" directory "/etc/xdg") + '("QT_PLUGIN_PATH" directory "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" directory "/lib/qt5/qml") + '("QTWEBENGINEPROCESS_PATH" regular + "/lib/qt5/libexec/QtWebEngineProcess")))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) |