me/guix
Archived
1
0
Fork 0
Code Activity

build-system/gnu: Use invoke instead of system*.

Browse source 
* guix/build/gnu-build-system.scm (unpack, configure, build, check, install)
(strip, compress-documentation): Use invoke and remove vestigial plumbing.
This commit is contained in:
Mark H Weaver 2018-03-16 03:03:25 -04:00
parent 6d084076b4
commit 9a87649c86
No known key found for this signature in database
GPG key ID: 7CEF29847562C516
1 changed files with 83 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

167
guix/build/gnu-build-system.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -152,12 +153,13 @@ working directory."
;; Preserve timestamps (set to the Epoch) on the copied tree so that ;; Preserve timestamps (set to the Epoch) on the copied tree so that
;; things work deterministically. ;; things work deterministically.
(copy-recursively source "." (copy-recursively source "."
#:keep-mtime? #t) #:keep-mtime? #t))
#t) (begin
(and (if (string-suffix? ".zip" source) (if (string-suffix? ".zip" source)
(zero? (system* "unzip" source)) (invoke "unzip" source)
(zero? (system* "tar" "xvf" source))) (invoke "tar" "xvf" source))
(chdir (first-subdirectory "."))))) (chdir (first-subdirectory "."))))
#t)
(define %bootstrap-scripts (define %bootstrap-scripts
;; Typical names of Autotools "bootstrap" scripts. ;; Typical names of Autotools "bootstrap" scripts.
@ -316,33 +318,32 @@ makefiles."
;; Call `configure' with a relative path. Otherwise, GCC's build system ;; Call `configure' with a relative path. Otherwise, GCC's build system
;; (for instance) records absolute source file names, which typically ;; (for instance) records absolute source file names, which typically
;; contain the hash part of the `.drv' file, leading to a reference leak. ;; contain the hash part of the `.drv' file, leading to a reference leak.
(zero? (apply system* bash (apply invoke bash
(string-append srcdir "/configure") (string-append srcdir "/configure")
flags)))) flags)))
(define* (build #:key (make-flags '()) (parallel-build? #t) (define* (build #:key (make-flags '()) (parallel-build? #t)
#:allow-other-keys) #:allow-other-keys)
(zero? (apply system* "make" (apply invoke "make"
`(,@(if parallel-build? `(,@(if parallel-build?
`("-j" ,(number->string (parallel-job-count))) `("-j" ,(number->string (parallel-job-count)))
'()) '())
,@make-flags)))) ,@make-flags)))
(define* (check #:key target (make-flags '()) (tests? (not target)) (define* (check #:key target (make-flags '()) (tests? (not target))
(test-target "check") (parallel-tests? #t) (test-target "check") (parallel-tests? #t)
#:allow-other-keys) #:allow-other-keys)
(if tests? (if tests?
(zero? (apply system* "make" test-target (apply invoke "make" test-target
`(,@(if parallel-tests? `(,@(if parallel-tests?
`("-j" ,(number->string (parallel-job-count))) `("-j" ,(number->string (parallel-job-count)))
'()) '())
,@make-flags))) ,@make-flags))
(begin (format #t "test suite not run~%"))
(format #t "test suite not run~%") #t)
#t)))
(define* (install #:key (make-flags '()) #:allow-other-keys) (define* (install #:key (make-flags '()) #:allow-other-keys)
(zero? (apply system* "make" "install" make-flags))) (apply invoke "make" "install" make-flags))
(define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t) (define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t)
#:allow-other-keys) #:allow-other-keys)
@ -408,10 +409,8 @@ makefiles."
(let ((debug (debug-file file))) (let ((debug (debug-file file)))
(mkdir-p (dirname debug)) (mkdir-p (dirname debug))
(copy-file file debug) (copy-file file debug)
(and (zero? (system* strip-command "--only-keep-debug" debug)) (invoke strip-command "--only-keep-debug" debug)
(begin (chmod debug #o400)))
(chmod debug #o400)
#t))))
(define (add-debug-link file) (define (add-debug-link file)
;; Add a debug link in FILE (info "(binutils) strip"). ;; Add a debug link in FILE (info "(binutils) strip").
@ -421,10 +420,10 @@ makefiles."
;; `bfd_fill_in_gnu_debuglink_section' function.) No reference to ;; `bfd_fill_in_gnu_debuglink_section' function.) No reference to
;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
;; file. ;; file.
(zero? (system* objcopy-command "--enable-deterministic-archives" (invoke objcopy-command "--enable-deterministic-archives"
(string-append "--add-gnu-debuglink=" (string-append "--add-gnu-debuglink="
(debug-file file)) (debug-file file))
file))) file))
(define (strip-dir dir) (define (strip-dir dir)
(format #t "stripping binaries in ~s with ~s and flags ~s~%" (format #t "stripping binaries in ~s with ~s and flags ~s~%"
@ -434,17 +433,18 @@ makefiles."
debug-output objcopy-command)) debug-output objcopy-command))
(for-each (lambda (file) (for-each (lambda (file)
(and (or (elf-file? file) (ar-file? file)) (when (or (elf-file? file) (ar-file? file))
(or (not debug-output) (when debug-output
(make-debug-file file)) (make-debug-file file))
;; Ensure the file is writable. ;; Ensure the file is writable.
(begin (make-file-writable file) #t) (make-file-writable file)
(zero? (apply system* strip-command (apply invoke strip-command
(append strip-flags (list file)))) (append strip-flags (list file)))
(or (not debug-output)
(add-debug-link file)))) (when debug-output
(add-debug-link file))))
(find-files dir (find-files dir
(lambda (file stat) (lambda (file stat)
;; Ignore symlinks such as: ;; Ignore symlinks such as:
@ -452,15 +452,16 @@ makefiles."
(eq? 'regular (stat:type stat))) (eq? 'regular (stat:type stat)))
#:stat lstat))) #:stat lstat)))
(or (not strip-binaries?) (when strip-binaries?
(every strip-dir (for-each
(append-map (match-lambda strip-dir
((_ . dir) (append-map (match-lambda
(filter-map (lambda (d) ((_ . dir)
(let ((sub (string-append dir "/" d))) (filter-map (lambda (d)
(and (directory-exists? sub) sub))) (let ((sub (string-append dir "/" d)))
strip-directories))) (and (directory-exists? sub) sub)))
outputs)))) strip-directories)))
outputs))))
(define* (validate-runpath #:key (define* (validate-runpath #:key
(validate-runpath? #t) (validate-runpath? #t)
@ -586,47 +587,45 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
(apply throw args)))))) (apply throw args))))))
(define (maybe-compress-directory directory regexp) (define (maybe-compress-directory directory regexp)
(or (not (directory-exists? directory)) (when (directory-exists? directory)
(match (find-files directory regexp) (match (find-files directory regexp)
(() ;nothing to compress (() ;nothing to compress
#t) #t)
((files ...) ;one or more files ((files ...) ;one or more files
(format #t (format #t
"compressing documentation in '~a' with ~s and flags ~s~%" "compressing documentation in '~a' with ~s and flags ~s~%"
directory documentation-compressor directory documentation-compressor
documentation-compressor-flags) documentation-compressor-flags)
(call-with-values (call-with-values
(lambda () (lambda ()
(partition symbolic-link? files)) (partition symbolic-link? files))
(lambda (symlinks regular-files) (lambda (symlinks regular-files)
;; Compress the non-symlink files, and adjust symlinks to refer ;; Compress the non-symlink files, and adjust symlinks to refer
;; to the compressed files. Leave files that have hard links ;; to the compressed files. Leave files that have hard links
;; unchanged ('gzip' would refuse to compress them anyway.) ;; unchanged ('gzip' would refuse to compress them anyway.)
;; Also, do not retarget symbolic links pointing to other ;; Also, do not retarget symbolic links pointing to other
;; symbolic links, since these are not compressed. ;; symbolic links, since these are not compressed.
(and (every retarget-symlink (for-each retarget-symlink
(filter (lambda (symlink) (filter (lambda (symlink)
(and (not (points-to-symlink? symlink)) (and (not (points-to-symlink? symlink))
(string-match regexp symlink))) (string-match regexp symlink)))
symlinks)) symlinks))
(zero? (apply invoke documentation-compressor
(apply system* documentation-compressor (append documentation-compressor-flags
(append documentation-compressor-flags (remove has-links? regular-files)))))))))
(remove has-links? regular-files)))))))))))
(define (maybe-compress output) (define (maybe-compress output)
(and (maybe-compress-directory (string-append output "/share/man") (maybe-compress-directory (string-append output "/share/man")
"\\.[0-9]+$") "\\.[0-9]+$")
(maybe-compress-directory (string-append output "/share/info") (maybe-compress-directory (string-append output "/share/info")
"\\.info(-[0-9]+)?$"))) "\\.info(-[0-9]+)?$"))
(if compress-documentation? (if compress-documentation?
(match outputs (match outputs
(((names . directories) ...) (((names . directories) ...)
(every maybe-compress directories))) (for-each maybe-compress directories)))
(begin (format #t "not compressing documentation~%"))
(format #t "not compressing documentation~%") #t)
#t)))
(define* (delete-info-dir-file #:key outputs #:allow-other-keys) (define* (delete-info-dir-file #:key outputs #:allow-other-keys)
"Delete any 'share/info/dir' file from OUTPUTS." "Delete any 'share/info/dir' file from OUTPUTS."