* bug#60056: [PATCH RFC 1/6] build: Add gnu-build-system v2.
2022-12-14 2:16 bug#60056: cross-compilation doesn't honor gcc native input Maxim Cournoyer
@ 2022-12-15 3:23 ` Maxim Cournoyer
2022-12-15 3:23 ` bug#60056: [PATCH RFC 2/6] build: gnu-build-system2: Remove source from native inputs Maxim Cournoyer
` (5 more replies)
0 siblings, 6 replies; 11+ messages in thread
From: Maxim Cournoyer @ 2022-12-15 3:23 UTC (permalink / raw)
To: 60056; +Cc: Maxim Cournoyer, ludo
* guix/build/gnu-build-system2.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/build-system/gnu2.scm: Use it.
---
Makefile.am | 2 +
guix/build-system/gnu2.scm | 580 +++++++++++++++++++
guix/build/gnu-build-system2.scm | 937 +++++++++++++++++++++++++++++++
3 files changed, 1519 insertions(+)
create mode 100644 guix/build-system/gnu2.scm
create mode 100644 guix/build/gnu-build-system2.scm
diff --git a/Makefile.am b/Makefile.am
index b54288c0fc..a331385aa1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -159,6 +159,7 @@ MODULES = \
guix/build-system/copy.scm \
guix/build-system/glib-or-gtk.scm \
guix/build-system/gnu.scm \
+ guix/build-system/gnu2.scm \
guix/build-system/guile.scm \
guix/build-system/haskell.scm \
guix/build-system/julia.scm \
@@ -217,6 +218,7 @@ MODULES = \
guix/build/glib-or-gtk-build-system.scm \
guix/build/gnu-bootstrap.scm \
guix/build/gnu-build-system.scm \
+ guix/build/gnu-build-system2.scm \
guix/build/gnu-dist.scm \
guix/build/guile-build-system.scm \
guix/build/maven-build-system.scm \
diff --git a/guix/build-system/gnu2.scm b/guix/build-system/gnu2.scm
new file mode 100644
index 0000000000..95fce76714
--- /dev/null
+++ b/guix/build-system/gnu2.scm
@@ -0,0 +1,580 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@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-system gnu2)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix gexp)
+ #:use-module (guix monads)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix packages)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:export (%gnu-build-system-modules2
+ gnu-build2
+ gnu-build-system2
+ standard-packages2
+ standard-cross-packages2
+ package-with-explicit-inputs2
+ package-with-extra-configure-variable2
+ static-libgcc-package2
+ static-package2
+ dist-package2
+ package-with-restricted-references2))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using the GNU Build System or
+;; something compatible ("./configure && make && make install").
+;;
+;; Code:
+
+(define %gnu-build-system-modules2
+ ;; Build-side modules imported and used by default.
+ '((guix build gnu-build-system2)
+ (guix build utils)
+ (guix build gremlin)
+ (guix elf)))
+
+(define %default-modules
+ ;; Modules in scope in the build-side environment.
+ '((guix build gnu-build-system2)
+ (guix build utils)))
+
+(define* (package-with-explicit-inputs/deprecated p inputs
+ #:optional
+ (loc (current-source-location))
+ #:key (native-inputs '())
+ guile)
+ "This variant is deprecated because it is inefficient: it memoizes only
+temporarily instead of memoizing across all transformations where INPUTS is
+the same.
+
+Rewrite P, which is assumed to use GNU-BUILD-SYSTEM2, to take INPUTS and
+NATIVE-INPUTS as explicit inputs instead of the implicit default, and return
+it. INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the
+latter case, they will be called in a context where the `%current-system' and
+`%current-target-system' are suitably parametrized. Use GUILE to run the
+builder, or the distro's final Guile when GUILE is #f."
+ (define inputs* inputs)
+ (define native-inputs* native-inputs)
+
+ (define (call inputs)
+ (if (procedure? inputs)
+ (inputs)
+ inputs))
+
+ (define (duplicate-filter inputs)
+ (let ((names (match (call inputs)
+ (((name _ ...) ...)
+ name))))
+ (lambda (inputs)
+ (fold alist-delete inputs names))))
+
+ (let loop ((p p))
+ (define rewritten-input
+ (mlambda (input)
+ (match input
+ ((name (? package? p) sub-drv ...)
+ ;; XXX: Check whether P's build system knows #:implicit-inputs, for
+ ;; things like `cross-pkg-config'.
+ (if (eq? (package-build-system p) gnu-build-system2)
+ (cons* name (loop p) sub-drv)
+ (cons* name p sub-drv)))
+ (x x))))
+
+ (package (inherit p)
+ (location (if (pair? loc) (source-properties->location loc) loc))
+ (arguments
+ ;; 'ensure-keyword-arguments' guarantees that this procedure is
+ ;; idempotent.
+ (ensure-keyword-arguments (package-arguments p)
+ `(#:guile ,guile
+ #:implicit-inputs? #f)))
+ (replacement
+ (let ((replacement (package-replacement p)))
+ (and replacement
+ (package-with-explicit-inputs2 replacement inputs loc
+ #:native-inputs
+ native-inputs
+ #:guile guile))))
+ (native-inputs
+ (let ((filtered (duplicate-filter native-inputs*)))
+ `(,@(call native-inputs*)
+ ,@(map rewritten-input
+ (filtered (package-native-inputs p))))))
+ (propagated-inputs
+ (map rewritten-input
+ (package-propagated-inputs p)))
+ (inputs
+ (let ((filtered (duplicate-filter inputs*)))
+ `(,@(call inputs*)
+ ,@(map rewritten-input
+ (filtered (package-inputs p)))))))))
+
+(define* (package-with-explicit-inputs* inputs #:optional guile)
+ "Return a procedure that rewrites the given package and all its dependencies
+so that they use INPUTS (a thunk) instead of implicit inputs."
+ (define (duplicate-filter package-inputs)
+ (let ((names (match (inputs)
+ (((name _ ...) ...)
+ name))))
+ (fold alist-delete package-inputs names)))
+
+ (define (add-explicit-inputs p)
+ (if (and (eq? (package-build-system p) gnu-build-system2)
+ (not (memq #:implicit-inputs? (package-arguments p))))
+ (package
+ (inherit p)
+ (inputs (append (inputs)
+ (duplicate-filter (package-inputs p))))
+ (arguments
+ (ensure-keyword-arguments (package-arguments p)
+ `(#:implicit-inputs? #f
+ #:guile ,guile))))
+ p))
+
+ (define (cut? p)
+ (or (not (eq? (package-build-system p) gnu-build-system2))
+ (memq #:implicit-inputs? (package-arguments p))))
+
+ (package-mapping add-explicit-inputs cut?))
+
+(define package-with-explicit-inputs2
+ (case-lambda*
+ ((inputs #:optional guile)
+ (package-with-explicit-inputs* inputs guile))
+ ((p inputs #:optional (loc (current-source-location))
+ #:key (native-inputs '()) guile)
+ ;; deprecated
+ (package-with-explicit-inputs/deprecated p inputs
+ loc
+ #:native-inputs
+ native-inputs
+ #:guile guile))))
+
+(define (package-with-extra-configure-variable2 p variable value)
+ "Return a version of P with VARIABLE=VALUE specified as an extra `configure'
+flag, recursively. An example is LDFLAGS=-static. If P already has configure
+flags for VARIABLE, the associated value is augmented."
+ (let loop ((p p))
+ (define (rewritten-inputs inputs)
+ (map (match-lambda
+ ((name (? package? p) sub ...)
+ `(,name ,(loop p) ,@sub))
+ (input input))
+ inputs))
+
+ (package (inherit p)
+ (arguments
+ (let ((args (package-arguments p)))
+ (substitute-keyword-arguments args
+ ((#:configure-flags flags)
+ (let* ((var= (string-append variable "="))
+ (len (string-length var=)))
+ `(cons ,(string-append var= value)
+ (map (lambda (flag)
+ (if (string-prefix? ,var= flag)
+ (string-append
+ ,(string-append var= value " ")
+ (substring flag ,len))
+ flag))
+ ,flags)))))))
+ (replacement
+ (let ((replacement (package-replacement p)))
+ (and replacement
+ (package-with-extra-configure-variable2 replacement
+ variable value))))
+ (inputs (rewritten-inputs (package-inputs p)))
+ (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
+
+(define (static-libgcc-package2 p)
+ "A version of P linked with `-static-gcc'."
+ (package-with-extra-configure-variable2 p "LDFLAGS" "-static-libgcc"))
+
+(define* (static-package2 p #:key (strip-all? #t))
+ "Return a statically-linked version of package P. If STRIP-ALL? is true,
+use `--strip-all' as the arguments to `strip'."
+ (package (inherit p)
+ (arguments
+ (let ((a (default-keyword-arguments (package-arguments p)
+ '(#:configure-flags '()
+ #:strip-flags '("--strip-unneeded")))))
+ (substitute-keyword-arguments a
+ ((#:configure-flags flags)
+ `(cons* "--disable-shared" "LDFLAGS=-static" ,flags))
+ ((#:strip-flags flags)
+ (if strip-all?
+ ''("--strip-all")
+ flags)))))
+ (replacement (and=> (package-replacement p) static-package2))))
+
+(define* (dist-package2 p source #:key (phases '%dist-phases))
+ "Return a package that takes source files from the SOURCE directory,
+runs `make distcheck' and whose result is one or more source tarballs. The
+exact build phases are defined by PHASES."
+ (let ((s source))
+ (package (inherit p)
+ (name (string-append (package-name p) "-dist"))
+ (source s)
+ (arguments
+ ;; Use the right phases and modules.
+ (substitute-keyword-arguments (package-arguments p)
+ ((#:modules modules %default-modules)
+ `((guix build gnu-dist)
+ ,@modules))
+ ((#:imported-modules modules %gnu-build-system-modules2)
+ `((guix build gnu-dist)
+ ,@modules))
+ ((#:phases _ #f)
+ phases)))
+ (native-inputs
+ ;; Add autotools & co. as inputs.
+ (let ((ref (lambda (module var)
+ (module-ref (resolve-interface module) var))))
+ `(,@(package-native-inputs p)
+ ("autoconf" ,(ref '(gnu packages autotools) 'autoconf-wrapper))
+ ("automake" ,(ref '(gnu packages autotools) 'automake))
+ ("libtool" ,(ref '(gnu packages autotools) 'libtool))
+ ("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext))
+ ("texinfo" ,(ref '(gnu packages texinfo) 'texinfo))))))))
+
+(define (package-with-restricted-references2 p refs)
+ "Return a package whose outputs are guaranteed to only refer to the packages
+listed in REFS."
+ (if (eq? (package-build-system p) gnu-build-system2) ; XXX: dirty
+ (package (inherit p)
+ (arguments `(#:allowed-references ,refs
+ ,@(package-arguments p))))
+ p))
+
+\f
+(define (standard-packages2)
+ "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of
+standard packages used as implicit inputs of the gnu-build-system2."
+
+ ;; Resolve (gnu packages commencement) lazily to hide circular dependency.
+ (let ((distro (resolve-module '(gnu packages commencement))))
+ (module-ref distro '%final-inputs)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs target
+ (implicit-inputs? #t) (implicit-cross-inputs? #t)
+ (strip-binaries? #t) system
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME from the given arguments."
+ (define private-keywords
+ `(#:inputs #:native-inputs #:outputs
+ #:implicit-inputs? #:implicit-cross-inputs?
+ ,@(if target '() '(#:target))))
+
+ (bag
+ (name name)
+ (system system) (target target)
+ (build-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@native-inputs
+
+ ;; When not cross-compiling, ensure implicit inputs come
+ ;; last. That way, libc headers come last, which allows
+ ;; #include_next to work correctly; see
+ ;; <https://bugs.gnu.org/30756>.
+ ,@(if target '() inputs)
+ ,@(if (and target implicit-cross-inputs?)
+ (standard-cross-packages2 target 'host)
+ '())
+ ,@(if implicit-inputs?
+ (standard-packages2)
+ '())))
+ (host-inputs (if target inputs '()))
+
+ ;; The cross-libc is really a target package, but for bootstrapping
+ ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a
+ ;; native package, so it would end up using a "native" variant of
+ ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
+ ;; would use a target variant (built with 'gnu-cross-build'.)
+ (target-inputs (if (and target implicit-cross-inputs?)
+ (standard-cross-packages2 target 'target)
+ '()))
+ (outputs (if strip-binaries?
+ outputs
+ (delete "debug" outputs)))
+ (build (if target gnu-cross-build gnu-build2))
+ (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define %license-file-regexp
+ ;; Regexp matching license files.
+ "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")
+
+(define %bootstrap-scripts
+ ;; Typical names of Autotools "bootstrap" scripts.
+ #~%bootstrap-scripts)
+
+(define %strip-flags
+ #~'("--strip-unneeded" "--enable-deterministic-archives"))
+
+(define %strip-directories
+ #~'("lib" "lib64" "libexec" "bin" "sbin"))
+
+(define* (gnu-build2 name inputs
+ #:key
+ guile source
+ (outputs '("out"))
+ (search-paths '())
+ (bootstrap-scripts %bootstrap-scripts)
+ (configure-flags ''())
+ (make-flags ''())
+ (out-of-source? #f)
+ (tests? #t)
+ (test-target "check")
+ (parallel-build? #t)
+ (parallel-tests? #t)
+ (patch-shebangs? #t)
+ (strip-binaries? #t)
+ (strip-flags %strip-flags)
+ (strip-directories %strip-directories)
+ (validate-runpath? #t)
+ (make-dynamic-linker-cache? #t)
+ (license-file-regexp %license-file-regexp)
+ (phases '%standard-phases)
+ (locale "en_US.utf8")
+ (system (%current-system))
+ (build (nix-system->gnu-triplet system))
+ (imported-modules %gnu-build-system-modules2)
+ (modules %default-modules)
+ (substitutable? #t)
+ allowed-references
+ disallowed-references)
+ "Return a derivation called NAME that builds from tarball SOURCE, with
+input derivation INPUTS, using the usual procedure of the GNU Build
+System. The builder is run with GUILE, or with the distro's final Guile
+package if GUILE is #f or omitted.
+
+The builder is run in a context where MODULES are used; IMPORTED-MODULES
+specifies modules not provided by Guile itself that must be imported in
+the builder's environment, from the host. Note that we distinguish
+between both, because for Guile's own modules like (ice-9 foo), we want
+to use GUILE's own version of it, rather than import the user's one,
+which could lead to gratuitous input divergence.
+
+SUBSTITUTABLE? determines whether users may be able to use substitutes of the
+returned derivations, or whether they should always build it locally.
+
+ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs
+are allowed to refer to."
+ (define builder
+ (with-imported-modules imported-modules
+ #~(begin
+ (use-modules #$@(sexp->gexp modules))
+
+ #$(with-build-variables inputs outputs
+ #~(gnu-build2 #:source #+source
+ #:system #$system
+ #:build #$build
+ #:outputs %outputs
+ #:inputs %build-inputs
+ #:search-paths '#$(sexp->gexp
+ (map search-path-specification->sexp
+ search-paths))
+ #:phases #$(if (pair? phases)
+ (sexp->gexp phases)
+ phases)
+ #:locale #$locale
+ #:bootstrap-scripts #$bootstrap-scripts
+ #:configure-flags #$(if (pair? configure-flags)
+ (sexp->gexp configure-flags)
+ configure-flags)
+ #:make-flags #$(if (pair? make-flags)
+ (sexp->gexp make-flags)
+ make-flags)
+ #:out-of-source? #$out-of-source?
+ #:tests? #$tests?
+ #:test-target #$test-target
+ #:parallel-build? #$parallel-build?
+ #:parallel-tests? #$parallel-tests?
+ #:patch-shebangs? #$patch-shebangs?
+ #:license-file-regexp #$license-file-regexp
+ #:strip-binaries? #$strip-binaries?
+ #:validate-runpath? #$validate-runpath?
+ #:make-dynamic-linker-cache? #$make-dynamic-linker-cache?
+ #:license-file-regexp #$license-file-regexp
+ #:strip-flags #$strip-flags
+ #:strip-directories #$strip-directories)))))
+
+ (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+ system #:graft? #f)))
+ ;; Note: Always pass #:graft? #f. Without it, ALLOWED-REFERENCES &
+ ;; co. would be interpreted as referring to grafted packages.
+ (gexp->derivation name builder
+ #:system system
+ #:target #f
+ #:graft? #f
+ #:substitutable? substitutable?
+ #:allowed-references allowed-references
+ #:disallowed-references disallowed-references
+ #:guile-for-build guile)))
+
+\f
+;;;
+;;; Cross-compilation.
+;;;
+
+(define standard-cross-packages2
+ (mlambda (target kind)
+ "Return the list of name/package tuples to cross-build for TARGET. KIND
+is one of `host' or `target'."
+ (let* ((cross (resolve-interface '(gnu packages cross-base)))
+ (gcc (module-ref cross 'cross-gcc))
+ (binutils (module-ref cross 'cross-binutils))
+ (libc (module-ref cross 'cross-libc)))
+ (case kind
+ ((host)
+ ;; Cross-GCC appears once here, so that it's in $PATH...
+ `(("cross-gcc" ,(gcc target
+ #:xbinutils (binutils target)
+ #:libc (libc target)))
+ ("cross-binutils" ,(binutils target))))
+ ((target)
+ (let ((libc (libc target)))
+ ;; ... and once here, so that libstdc++ & co. are in
+ ;; CROSS_CPLUS_INCLUDE_PATH, etc.
+ `(("cross-gcc" ,(gcc target
+ #:xbinutils (binutils target)
+ #:libc libc))
+ ("cross-libc" ,libc)
+
+ ;; MinGW's libc doesn't have a "static" output.
+ ,@(if (member "static" (package-outputs libc))
+ `(("cross-libc:static" ,libc "static"))
+ '()))))))))
+
+(define* (gnu-cross-build name
+ #:key
+ target
+ build-inputs target-inputs host-inputs
+ guile source
+ (outputs '("out"))
+ (search-paths '())
+ (native-search-paths '())
+
+ (bootstrap-scripts %bootstrap-scripts)
+ (configure-flags ''())
+ (make-flags ''())
+ (out-of-source? #f)
+ (tests? #f) ; nothing can be done
+ (test-target "check")
+ (parallel-build? #t) (parallel-tests? #t)
+ (patch-shebangs? #t)
+ (strip-binaries? #t)
+ (strip-flags %strip-flags)
+ (strip-directories %strip-directories)
+ (validate-runpath? #t)
+
+ ;; We run 'ldconfig' to generate ld.so.cache and it
+ ;; generally can't do that for cross-built binaries
+ ;; ("ldconfig: foo.so is for unknown machine 40.").
+ (make-dynamic-linker-cache? #f)
+
+ (license-file-regexp %license-file-regexp)
+ (phases '%standard-phases)
+ (locale "en_US.utf8")
+ (system (%current-system))
+ (build (nix-system->gnu-triplet system))
+ (imported-modules %gnu-build-system-modules2)
+ (modules %default-modules)
+ (substitutable? #t)
+ allowed-references
+ disallowed-references)
+ "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are
+cross-built inputs, and NATIVE-INPUTS are inputs that run on the build
+platform."
+ (define builder
+ #~(begin
+ (use-modules #$@(sexp->gexp modules))
+
+ (define %build-host-inputs
+ #+(input-tuples->gexp build-inputs))
+
+ (define %build-target-inputs
+ (append #$(input-tuples->gexp host-inputs)
+ #+(input-tuples->gexp target-inputs)))
+
+ (define %build-inputs
+ (append %build-host-inputs %build-target-inputs))
+
+ (define %outputs
+ #$(outputs->gexp outputs))
+
+ (gnu-build2 #:source #+source
+ #:system #$system
+ #:build #$build
+ #:target #$target
+ #:outputs %outputs
+ #:inputs %build-target-inputs
+ #:native-inputs %build-host-inputs
+ #:search-paths '#$(sexp->gexp
+ (map search-path-specification->sexp
+ search-paths))
+ #:native-search-paths '#$(sexp->gexp
+ (map
+ search-path-specification->sexp
+ native-search-paths))
+ #:phases #$(if (pair? phases)
+ (sexp->gexp phases)
+ phases)
+ #:locale #$locale
+ #:bootstrap-scripts #$bootstrap-scripts
+ #:configure-flags #$configure-flags
+ #:make-flags #$make-flags
+ #:out-of-source? #$out-of-source?
+ #:tests? #$tests?
+ #:test-target #$test-target
+ #:parallel-build? #$parallel-build?
+ #:parallel-tests? #$parallel-tests?
+ #:patch-shebangs? #$patch-shebangs?
+ #:license-file-regexp #$license-file-regexp
+ #:strip-binaries? #$strip-binaries?
+ #:validate-runpath? #$validate-runpath?
+ #:make-dynamic-linker-cache? #$make-dynamic-linker-cache?
+ #:license-file-regexp #$license-file-regexp
+ #:strip-flags #$strip-flags
+ #:strip-directories #$strip-directories)))
+
+ (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+ system #:graft? #f)))
+ (gexp->derivation name builder
+ #:system system
+ #:target target
+ #:graft? #f
+ #:modules imported-modules
+ #:substitutable? substitutable?
+ #:allowed-references allowed-references
+ #:disallowed-references disallowed-references
+ #:guile-for-build guile)))
+
+(define gnu-build-system2
+ (build-system
+ (name 'gnu)
+ (description
+ "The GNU Build System—i.e., ./configure && make && make install")
+ (lower lower)))
diff --git a/guix/build/gnu-build-system2.scm b/guix/build/gnu-build-system2.scm
new file mode 100644
index 0000000000..54129549c2
--- /dev/null
+++ b/guix/build/gnu-build-system2.scm
@@ -0,0 +1,937 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; 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 gnu-build-system2)
+ #:use-module (guix build utils)
+ #:use-module (guix build gremlin)
+ #:use-module (guix elf)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-26)
+ #:use-module (rnrs io ports)
+ #:export (%standard-phases
+ %license-file-regexp
+ %bootstrap-scripts
+ dump-file-contents
+ gnu-build2))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using the GNU Build System or
+;; something compatible ("./configure && make && make install"). This is the
+;; builder-side code.
+;;
+;; Code:
+
+(cond-expand
+ (guile-2.2
+ ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+ ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
+ (define time-monotonic time-tai))
+ (else #t))
+
+(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/."
+ (setenv "SOURCE_DATE_EPOCH" "1"))
+
+(define (first-subdirectory directory)
+ "Return the file name of the first sub-directory of DIRECTORY or false, when
+there are none."
+ (match (scandir directory
+ (lambda (file)
+ (and (not (member file '("." "..")))
+ (file-is-directory? (string-append directory "/"
+ file)))))
+ ((first . _) first)
+ (_ #f)))
+
+(define* (set-paths #:key target inputs native-inputs
+ (search-paths '()) (native-search-paths '())
+ #:allow-other-keys)
+ (define input-directories
+ ;; The "source" input can be a directory, but we don't want it for search
+ ;; paths. See <https://issues.guix.gnu.org/44924>.
+ (match (alist-delete "source" inputs)
+ (((_ . dir) ...)
+ dir)))
+
+ (define native-input-directories
+ (match native-inputs
+ (((_ . dir) ...)
+ dir)
+ (#f ; not cross compiling
+ '())))
+
+ ;; Tell 'ld-wrapper' to disallow non-store libraries.
+ (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no")
+
+ ;; When cross building, $PATH must refer only to native (host) inputs since
+ ;; target inputs are not executable.
+ (set-path-environment-variable "PATH" '("bin" "sbin")
+ (append native-input-directories
+ (if target
+ '()
+ input-directories)))
+
+ (for-each (match-lambda
+ ((env-var (files ...) separator type pattern)
+ (set-path-environment-variable env-var files
+ input-directories
+ #:separator separator
+ #:type type
+ #:pattern pattern)))
+ search-paths)
+
+ (when native-search-paths
+ ;; Search paths for native inputs, when cross building.
+ (for-each (match-lambda
+ ((env-var (files ...) separator type pattern)
+ (set-path-environment-variable env-var files
+ native-input-directories
+ #:separator separator
+ #:type type
+ #:pattern pattern)))
+ native-search-paths)))
+
+(define* (install-locale #:key
+ (locale "en_US.utf8")
+ (locale-category LC_ALL)
+ #:allow-other-keys)
+ "Try to install LOCALE; emit a warning if that fails. The main goal is to
+use a UTF-8 locale so that Guile correctly interprets UTF-8 file names.
+
+This phase must typically happen after 'set-paths' so that $LOCPATH has a
+chance to be set."
+ (catch 'system-error
+ (lambda ()
+ (setlocale locale-category locale)
+
+ ;; While we're at it, pass it to sub-processes.
+ (setenv (locale-category->string locale-category) locale)
+
+ (format (current-error-port) "using '~a' locale for category ~s~%"
+ locale (locale-category->string locale-category)))
+ (lambda args
+ ;; This is known to fail for instance in early bootstrap where locales
+ ;; are not available.
+ (format (current-error-port)
+ "warning: failed to install '~a' locale: ~a~%"
+ locale (strerror (system-error-errno args))))))
+
+(define* (unpack #:key source #:allow-other-keys)
+ "Unpack SOURCE in the working directory, and change directory within the
+source. When SOURCE is a directory, copy it in a sub-directory of the current
+working directory."
+ (if (file-is-directory? source)
+ (begin
+ (mkdir "source")
+ (chdir "source")
+
+ ;; Preserve timestamps (set to the Epoch) on the copied tree so that
+ ;; things work deterministically.
+ (copy-recursively source "."
+ #:keep-mtime? #t)
+ ;; Make the source checkout files writable, for convenience.
+ (for-each (lambda (f)
+ (false-if-exception (make-file-writable f)))
+ (find-files ".")))
+ (begin
+ (cond
+ ((string-suffix? ".zip" source)
+ (invoke "unzip" source))
+ ((tarball? source)
+ (invoke "tar" "xvf" source))
+ (else
+ (let ((name (strip-store-file-name source))
+ (command (compressor source)))
+ (copy-file source name)
+ (when command
+ (invoke command "--decompress" name)))))
+ ;; Attempt to change into child directory.
+ (and=> (first-subdirectory ".") chdir))))
+
+(define %bootstrap-scripts
+ ;; Typical names of Autotools "bootstrap" scripts.
+ '("bootstrap" "bootstrap.sh" "autogen.sh"))
+
+(define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts)
+ #:allow-other-keys)
+ "If the code uses Autotools and \"configure\" is missing, run
+\"autoreconf\". Otherwise do nothing."
+ ;; Note: Run that right after 'unpack' so that the generated files are
+ ;; visible when the 'patch-source-shebangs' phase runs.
+ (define (script-exists? file)
+ (and (file-exists? file)
+ (not (file-is-directory? file))))
+
+ (if (not (script-exists? "configure"))
+
+ ;; First try one of the BOOTSTRAP-SCRIPTS. If none exists, and it's
+ ;; clearly an Autoconf-based project, run 'autoreconf'. Otherwise, do
+ ;; nothing (perhaps the user removed or overrode the 'configure' phase.)
+ (let ((script (find script-exists? bootstrap-scripts)))
+ ;; GNU packages often invoke the 'git-version-gen' script from
+ ;; 'configure.ac' so make sure it has a valid shebang.
+ (false-if-file-not-found
+ (patch-shebang "build-aux/git-version-gen"))
+
+ (if script
+ (let ((script (string-append "./" script)))
+ (setenv "NOCONFIGURE" "true")
+ (format #t "running '~a'~%" script)
+ (if (executable-file? script)
+ (begin
+ (patch-shebang script)
+ (invoke script))
+ (invoke "sh" script))
+ ;; Let's clean up after ourselves.
+ (unsetenv "NOCONFIGURE"))
+ (if (or (file-exists? "configure.ac")
+ (file-exists? "configure.in"))
+ (invoke "autoreconf" "-vif")
+ (format #t "no 'configure.ac' or anything like that, \
+doing nothing~%"))))
+ (format #t "GNU build system bootstrapping not needed~%")))
+
+;; See <http://bugs.gnu.org/17840>.
+(define* (patch-usr-bin-file #:key native-inputs inputs
+ (patch-/usr/bin/file? #t)
+ #:allow-other-keys)
+ "Patch occurrences of \"/usr/bin/file\" in all the executable 'configure'
+files found in the source tree. This works around Libtool's Autoconf macros,
+which generates invocations of \"/usr/bin/file\" that are used to determine
+things like the ABI being used."
+ (when patch-/usr/bin/file?
+ (for-each (lambda (file)
+ (when (executable-file? file)
+ (patch-/usr/bin/file file)))
+ (find-files "." "^configure$"))))
+
+(define* (patch-source-shebangs #:key source #:allow-other-keys)
+ "Patch shebangs in all source files; this includes non-executable
+files such as `.in' templates. Most scripts honor $SHELL and
+$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
+`missing' script."
+ (for-each patch-shebang
+ (find-files "."
+ (lambda (file stat)
+ ;; Filter out symlinks.
+ (eq? 'regular (stat:type stat)))
+ #:stat lstat)))
+
+(define (patch-generated-file-shebangs . rest)
+ "Patch shebangs in generated files, including `SHELL' variables in
+makefiles."
+ ;; Patch executable regular files, some of which might have been generated
+ ;; by `configure'.
+ (for-each patch-shebang
+ (find-files "."
+ (lambda (file stat)
+ (and (eq? 'regular (stat:type stat))
+ (not (zero? (logand (stat:mode stat) #o100)))))
+ #:stat lstat))
+
+ ;; Patch `SHELL' in generated makefiles.
+ (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
+
+(define* (configure #:key build target native-inputs inputs outputs
+ (configure-flags '()) out-of-source?
+ #:allow-other-keys)
+ (define (package-name)
+ (let* ((out (assoc-ref outputs "out"))
+ (base (basename out))
+ (dash (string-rindex base #\-)))
+ ;; XXX: We'd rather use `package-name->name+version' or similar.
+ (string-drop (if dash
+ (substring base 0 dash)
+ base)
+ (+ 1 (string-index base #\-)))))
+
+ (let* ((prefix (assoc-ref outputs "out"))
+ (bindir (assoc-ref outputs "bin"))
+ (libdir (assoc-ref outputs "lib"))
+ (includedir (assoc-ref outputs "include"))
+ (docdir (assoc-ref outputs "doc"))
+ (bash (or (and=> (assoc-ref (or native-inputs inputs) "bash")
+ (cut string-append <> "/bin/bash"))
+ "/bin/sh"))
+ (flags `(,@(if target ; cross building
+ '("CC_FOR_BUILD=gcc")
+ '())
+ ,(string-append "CONFIG_SHELL=" bash)
+ ,(string-append "SHELL=" bash)
+ ,(string-append "--prefix=" prefix)
+ "--enable-fast-install" ; when using Libtool
+
+ ;; Produce multiple outputs when specific output names
+ ;; are recognized.
+ ,@(if bindir
+ (list (string-append "--bindir=" bindir "/bin"))
+ '())
+ ,@(if libdir
+ (cons (string-append "--libdir=" libdir "/lib")
+ (if includedir
+ '()
+ (list
+ (string-append "--includedir="
+ libdir "/include"))))
+ '())
+ ,@(if includedir
+ (list (string-append "--includedir="
+ includedir "/include"))
+ '())
+ ,@(if docdir
+ (list (string-append "--docdir=" docdir
+ "/share/doc/" (package-name)))
+ '())
+ ,@(if build
+ (list (string-append "--build=" build))
+ '())
+ ,@(if target ; cross building
+ (list (string-append "--host=" target))
+ '())
+ ,@configure-flags))
+ (abs-srcdir (getcwd))
+ (srcdir (if out-of-source?
+ (string-append "../" (basename abs-srcdir))
+ ".")))
+ (format #t "source directory: ~s (relative from build: ~s)~%"
+ abs-srcdir srcdir)
+ (if out-of-source?
+ (begin
+ (mkdir "../build")
+ (chdir "../build")))
+ (format #t "build directory: ~s~%" (getcwd))
+ (format #t "configure flags: ~s~%" flags)
+
+ ;; Use BASH to reduce reliance on /bin/sh since it may not always be
+ ;; reliable (see
+ ;; <http://thread.gmane.org/gmane.linux.distributions.nixos/9748>
+ ;; for a summary of the situation.)
+ ;;
+ ;; Call `configure' with a relative path. Otherwise, GCC's build system
+ ;; (for instance) records absolute source file names, which typically
+ ;; contain the hash part of the `.drv' file, leading to a reference leak.
+ (apply invoke bash
+ (string-append srcdir "/configure")
+ flags)))
+
+(define* (build #:key (make-flags '()) (parallel-build? #t)
+ #:allow-other-keys)
+ (apply invoke "make"
+ `(,@(if parallel-build?
+ `("-j" ,(number->string (parallel-job-count)))
+ '())
+ ,@make-flags)))
+
+(define* (dump-file-contents directory file-regexp
+ #:optional (port (current-error-port)))
+ "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP."
+ (define (dump file)
+ (let ((prefix (string-append "\n--- " file " ")))
+ (display (if (< (string-length prefix) 78)
+ (string-pad-right prefix 78 #\-)
+ prefix)
+ port)
+ (display "\n\n" port)
+ (call-with-input-file file
+ (lambda (log)
+ (dump-port log port)))
+ (display "\n" port)))
+
+ (for-each dump (find-files directory file-regexp)))
+
+(define %test-suite-log-regexp
+ ;; Name of test suite log files as commonly found in GNU-based build systems
+ ;; and CMake.
+ "^(test-?suite\\.log|LastTestFailed\\.log)$")
+
+(define* (check #:key target (make-flags '()) (tests? (not target))
+ (test-target "check") (parallel-tests? #t)
+ (test-suite-log-regexp %test-suite-log-regexp)
+ #:allow-other-keys)
+ (if tests?
+ (guard (c ((invoke-error? c)
+ ;; Dump the test suite log to facilitate debugging.
+ (display "\nTest suite failed, dumping logs.\n"
+ (current-error-port))
+ (dump-file-contents "." test-suite-log-regexp)
+ (raise c)))
+ (apply invoke "make" test-target
+ `(,@(if parallel-tests?
+ `("-j" ,(number->string (parallel-job-count)))
+ '())
+ ,@make-flags)))
+ (format #t "test suite not run~%")))
+
+(define* (install #:key (make-flags '()) #:allow-other-keys)
+ (apply invoke "make" "install" make-flags))
+
+(define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t)
+ #:allow-other-keys)
+ (define (list-of-files dir)
+ (map (cut string-append dir "/" <>)
+ (or (scandir dir (lambda (f)
+ (let ((s (lstat (string-append dir "/" f))))
+ (eq? 'regular (stat:type s)))))
+ '())))
+
+ (define bin-directories
+ (match-lambda
+ ((_ . dir)
+ (list (string-append dir "/bin")
+ (string-append dir "/sbin")
+ (string-append dir "/libexec")))))
+
+ (define output-bindirs
+ (append-map bin-directories outputs))
+
+ (define input-bindirs
+ ;; Shebangs should refer to binaries of the target system---i.e., from
+ ;; "inputs", not from "native-inputs".
+ (append-map bin-directories inputs))
+
+ (when patch-shebangs?
+ (let ((path (append output-bindirs input-bindirs)))
+ (for-each (lambda (dir)
+ (let ((files (list-of-files dir)))
+ (for-each (cut patch-shebang <> path) files)))
+ output-bindirs))))
+
+(define* (strip #:key target outputs (strip-binaries? #t)
+ (strip-command (if target
+ (string-append target "-strip")
+ "strip"))
+ (objcopy-command (if target
+ (string-append target "-objcopy")
+ "objcopy"))
+ (strip-flags '("--strip-unneeded"
+ "--enable-deterministic-archives"))
+ (strip-directories '("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ #:allow-other-keys)
+ (define debug-output
+ ;; If an output is called "debug", then that's where debugging information
+ ;; will be stored instead of being discarded.
+ (assoc-ref outputs "debug"))
+
+ (define debug-file-extension
+ ;; File name extension for debugging information.
+ ".debug")
+
+ (define (debug-file file)
+ ;; Return the name of the debug file for FILE, an absolute file name.
+ ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE,
+ ;; which is where GDB looks for it (info "(gdb) Separate Debug Files").
+ (string-append debug-output "/lib/debug/"
+ file debug-file-extension))
+
+ (define (make-debug-file file)
+ ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE.
+ (let ((debug (debug-file file)))
+ (mkdir-p (dirname debug))
+ (copy-file file debug)
+ (invoke strip-command "--only-keep-debug" debug)
+ (chmod debug #o400)))
+
+ (define (add-debug-link file)
+ ;; Add a debug link in FILE (info "(binutils) strip").
+
+ ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug
+ ;; link around so it can compute a CRC of that file (see the
+ ;; `bfd_fill_in_gnu_debuglink_section' function.) No reference to
+ ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
+ ;; file.
+ (invoke objcopy-command "--enable-deterministic-archives"
+ (string-append "--add-gnu-debuglink="
+ (debug-file file))
+ file))
+
+ (define (strip-dir dir)
+ (format #t "stripping binaries in ~s with ~s and flags ~s~%"
+ dir strip-command strip-flags)
+ (when debug-output
+ (format #t "debugging output written to ~s using ~s~%"
+ debug-output objcopy-command))
+
+ (for-each (lambda (file)
+ (when (or (elf-file? file) (ar-file? file))
+ ;; If an error occurs while processing a file, issue a
+ ;; warning and continue to the next file.
+ (guard (c ((invoke-error? c)
+ (format (current-error-port)
+ "warning: ~a: program ~s exited\
+~@[ with non-zero exit status ~a~]\
+~@[ terminated by signal ~a~]~%"
+ file
+ (invoke-error-program c)
+ (invoke-error-exit-status c)
+ (invoke-error-term-signal c))))
+ (when debug-output
+ (make-debug-file file))
+
+ ;; Ensure the file is writable.
+ (make-file-writable file)
+
+ (apply invoke strip-command
+ (append strip-flags (list file)))
+
+ (when debug-output
+ (add-debug-link file)))))
+ (find-files dir
+ (lambda (file stat)
+ ;; Ignore symlinks such as:
+ ;; libfoo.so -> libfoo.so.0.0.
+ (eq? 'regular (stat:type stat)))
+ #:stat lstat)))
+
+ (when strip-binaries?
+ (for-each
+ strip-dir
+ (append-map (match-lambda
+ ((_ . dir)
+ (filter-map (lambda (d)
+ (let ((sub (string-append dir "/" d)))
+ (and (directory-exists? sub) sub)))
+ strip-directories)))
+ outputs))))
+
+(define* (validate-runpath #:key
+ (validate-runpath? #t)
+ (elf-directories '("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ outputs #:allow-other-keys)
+ "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
+ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
+
+Since the ELF parser needs to have a copy of files in memory, better run this
+phase after stripping."
+ (define (sub-directory parent)
+ (lambda (directory)
+ (let ((directory (string-append parent "/" directory)))
+ (and (directory-exists? directory) directory))))
+
+ (define (validate directory)
+ (define (file=? file1 file2)
+ (let ((st1 (stat file1))
+ (st2 (stat file2)))
+ (= (stat:ino st1) (stat:ino st2))))
+
+ ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
+ ;; duplicates.
+ (let ((files (delete-duplicates (find-files directory (lambda (file stat)
+ (elf-file? file)))
+ file=?)))
+ (format (current-error-port)
+ "validating RUNPATH of ~a binaries in ~s...~%"
+ (length files) directory)
+ (every* validate-needed-in-runpath files)))
+
+ (if validate-runpath?
+ (let ((dirs (append-map (match-lambda
+ (("debug" . _)
+ ;; The "debug" output is full of ELF files
+ ;; that are not worth checking.
+ '())
+ ((name . output)
+ (filter-map (sub-directory output)
+ elf-directories)))
+ outputs)))
+ (unless (every* validate dirs)
+ (error "RUNPATH validation failed")))
+ (format (current-error-port) "skipping RUNPATH validation~%")))
+
+(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))))
+
+(define* (reset-gzip-timestamps #:key outputs #:allow-other-keys)
+ "Reset embedded timestamps in gzip files found in OUTPUTS."
+ (define (process-directory directory)
+ (let ((files (find-files directory
+ (lambda (file stat)
+ (and (eq? 'regular (stat:type stat))
+ (or (string-suffix? ".gz" file)
+ (string-suffix? ".tgz" file))
+ (gzip-file? file)))
+ #:stat lstat)))
+ ;; Ensure the files are writable.
+ (for-each make-file-writable files)
+ (for-each reset-gzip-timestamp files)))
+
+ (match outputs
+ (((names . directories) ...)
+ (for-each process-directory directories))))
+
+(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)
+ (string-append link compressed-documentation-extension))))
+
+ (define (has-links? file)
+ ;; Return #t if FILE has hard links.
+ (> (stat:nlink (lstat file)) 1))
+
+ (define (points-to-symlink? symlink)
+ ;; Return #t if SYMLINK points to another symbolic link.
+ (let* ((target (readlink symlink))
+ (target-absolute (if (string-prefix? "/" target)
+ target
+ (string-append (dirname symlink)
+ "/" target))))
+ (catch 'system-error
+ (lambda ()
+ (symbolic-link? target-absolute))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (begin
+ (format (current-error-port)
+ "The symbolic link '~a' target is missing: '~a'\n"
+ symlink target-absolute)
+ #f)
+ (apply throw args))))))
+
+ (define (maybe-compress-directory directory regexp)
+ (when (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.)
+ ;; Also, do not retarget symbolic links pointing to other
+ ;; symbolic links, since these are not compressed.
+ (for-each retarget-symlink
+ (filter (lambda (symlink)
+ (and (not (points-to-symlink? symlink))
+ (string-match regexp symlink)))
+ symlinks))
+ (apply invoke documentation-compressor
+ (append documentation-compressor-flags
+ (remove has-links? regular-files)))))))))
+
+ (define (maybe-compress output)
+ (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) ...)
+ (for-each maybe-compress directories)))
+ (format #t "not compressing documentation~%")))
+
+(define* (delete-info-dir-file #:key outputs #:allow-other-keys)
+ "Delete any 'share/info/dir' file from OUTPUTS."
+ (for-each (match-lambda
+ ((output . directory)
+ (let ((info-dir-file (string-append directory "/share/info/dir")))
+ (when (file-exists? info-dir-file)
+ (delete-file info-dir-file)))))
+ outputs))
+
+
+(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
+ "Replace any references to executables in '.desktop' files with their
+absolute file names."
+ (define bin-directories
+ (append-map (match-lambda
+ ((_ . directory)
+ (list (string-append directory "/bin")
+ (string-append directory "/sbin"))))
+ outputs))
+
+ (define (which program)
+ (or (search-path bin-directories program)
+ (begin
+ (format (current-error-port)
+ "warning: '.desktop' file refers to '~a', \
+which cannot be found~%"
+ program)
+ program)))
+
+ (for-each (match-lambda
+ ((_ . directory)
+ (let ((applications (string-append directory
+ "/share/applications")))
+ (when (directory-exists? applications)
+ (let ((files (find-files applications "\\.desktop$")))
+ (format #t "adjusting ~a '.desktop' files in ~s~%"
+ (length files) applications)
+
+ ;; '.desktop' files contain translations and are always
+ ;; UTF-8-encoded.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (substitute* files
+ (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+ (string-append "Exec=" (which binary) rest))
+ (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+ (string-append "TryExec="
+ (which binary) rest)))))))))
+ outputs))
+
+(define* (make-dynamic-linker-cache #:key outputs
+ (make-dynamic-linker-cache? #t)
+ #:allow-other-keys)
+ "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the
+OUTPUTS. This reduces application startup time by avoiding the 'stat' storm
+that traversing all the RUNPATH entries entails."
+ (define (make-cache-for-output directory)
+ (define bin-directories
+ (filter-map (lambda (sub-directory)
+ (let ((directory (string-append directory "/"
+ sub-directory)))
+ (and (directory-exists? directory)
+ directory)))
+ '("bin" "sbin" "libexec")))
+
+ (define programs
+ ;; Programs that can benefit from the ld.so cache.
+ (append-map (lambda (directory)
+ (if (directory-exists? directory)
+ (find-files directory
+ (lambda (file stat)
+ (and (executable-file? file)
+ (elf-file? file))))
+ '()))
+ bin-directories))
+
+ (define library-path
+ ;; Directories containing libraries that PROGRAMS depend on,
+ ;; recursively.
+ (delete-duplicates
+ (append-map (lambda (program)
+ (map dirname (file-needed/recursive program)))
+ programs)))
+
+ (define cache-file
+ (string-append directory "/etc/ld.so.cache"))
+
+ (define ld.so.conf
+ (string-append (or (getenv "TMPDIR") "/tmp")
+ "/ld.so.conf"))
+
+ (unless (null? library-path)
+ (mkdir-p (dirname cache-file))
+ (guard (c ((invoke-error? c)
+ ;; Do not treat 'ldconfig' failure as an error.
+ (format (current-error-port)
+ "warning: 'ldconfig' failed:~%")
+ (report-invoke-error c (current-error-port))))
+ ;; Create a config file to tell 'ldconfig' where to look for the
+ ;; libraries that PROGRAMS need.
+ (call-with-output-file ld.so.conf
+ (lambda (port)
+ (for-each (lambda (directory)
+ (display directory port)
+ (newline port))
+ library-path)))
+
+ (invoke "ldconfig" "-f" ld.so.conf "-C" cache-file)
+ (format #t "created '~a' from ~a library search path entries~%"
+ cache-file (length library-path)))))
+
+ (if make-dynamic-linker-cache?
+ (match outputs
+ (((_ . directories) ...)
+ (for-each make-cache-for-output directories)))
+ (format #t "ld.so cache not built~%")))
+
+(define %license-file-regexp
+ ;; Regexp matching license files.
+ "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")
+
+(define* (install-license-files #:key outputs
+ (license-file-regexp %license-file-regexp)
+ out-of-source?
+ #:allow-other-keys)
+ "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
+ (define (find-source-directory package)
+ ;; For an out-of-source build, guess the source directory location
+ ;; relative to the current directory. Return #f on failure.
+ (match (scandir ".."
+ (lambda (file)
+ (and (not (member file '("." ".." "build")))
+ (file-is-directory?
+ (string-append "../" file)))))
+ (() ;hmm, no source
+ #f)
+ ((source) ;only one other file
+ (string-append "../" source))
+ ((directories ...) ;pick the most likely one
+ ;; This happens for example with libstdc++, which lives within the GCC
+ ;; source tree.
+ (any (lambda (directory)
+ (and (string-prefix? package directory)
+ (string-append "../" directory)))
+ directories))))
+
+ (define (copy-to-directories directories sub-directory)
+ (lambda (file)
+ (for-each (if (file-is-directory? file)
+ (cut copy-recursively file <>)
+ (cut install-file file <>))
+ (map (cut string-append <> "/" sub-directory)
+ directories))))
+
+ (let* ((regexp (make-regexp license-file-regexp))
+ (out (or (assoc-ref outputs "out")
+ (match outputs
+ (((_ . output) _ ...)
+ output))))
+ (package (strip-store-file-name out))
+ (outputs (match outputs
+ (((_ . outputs) ...)
+ outputs)))
+ (source (if out-of-source?
+ (find-source-directory
+ (package-name->name+version package))
+ "."))
+ (files (and source
+ (scandir source
+ (lambda (file)
+ (regexp-exec regexp file))))))
+ (if files
+ (begin
+ (format #t "installing ~a license files from '~a'~%"
+ (length files) source)
+ (for-each (copy-to-directories outputs
+ (string-append "share/doc/"
+ package))
+ (map (cut string-append source "/" <>) files)))
+ (format (current-error-port)
+ "failed to find license files~%"))))
+
+(define %standard-phases
+ ;; Standard build phases, as a list of symbol/procedure pairs.
+ (let-syntax ((phases (syntax-rules ()
+ ((_ p ...) `((p . ,p) ...)))))
+ (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack
+ bootstrap
+ patch-usr-bin-file
+ patch-source-shebangs configure patch-generated-file-shebangs
+ build check install
+ patch-shebangs strip
+ validate-runpath
+ validate-documentation-location
+ delete-info-dir-file
+ patch-dot-desktop-files
+ make-dynamic-linker-cache
+ install-license-files
+ reset-gzip-timestamps
+ compress-documentation)))
+
+\f
+(define* (gnu-build2 #:key (source #f) (outputs #f) (inputs #f)
+ (phases %standard-phases)
+ #:allow-other-keys
+ #:rest args)
+ "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES
+in order. Return #t if all the PHASES succeeded, #f otherwise."
+ (define (elapsed-time end start)
+ (let ((diff (time-difference end start)))
+ (+ (time-second diff)
+ (/ (time-nanosecond diff) 1e9))))
+
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
+
+ ;; Encoding/decoding errors shouldn't be silent.
+ (fluid-set! %default-port-conversion-strategy 'error)
+
+ (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ (exit 1)))
+ ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
+ ;; PHASES can pick the keyword arguments it's interested in.
+ (for-each (match-lambda
+ ((name . proc)
+ (let ((start (current-time time-monotonic)))
+ (define (end-of-phase success?)
+ (let ((end (current-time time-monotonic)))
+ (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
+ name success?
+ (elapsed-time end start))
+
+ ;; Dump the environment variables as a shell script,
+ ;; for handy debugging.
+ (system "export > $NIX_BUILD_TOP/environment-variables")))
+
+ (format #t "starting phase `~a'~%" name)
+ (with-throw-handler #t
+ (lambda ()
+ (apply proc args)
+ (end-of-phase #t))
+ (lambda args
+ ;; This handler executes before the stack is unwound.
+ ;; The exception is automatically re-thrown from here,
+ ;; and we should get a proper backtrace.
+ (format (current-error-port)
+ "error: in phase '~a': uncaught exception:
+~{~s ~}~%" name args)
+ (end-of-phase #f))))))
+ phases)))
base-commit: e2bcd41ce35b051f311e36dfd104d36ce1145f8b
prerequisite-patch-id: 77c51f63cfaba6cafe4e7125f50077d6dc5ca24a
prerequisite-patch-id: 776778c03bce9b7ad3ab94a120f42b764c00fcae
prerequisite-patch-id: 4910d08bdc27384d76030b6ac491ad2c2ed0957f
prerequisite-patch-id: 2de8762a6381a93682d0fe4c893962b9803362b0
prerequisite-patch-id: b9b6f21a2db3f7a5ef82bb11ed23f69749cc6b3d
--
2.38.1
^ permalink raw reply related [flat|nested] 11+ messages in thread