diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/gnu-build-system.scm | 99 | ||||
| -rw-r--r-- | guix/build/utils.scm | 80 | ||||
| -rw-r--r-- | guix/packages.scm | 5 |
3 files changed, 161 insertions, 23 deletions
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 17fa7afd8d..d3de92b724 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -20,6 +20,7 @@ #:use-module (guix build utils) #:use-module (ice-9 ftw) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -236,18 +237,11 @@ makefiles." (string-append srcdir "/configure") flags)))) -(define %parallel-job-count - ;; String to be passed next to GNU Make's `-j' argument. - (match (getenv "NIX_BUILD_CORES") - (#f "1") - ("0" (number->string (current-processor-count))) - (x x))) - (define* (build #:key (make-flags '()) (parallel-build? #t) #:allow-other-keys) (zero? (apply system* "make" `(,@(if parallel-build? - `("-j" ,%parallel-job-count) + `("-j" ,(number->string (parallel-job-count))) '()) ,@make-flags)))) @@ -257,7 +251,7 @@ makefiles." (if tests? (zero? (apply system* "make" test-target `(,@(if parallel-tests? - `("-j" ,%parallel-job-count) + `("-j" ,(number->string (parallel-job-count))) '()) ,@make-flags))) (begin @@ -350,7 +344,9 @@ makefiles." debug-output objcopy-command)) (file-system-fold (const #t) (lambda (path stat result) ; leaf - (and (or (not debug-output) + (and (file-exists? path) ;discard dangling symlinks + (or (elf-file? path) (ar-file? path)) + (or (not debug-output) (make-debug-file path)) (zero? (apply system* strip-command (append strip-flags (list path)))) @@ -377,6 +373,85 @@ makefiles." strip-directories))) outputs)))) +(define* (validate-documentation-location #:key outputs + #:allow-other-keys) + "Documentation should go to 'share/info' and 'share/man', not just 'info/' +and 'man/'. This phase moves directories to the right place if needed." + (define (validate-sub-directory output sub-directory) + (let ((directory (string-append output "/" sub-directory))) + (when (directory-exists? directory) + (let ((target (string-append output "/share/" sub-directory))) + (format #t "moving '~a' to '~a'~%" directory target) + (mkdir-p (dirname target)) + (rename-file directory target))))) + + (define (validate-output output) + (for-each (cut validate-sub-directory output <>) + '("man" "info"))) + + (match outputs + (((names . directories) ...) + (for-each validate-output directories))) + #t) + +(define* (compress-documentation #:key outputs + (compress-documentation? #t) + (documentation-compressor "gzip") + (documentation-compressor-flags + '("--best" "--no-name")) + (compressed-documentation-extension ".gz") + #:allow-other-keys) + "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files +found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with +DOCUMENTATION-COMPRESSOR-FLAGS." + (define (retarget-symlink link) + (let ((target (readlink link))) + (delete-file link) + (symlink (string-append target compressed-documentation-extension) + link))) + + (define (has-links? file) + ;; Return #t if FILE has hard links. + (> (stat:nlink (lstat file)) 1)) + + (define (maybe-compress-directory directory regexp) + (or (not (directory-exists? directory)) + (match (find-files directory regexp) + (() ;nothing to compress + #t) + ((files ...) ;one or more files + (format #t + "compressing documentation in '~a' with ~s and flags ~s~%" + directory documentation-compressor + documentation-compressor-flags) + (call-with-values + (lambda () + (partition symbolic-link? files)) + (lambda (symlinks regular-files) + ;; Compress the non-symlink files, and adjust symlinks to refer + ;; to the compressed files. Leave files that have hard links + ;; unchanged ('gzip' would refuse to compress them anyway.) + (and (zero? (apply system* documentation-compressor + (append documentation-compressor-flags + (remove has-links? regular-files)))) + (every retarget-symlink + (filter (cut string-match regexp <>) + symlinks))))))))) + + (define (maybe-compress output) + (and (maybe-compress-directory (string-append output "/share/man") + "\\.[0-9]+$") + (maybe-compress-directory (string-append output "/share/info") + "\\.info(-[0-9]+)?$"))) + + (if compress-documentation? + (match outputs + (((names . directories) ...) + (every maybe-compress directories))) + (begin + (format #t "not compressing documentation~%") + #t))) + (define %standard-phases ;; Standard build phases, as a list of symbol/procedure pairs. (let-syntax ((phases (syntax-rules () @@ -385,7 +460,9 @@ makefiles." patch-usr-bin-file patch-source-shebangs configure patch-generated-file-shebangs build check install - patch-shebangs strip))) + patch-shebangs strip + validate-documentation-location + compress-documentation))) (define* (gnu-build #:key (source #f) (outputs #f) (inputs #f) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index cda4fb12ef..9b1e098c6b 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -31,9 +31,14 @@ #:re-export (alist-cons alist-delete) #:export (%store-directory + parallel-job-count + directory-exists? executable-file? + symbolic-link? call-with-ascii-input-file + elf-file? + ar-file? with-directory-excursion mkdir-p copy-recursively @@ -69,6 +74,14 @@ (or (getenv "NIX_STORE") "/gnu/store")) +(define parallel-job-count + ;; Number of processes to be passed next to GNU Make's `-j' argument. + (make-parameter + (match (getenv "NIX_BUILD_CORES") ;set by the daemon + (#f 1) + ("0" (current-processor-count)) + (x (or (string->number x) 1))))) + (define (directory-exists? dir) "Return #t if DIR exists and is a directory." (let ((s (stat dir #f))) @@ -81,6 +94,10 @@ (and s (not (zero? (logand (stat:mode s) #o100)))))) +(define (symbolic-link? file) + "Return #t if FILE is a symbolic link (aka. \"symlink\".)" + (eq? (stat:type (lstat file)) 'symlink)) + (define (call-with-ascii-input-file file proc) "Open FILE as an ASCII or binary file, and pass the resulting port to PROC. FILE is closed when PROC's dynamic extent is left. Return the @@ -96,6 +113,42 @@ return values of applying PROC to the port." (lambda () (close-input-port port))))) +(define (file-header-match header) + "Return a procedure that returns true when its argument is a file starting +with the bytes in HEADER, a bytevector." + (define len + (bytevector-length header)) + + (lambda (file) + "Return true if FILE starts with the right magic bytes." + (define (get-header) + (call-with-input-file file + (lambda (port) + (get-bytevector-n port len)) + #:binary #t #:guess-encoding #f)) + + (catch 'system-error + (lambda () + (equal? (get-header) header)) + (lambda args + (if (= EISDIR (system-error-errno args)) + #f ;FILE is a directory + (apply throw args)))))) + +(define %elf-magic-bytes + ;; Magic bytes of ELF files. See <elf.h>. + (u8-list->bytevector (map char->integer (string->list "\x7FELF")))) + +(define elf-file? + (file-header-match %elf-magic-bytes)) + +(define %ar-magic-bytes + ;; Magic bytes of archives created by 'ar'. See <ar.h>. + (u8-list->bytevector (map char->integer (string->list "!<arch>\n")))) + +(define ar-file? + (file-header-match %ar-magic-bytes)) + (define-syntax-rule (with-directory-excursion dir body ...) "Run BODY with DIR as the process's current directory." (let ((init (getcwd))) @@ -365,10 +418,11 @@ PROC's result is returned." (false-if-exception (delete-file template)))))) (define (substitute file pattern+procs) - "PATTERN+PROCS is a list of regexp/two-argument procedure. For each line -of FILE, and for each PATTERN that it matches, call the corresponding PROC -as (PROC LINE MATCHES); PROC must return the line that will be written as a -substitution of the original line." + "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each +line of FILE, and for each PATTERN that it matches, call the corresponding +PROC as (PROC LINE MATCHES); PROC must return the line that will be written as +a substitution of the original line. Be careful about using '$' to match the +end of a line; by itself it won't match the terminating newline of a line." (let ((rx+proc (map (match-lambda (((? regexp? pattern) . proc) (cons pattern proc)) @@ -428,7 +482,10 @@ When one of the MATCH-VAR is `_', no variable is bound to the corresponding match substring. Alternatively, FILE may be a list of file names, in which case they are -all subject to the substitutions." +all subject to the substitutions. + +Be careful about using '$' to match the end of a line; by itself it won't +match the terminating newline of a line." ((substitute* file ((regexp match-var ...) body ...) ...) (let () (define (substitute-one-file file-name) @@ -572,9 +629,7 @@ When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged." ;; XXX: Unlike with `patch-shebang', FILE is always touched. (define (find-shell name) - (let ((shell - (search-path (search-path-as-string->list (getenv "PATH")) - name))) + (let ((shell (which name))) (unless shell (format (current-error-port) "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%" @@ -583,7 +638,7 @@ When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged." (let ((st (stat file))) (substitute* file - (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$" + (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$" _ dir shell args) (let* ((old (string-append dir shell)) (new (or (find-shell shell) old))) @@ -707,7 +762,7 @@ contents: #!location/of/bin/bash export PATH=\"/gnu/.../bar/bin\" export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\" - exec location/of/.foo-real + exec -a location/of/foo location/of/.foo-real \"$@\" This is useful for scripts that expect particular programs to be in $PATH, for programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or @@ -731,6 +786,7 @@ the previous wrapper." (copy-file prog prog-real) prog-real) (wrapper-file-name number))) + (let* ((number (next-wrapper-number)) (target (wrapper-target number)) (wrapper (wrapper-file-name (1+ number))) @@ -760,10 +816,11 @@ the previous wrapper." (with-output-to-file prog-tmp (lambda () (format #t - "#!~a~%~a~%exec \"~a\" \"$@\"~%" + "#!~a~%~a~%exec -a \"~a\" \"~a\" \"$@\"~%" (which "bash") (string-join (map export-variable vars) "\n") + (canonicalize-path prog) (canonicalize-path target)))) (chmod prog-tmp #o755) @@ -773,6 +830,7 @@ the previous wrapper." ;;; Local Variables: ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1) +;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1) ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1) ;;; eval: (put 'let-matches 'scheme-indent-function 3) ;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1) diff --git a/guix/packages.scm b/guix/packages.scm index 2a9a55e12f..a25eab7699 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -399,7 +399,10 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." (define (apply-patch input) (let ((patch* (assoc-ref %build-inputs input))) (format (current-error-port) "applying '~a'...~%" patch*) - (zero? (system* patch "--batch" ,@flags "--input" patch*)))) + + ;; Use '--force' so that patches that do not apply perfectly are + ;; rejected. + (zero? (system* patch "--force" ,@flags "--input" patch*)))) (define (first-file directory) ;; Return the name of the first file in DIRECTORY. |