distro/packages/ld-wrapper.scm

   1 #!@BASH@
   2 # -*- mode: scheme; coding: utf-8; -*-
   3
   4 # XXX: We have to go through Bash because there's no command-line switch to
   5 # augment %load-compiled-path, and because of the silly 127-byte limit for
   6 # the shebang line in Linux.
   7 # Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
   8 # .go file (see <http://bugs.gnu.org/12519>).
   9
  10 main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
  11 exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@"
  12 !#
  13 ;;; GNU Guix --- Functional package management for GNU
  14 ;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
  15 ;;;
  16 ;;; This file is part of GNU Guix.
  17 ;;;
  18 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  19 ;;; under the terms of the GNU General Public License as published by
  20 ;;; the Free Software Foundation; either version 3 of the License, or (at
  21 ;;; your option) any later version.
  22 ;;;
  23 ;;; GNU Guix is distributed in the hope that it will be useful, but
  24 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26 ;;; GNU General Public License for more details.
  27 ;;;
  28 ;;; You should have received a copy of the GNU General Public License
  29 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  30
  31 (define-module (gnu build-support ld-wrapper)
  32   #:use-module (srfi srfi-1)
  33   #:export (ld-wrapper))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; This is a wrapper for the linker.  Its purpose is to inspect the -L and
  38 ;;; -l switches passed to the linker, add corresponding -rpath arguments, and
  39 ;;; invoke the actual linker with this new set of arguments.
  40 ;;;
  41 ;;; The alternatives to this hack would be:
  42 ;;;
  43 ;;;   1. Using $LD_RUN_PATH.  However, that would tend to include more than
  44 ;;;      needed in the RPATH; for instance, given a package with `libfoo' as
  45 ;;;      an input, all its binaries would have libfoo in their RPATH,
  46 ;;;      regardless of whether they actually NEED it.
  47 ;;;
  48 ;;;   2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
  49 ;;;      `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
  50 ;;;      However, this doesn't work when $LIBRARY_PATH is used, because the
  51 ;;;      additional `-L' switches are not matched by the above rule, because
  52 ;;;      the rule only matches explicit user-provided switches.  See
  53 ;;;      <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
  54 ;;;
  55 ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
  56 ;;; libraries outside the store.
  57 ;;;
  58 ;;; Code:
  59
  60 (define %real-ld
  61   ;; Name of the linker that we wrap.
  62   "@LD@")
  63
  64 (define %store-directory
  65   ;; File name of the store.
  66   (or (getenv "NIX_STORE") "/nix/store"))
  67
  68 (define %temporary-directory
  69   ;; Temporary directory.
  70   (or (getenv "TMPDIR") "/tmp"))
  71
  72 (define %build-directory
  73   ;; Top build directory when run from a builder.
  74   (getenv "NIX_BUILD_TOP"))
  75
  76 (define %allow-impurities?
  77   ;; Whether to allow references to libraries outside the store.
  78   (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
  79
  80 (define %debug?
  81   ;; Whether to emit debugging output.
  82   (getenv "GUIX_LD_WRAPPER_DEBUG"))
  83
  84 (define (pure-file-name? file)
  85   ;; Return #t when FILE is the name of a file either within the store or
  86   ;; within the build directory.
  87   (or (not (string-prefix? "/" file))
  88       (string-prefix? %store-directory file)
  89       (string-prefix? %temporary-directory file)
  90       (and %build-directory
  91            (string-prefix? %build-directory file))))
  92
  93 (define (switch-arguments switch args)
  94   ;; Return the arguments passed for the occurrences of SWITCH--e.g.,
  95   ;; "-L"--in ARGS.
  96   (let ((prefix-len (string-length switch)))
  97     (fold-right (lambda (arg path)
  98                   (if (string-prefix? switch arg)
  99                       (cons (substring arg prefix-len) path)
 100                       path))
 101                 '()
 102                 args)))
 103
 104 (define (library-path args)
 105   ;; Return the library search path extracted from `-L' switches in ARGS.
 106   ;; Note: allow references to out-of-store directories.  When this leads to
 107   ;; actual impurities, this is caught later.
 108   (switch-arguments "-L" args))
 109
 110 (define (library-files-linked args)
 111   ;; Return the file names of shared libraries explicitly linked against via
 112   ;; `-l' in ARGS.
 113   (map (lambda (lib)
 114          (string-append "lib" lib ".so"))
 115        (switch-arguments "-l" args)))
 116
 117 (define (rpath-arguments lib-path library-files)
 118   ;; Return the `-rpath' argument list for each of LIBRARY-FILES found in
 119   ;; LIB-PATH.
 120   (fold-right (lambda (file args)
 121                 (let ((absolute (search-path lib-path file)))
 122                   (if absolute
 123                       (if (or %allow-impurities?
 124                               (pure-file-name? absolute))
 125                           (cons* "-rpath" (dirname absolute)
 126                                  args)
 127                           (begin
 128                             (format (current-error-port)
 129                                     "ld-wrapper: error: attempt to use impure library ~s~%"
 130                                     absolute)
 131                             (exit 1)))
 132                       args)))
 133               '()
 134               library-files))
 135
 136 (define (ld-wrapper . args)
 137   ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
 138   (let* ((lib-path (library-path args))
 139          (libs     (library-files-linked args))
 140          (args     (append args (rpath-arguments lib-path libs))))
 141     (if %debug?
 142         (format (current-error-port)
 143                 "ld-wrapper: invoking `~a' with ~s~%"
 144                 %real-ld args))
 145     (apply execl %real-ld (basename %real-ld) args)))
 146
 147 ;;; ld-wrapper.scm ends here