| 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 \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@" |
| 12 | !# |
| 13 | ;;; GNU Guix --- Functional package management for GNU |
| 14 | ;;; Copyright © 2012, 2013, 2014, 2015 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 | #:use-module (ice-9 match) |
| 34 | #:export (ld-wrapper)) |
| 35 | |
| 36 | ;;; Commentary: |
| 37 | ;;; |
| 38 | ;;; This is a wrapper for the linker. Its purpose is to inspect the -L and |
| 39 | ;;; -l switches passed to the linker, add corresponding -rpath arguments, and |
| 40 | ;;; invoke the actual linker with this new set of arguments. |
| 41 | ;;; |
| 42 | ;;; The alternatives to this hack would be: |
| 43 | ;;; |
| 44 | ;;; 1. Using $LD_RUN_PATH. However, that would tend to include more than |
| 45 | ;;; needed in the RPATH; for instance, given a package with `libfoo' as |
| 46 | ;;; an input, all its binaries would have libfoo in their RPATH, |
| 47 | ;;; regardless of whether they actually NEED it. |
| 48 | ;;; |
| 49 | ;;; 2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a |
| 50 | ;;; `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'. |
| 51 | ;;; However, this doesn't work when $LIBRARY_PATH is used, because the |
| 52 | ;;; additional `-L' switches are not matched by the above rule, because |
| 53 | ;;; the rule only matches explicit user-provided switches. See |
| 54 | ;;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details. |
| 55 | ;;; |
| 56 | ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to |
| 57 | ;;; libraries outside the store. |
| 58 | ;;; |
| 59 | ;;; Code: |
| 60 | |
| 61 | (define %real-ld |
| 62 | ;; Name of the linker that we wrap. |
| 63 | "@LD@") |
| 64 | |
| 65 | (define %store-directory |
| 66 | ;; File name of the store. |
| 67 | (or (getenv "NIX_STORE") "/gnu/store")) |
| 68 | |
| 69 | (define %temporary-directory |
| 70 | ;; Temporary directory. |
| 71 | (or (getenv "TMPDIR") "/tmp")) |
| 72 | |
| 73 | (define %build-directory |
| 74 | ;; Top build directory when run from a builder. |
| 75 | (getenv "NIX_BUILD_TOP")) |
| 76 | |
| 77 | (define %allow-impurities? |
| 78 | ;; Whether to allow references to libraries outside the store. |
| 79 | (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")) |
| 80 | |
| 81 | (define %debug? |
| 82 | ;; Whether to emit debugging output. |
| 83 | (getenv "GUIX_LD_WRAPPER_DEBUG")) |
| 84 | |
| 85 | (define %disable-rpath? |
| 86 | ;; Whether to disable automatic '-rpath' addition. |
| 87 | (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) |
| 88 | |
| 89 | (define (readlink* file) |
| 90 | ;; Call 'readlink' until the result is not a symlink. |
| 91 | (define %max-symlink-depth 50) |
| 92 | |
| 93 | (let loop ((file file) |
| 94 | (depth 0)) |
| 95 | (define (absolute target) |
| 96 | (if (absolute-file-name? target) |
| 97 | target |
| 98 | (string-append (dirname file) "/" target))) |
| 99 | |
| 100 | (if (>= depth %max-symlink-depth) |
| 101 | file |
| 102 | (call-with-values |
| 103 | (lambda () |
| 104 | (catch 'system-error |
| 105 | (lambda () |
| 106 | (values #t (readlink file))) |
| 107 | (lambda args |
| 108 | (let ((errno (system-error-errno args))) |
| 109 | (if (or (= errno EINVAL) (= errno ENOENT)) |
| 110 | (values #f file) |
| 111 | (apply throw args)))))) |
| 112 | (lambda (success? target) |
| 113 | (if success? |
| 114 | (loop (absolute target) (+ depth 1)) |
| 115 | file)))))) |
| 116 | |
| 117 | (define (pure-file-name? file) |
| 118 | ;; Return #t when FILE is the name of a file either within the store |
| 119 | ;; (possibly via a symlink) or within the build directory. |
| 120 | (let ((file (readlink* file))) |
| 121 | (or (not (string-prefix? "/" file)) |
| 122 | (string-prefix? %store-directory file) |
| 123 | (string-prefix? %temporary-directory file) |
| 124 | (and %build-directory |
| 125 | (string-prefix? %build-directory file))))) |
| 126 | |
| 127 | (define (store-file-name? file) |
| 128 | ;; Return #t when FILE is a store file, possibly indirectly. |
| 129 | (string-prefix? %store-directory (readlink* file))) |
| 130 | |
| 131 | (define (shared-library? file) |
| 132 | ;; Return #t when FILE denotes a shared library. |
| 133 | (or (string-suffix? ".so" file) |
| 134 | (let ((index (string-contains file ".so."))) |
| 135 | ;; Since we cannot use regexps during bootstrap, roll our own. |
| 136 | (and index |
| 137 | (string-every (char-set-union (char-set #\.) char-set:digit) |
| 138 | (string-drop file (+ index 3))))))) |
| 139 | |
| 140 | (define (library-files-linked args) |
| 141 | ;; Return the file names of shared libraries explicitly linked against via |
| 142 | ;; `-l' or with an absolute file name in ARGS. |
| 143 | (define path+files+args |
| 144 | (fold (lambda (argument result) |
| 145 | (match result |
| 146 | ((library-path library-files |
| 147 | ((and flag |
| 148 | (or "-dynamic-linker" "-plugin")) |
| 149 | . rest)) |
| 150 | ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when |
| 151 | ;; passed '-plugin liblto_plugin.so', ignore |
| 152 | ;; 'liblto_plugin.so'. See <http://bugs.gnu.org/20102>. |
| 153 | (list library-path |
| 154 | library-files |
| 155 | (cons* argument flag rest))) |
| 156 | ((library-path library-files previous-args) |
| 157 | (cond ((string-prefix? "-L" argument) ;augment the search path |
| 158 | (list (append library-path |
| 159 | (list (string-drop argument 2))) |
| 160 | library-files |
| 161 | (cons argument previous-args))) |
| 162 | ((string-prefix? "-l" argument) ;add library |
| 163 | (let* ((lib (string-append "lib" |
| 164 | (string-drop argument 2) |
| 165 | ".so")) |
| 166 | (full (search-path library-path lib))) |
| 167 | (list library-path |
| 168 | (if full |
| 169 | (cons full library-files) |
| 170 | library-files) |
| 171 | (cons argument previous-args)))) |
| 172 | ((and (string-prefix? %store-directory argument) |
| 173 | (shared-library? argument)) ;add library |
| 174 | (list library-path |
| 175 | (cons argument library-files) |
| 176 | (cons argument previous-args))) |
| 177 | (else |
| 178 | (list library-path |
| 179 | library-files |
| 180 | (cons argument previous-args))))))) |
| 181 | (list '() '() '()) |
| 182 | args)) |
| 183 | |
| 184 | (match path+files+args |
| 185 | ((path files arguments) |
| 186 | (reverse files)))) |
| 187 | |
| 188 | (define (rpath-arguments library-files) |
| 189 | ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of |
| 190 | ;; absolute file names. |
| 191 | (fold-right (lambda (file args) |
| 192 | ;; Add '-rpath' if and only if FILE is in the store; we don't |
| 193 | ;; want to add '-rpath' for files under %BUILD-DIRECTORY or |
| 194 | ;; %TEMPORARY-DIRECTORY because that could leak to installed |
| 195 | ;; files. |
| 196 | (cond ((and (not %disable-rpath?) |
| 197 | (store-file-name? file)) |
| 198 | (cons* "-rpath" (dirname file) args)) |
| 199 | ((or %allow-impurities? |
| 200 | (pure-file-name? file)) |
| 201 | args) |
| 202 | (else |
| 203 | (begin |
| 204 | (format (current-error-port) |
| 205 | "ld-wrapper: error: attempt to use \ |
| 206 | impure library ~s~%" |
| 207 | file) |
| 208 | (exit 1))))) |
| 209 | '() |
| 210 | library-files)) |
| 211 | |
| 212 | (define (ld-wrapper . args) |
| 213 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. |
| 214 | (let* ((libs (library-files-linked args)) |
| 215 | (args (append args (rpath-arguments libs)))) |
| 216 | (when %debug? |
| 217 | (format (current-error-port) |
| 218 | "ld-wrapper: libraries linked: ~s~%" libs) |
| 219 | (format (current-error-port) |
| 220 | "ld-wrapper: invoking `~a' with ~s~%" |
| 221 | %real-ld args)) |
| 222 | (apply execl %real-ld (basename %real-ld) args))) |
| 223 | |
| 224 | ;;; ld-wrapper.scm ends here |