guix/build/meson-build-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build meson-build-system)
  20   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  21   #:use-module ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:)
  22   #:use-module (guix build utils)
  23   #:use-module (guix build rpath)
  24   #:use-module (guix build gremlin)
  25   #:use-module (guix elf)
  26   #:use-module (ice-9 match)
  27   #:use-module (rnrs io ports)
  28   #:use-module (srfi srfi-1)
  29   #:export (%standard-phases
  30             meson-build))
  31
  32 ;; Commentary:
  33 ;;
  34 ;; Builder-side code of the standard meson build procedure.
  35 ;;
  36 ;; Code:
  37
  38 (define* (configure #:key outputs configure-flags build-type
  39                     #:allow-other-keys)
  40   "Configure the given package."
  41   (let* ((out (assoc-ref outputs "out"))
  42          (source-dir (getcwd))
  43          (build-dir "../build")
  44          (prefix (assoc-ref outputs "out"))
  45          (args `(,(string-append "--prefix=" prefix)
  46                  ,(string-append "--buildtype=" build-type)
  47                  ,@configure-flags
  48                  ,source-dir)))
  49     (mkdir build-dir)
  50     (chdir build-dir)
  51     (zero? (apply system* "meson" args))))
  52
  53 (define* (build #:key parallel-build?
  54                 #:allow-other-keys)
  55   "Build a given meson package."
  56   (zero? (apply system* "ninja"
  57                 (if parallel-build?
  58                     `("-j" ,(number->string (parallel-job-count)))
  59                     '("-j" "1")))))
  60
  61 (define* (check #:key test-target parallel-tests? tests?
  62                 #:allow-other-keys)
  63   (setenv "MESON_TESTTHREADS"
  64           (if parallel-tests?
  65               (number->string (parallel-job-count))
  66               "1"))
  67   (if tests?
  68       (zero? (system* "ninja" test-target))
  69       (begin
  70         (format #t "test suite not run~%")
  71         #t)))
  72
  73 (define* (install #:rest args)
  74   (zero? (system* "ninja" "install")))
  75
  76 (define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec"
  77                                                "bin" "sbin"))
  78                       outputs #:allow-other-keys)
  79   "Try to make sure all ELF files in ELF-DIRECTORIES are able to find their
  80 local dependencies in their RUNPATH, by searching for the needed libraries in
  81 the directories of the package, and adding them to the RUNPATH if needed.
  82 Also shrink the RUNPATH to what is needed,
  83 since a lot of directories are left over from the build phase of meson,
  84 for example libraries only needed for the tests."
  85
  86   ;; Find the directories (if any) that contains DEP-NAME.  The directories
  87   ;; searched are the ones that ELF-FILES are in.
  88   (define (find-deps dep-name elf-files)
  89     (map dirname (filter (lambda (file)
  90                            (string=? dep-name (basename file)))
  91                          elf-files)))
  92
  93   ;; Return a list of libraries that FILE needs.
  94   (define (file-needed file)
  95     (let* ((elf (call-with-input-file file
  96                   (compose parse-elf get-bytevector-all)))
  97            (dyninfo (elf-dynamic-info elf)))
  98       (if dyninfo
  99           (elf-dynamic-info-needed dyninfo)
 100           '())))
 101
 102
 103   ;; If FILE needs any libs that are part of ELF-FILES, the RUNPATH
 104   ;; is modified accordingly.
 105   (define (handle-file file elf-files)
 106     (let* ((dep-dirs (concatenate (map (lambda (dep-name)
 107                                          (find-deps dep-name elf-files))
 108                                        (file-needed file)))))
 109       (unless (null? dep-dirs)
 110         (augment-rpath file (string-join dep-dirs ":")))))
 111
 112   (define handle-output
 113     (match-lambda
 114       ((output . directory)
 115        (let* ((elf-dirnames (map (lambda (subdir)
 116                                    (string-append directory "/" subdir))
 117                                  elf-directories))
 118               (existing-elf-dirs (filter (lambda (dir)
 119                                             (and (file-exists? dir)
 120                                                  (file-is-directory? dir)))
 121                                           elf-dirnames))
 122               (elf-pred (lambda (name stat)
 123                           (elf-file? name)))
 124               (elf-list (concatenate (map (lambda (dir)
 125                                             (find-files dir elf-pred))
 126                                           existing-elf-dirs))))
 127          (for-each (lambda (elf-file)
 128                      (system* "patchelf" "--shrink-rpath" elf-file)
 129                      (handle-file elf-file elf-list))
 130                    elf-list)))))
 131   (for-each handle-output outputs)
 132   #t)
 133
 134 (define %standard-phases
 135   ;; The standard-phases of glib-or-gtk contains a superset of the phases
 136   ;; from the gnu-build-system.  If the glib-or-gtk? key is #f (the default)
 137   ;; then the extra phases will be removed again in (guix build-system meson).
 138   (modify-phases glib-or-gtk:%standard-phases
 139     (replace 'configure configure)
 140     (replace 'build build)
 141     (replace 'check check)
 142     (replace 'install install)
 143     (add-after 'strip 'fix-runpath fix-runpath)))
 144
 145 (define* (meson-build #:key inputs phases
 146                       #:allow-other-keys #:rest args)
 147   "Build the given package, applying all of PHASES in order."
 148   (apply gnu:gnu-build #:inputs inputs #:phases phases args))
 149
 150 ;;; meson-build-system.scm ends here