diff options
Diffstat (limited to 'nonguix/build')
| -rw-r--r-- | nonguix/build/binary-build-system.scm | 155 | ||||
| -rw-r--r-- | nonguix/build/utils.scm | 111 |
2 files changed, 0 insertions, 266 deletions
diff --git a/nonguix/build/binary-build-system.scm b/nonguix/build/binary-build-system.scm deleted file mode 100644 index 6a676ae..0000000 --- a/nonguix/build/binary-build-system.scm +++ /dev/null @@ -1,155 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> -;;; -;;; This file is not 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 (nonguix build binary-build-system) - #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (nonguix build utils) - #:use-module (guix build utils) - #:use-module (ice-9 match) - #:export (%standard-phases - binary-build)) - -;; Commentary: -;; -;; Builder-side code of the standard binary build procedure. -;; -;; Code: - -(define (new-install) - "Return the copy-build-system `install' procedure." - (@@ (guix build copy-build-system) install)) - -(define* (old-install #:key install-plan outputs #:allow-other-keys) - "Copy files from the \"source\" build input to the \"out\" output according to INSTALL-PLAN. - -An INSTALL-PLAN is made of three elements: - -- A source path which is a file or directory from the \"source\" build input. -- Patterns of the files to copy (only useful if the source path is a directory). -- The target destination. - -If the target ends with a slash, it represents the target directory. If not, it -represent the target full path, which only makes sense for single files." - (define (install-file file target) - (let ((target (string-append (assoc-ref outputs "out") - "/" target - (if (string-suffix? "/" target) - (string-append "/" file) - "")))) - (mkdir-p (dirname target)) - (copy-file file target))) - - (define (install-file-pattern pattern target) - (for-each - (lambda (file) - (install-file file target)) - (find-files "." pattern))) - - (define (install plan) - (match plan - ((file-or-directory files target) - (if (file-is-directory? file-or-directory) - (with-directory-excursion file-or-directory - (for-each - (lambda (pattern) - (install-file-pattern pattern target)) - files)) - (install-file file-or-directory target))))) - - (for-each install install-plan) - #t) - -(define* (install #:key install-plan outputs #:allow-other-keys) - (define (install-old-format) - (warn "Install-plan format deprecated. -Please update to the format of the copy-build-system.") - (old-install #:install-plan install-plan #:outputs outputs)) - (match (car install-plan) - ((source (. matches) target) - (install-old-format)) - ((source #f target) - (install-old-format)) - (_ ((new-install) #:install-plan install-plan #:outputs outputs)))) - -(define* (patchelf #:key inputs outputs patchelf-plan #:allow-other-keys) - "Set the interpreter and the RPATH of files as per the PATCHELF-PLAN. - -The PATCHELF-PLAN elements are lists of: - -- The file to patch. -- The inputs (as strings) to include in the rpath, e.g. \"mesa\". - -Both executables and dynamic libraries are accepted. -The inputs are optional when the file is an executable." - (define (binary-patch binary interpreter runpath) - (unless (string-contains binary ".so") - ;; Use `system*' and not `invoke' since this may raise an error if - ;; library does not end with .so. - (system* "patchelf" "--set-interpreter" interpreter binary)) - (when runpath - (let ((rpath (string-join - (map - (lambda (input-or-output) - (cond - ((assoc-ref outputs input-or-output) - (string-append (assoc-ref outputs input-or-output) "/lib")) - ((assoc-ref inputs input-or-output) - (string-append (assoc-ref inputs input-or-output) "/lib")) - (else (error (format #f "`~a' not found among the inputs nor the outputs." input-or-output))))) - runpath) - ":"))) - (invoke "patchelf" "--set-rpath" rpath binary))) - #t) - - (when (and patchelf-plan - (not (null? patchelf-plan))) - (let ((interpreter (car (find-files (assoc-ref inputs "libc") "ld-linux.*\\.so"))) - (interpreter32 (car (find-files (assoc-ref inputs "libc32") "ld-linux.*\\.so")))) - (for-each - (lambda (plan) - (match plan - ((binary runpath) - (binary-patch binary (if (64-bit? binary) - interpreter - interpreter32) - runpath)) - ((binary) - (binary-patch binary (if (64-bit? binary) - interpreter - interpreter32) - #f)))) - patchelf-plan))) - #t) - -(define %standard-phases - ;; Everything is as with the GNU Build System except for the `configure' - ;; , `build', `check' and `install' phases. - (modify-phases gnu:%standard-phases - (delete 'bootstrap) - (delete 'configure) - (delete 'build) - (delete 'check) - (add-before 'install 'patchelf patchelf) - (replace 'install install))) - -(define* (binary-build #:key inputs (phases %standard-phases) - #:allow-other-keys #:rest args) - "Build the given package, applying all of PHASES in order." - (apply gnu:gnu-build #:inputs inputs #:phases phases args)) - -;;; binary-build-system.scm ends here diff --git a/nonguix/build/utils.scm b/nonguix/build/utils.scm deleted file mode 100644 index ab437f2..0000000 --- a/nonguix/build/utils.scm +++ /dev/null @@ -1,111 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> -;;; Copyright © 2020 Alex Griffin <a@ajgrf.com> -;;; -;;; This file is not 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 (nonguix build utils) - #:use-module (ice-9 match) - #:use-module (ice-9 binary-ports) - #:use-module (guix build utils) - #:use-module (srfi srfi-26) - #:export (64-bit? - make-wrapper - concatenate-files)) - -(define (64-bit? file) - "Return true if ELF file is in 64-bit format, false otherwise. -See https://en.wikipedia.org/wiki/Executable_and_Linkable_Format#File_header." - (with-input-from-file file - (lambda () - (= 2 - (array-ref (get-bytevector-n (current-input-port) 5) 4))) - #:binary #t)) - -(define* (make-wrapper wrapper real-file #:key (skip-argument-0? #f) #:rest vars) - "Like `wrap-program' but create WRAPPER around REAL-FILE. -The wrapper automatically changes directory to that of REAL-FILE. - -Example: - - (make-wrapper \"bin/foo\" \"sub-dir/original-foo\" - '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\")) - '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\" - \"/qux/certs\"))) - -will create 'bin/foo' with the following -contents: - - #!location/of/bin/bash - export PATH=\"/gnu/.../bar/bin\" - export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\" - cd sub-dir - exec -a $0 sub-dir/original-foo \"$@\"." - (define (export-variable lst) - ;; Return a string that exports an environment variable. - (match lst - ((var sep '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest sep))) - ((var sep 'prefix rest) - (format #f "export ~a=\"~a${~a:+~a}$~a\"" - var (string-join rest sep) var sep var)) - ((var sep 'suffix rest) - (format #f "export ~a=\"$~a${~a+~a}~a\"" - var var var sep (string-join rest sep))) - ((var '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest ":"))) - ((var 'prefix rest) - (format #f "export ~a=\"~a${~a:+:}$~a\"" - var (string-join rest ":") var var)) - ((var 'suffix rest) - (format #f "export ~a=\"$~a${~a:+:}~a\"" - var var var (string-join rest ":"))))) - - (define (remove-keyword-arguments lst) - (match lst - (() '()) - (((? keyword? _) _ lst ...) - (remove-keyword-arguments lst)) - (_ lst))) - - (mkdir-p (dirname wrapper)) - (call-with-output-file wrapper - (lambda (port) - (format port - (if skip-argument-0? - "#!~a~%~a~%cd \"~a\"~%exec \"~a\" \"$@\"~%" - "#!~a~%~a~%cd \"~a\"~%exec -a \"$0\" \"~a\" \"$@\"~%") - (which "bash") - (string-join - (map export-variable (remove-keyword-arguments vars)) - "\n") - (dirname real-file) - (canonicalize-path real-file)))) - (chmod wrapper #o755)) - -(define (concatenate-files files result) - "Make RESULT the concatenation of all of FILES." - (define (dump file port) - (put-bytevector - port - (call-with-input-file file - get-bytevector-all))) - - (call-with-output-file result - (lambda (port) - (for-each (cut dump <> port) files)))) |