Commit | Line | Data |
---|---|---|
dfb53ee2 | 1 | #!@BASH@ |
82dc2b9a LC |
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 | ||
dfb53ee2 | 10 | main="(@ (gnu build-support ld-wrapper) ld-wrapper)" |
9bab6bea | 11 | exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@" |
82dc2b9a | 12 | !# |
4155e2a9 | 13 | ;;; GNU Guix --- Functional package management for GNU |
d8491ba5 | 14 | ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
82dc2b9a | 15 | ;;; |
4155e2a9 | 16 | ;;; This file is part of GNU Guix. |
82dc2b9a | 17 | ;;; |
4155e2a9 | 18 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
82dc2b9a LC |
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 | ;;; | |
4155e2a9 | 23 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
82dc2b9a LC |
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 | |
4155e2a9 | 29 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
82dc2b9a | 30 | |
dfb53ee2 | 31 | (define-module (gnu build-support ld-wrapper) |
82dc2b9a | 32 | #:use-module (srfi srfi-1) |
d8491ba5 | 33 | #:use-module (ice-9 match) |
82dc2b9a LC |
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. | |
8be3b8a3 | 67 | (or (getenv "NIX_STORE") "/gnu/store")) |
82dc2b9a LC |
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 | ||
71b67168 LC |
85 | (define %disable-rpath? |
86 | ;; Whether to disable automatic '-rpath' addition. | |
87 | (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) | |
88 | ||
41fc0eb9 LC |
89 | (define (readlink* file) |
90 | ;; Call 'readlink' until the result is not a symlink. | |
cfbf7877 LC |
91 | (define %max-symlink-depth 50) |
92 | ||
93 | (let loop ((file file) | |
94 | (depth 0)) | |
cbbb11c8 LC |
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)))))) | |
41fc0eb9 LC |
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. | |
cbbb11c8 | 120 | (let ((file (readlink* file))) |
cfbf7877 LC |
121 | (or (not (string-prefix? "/" file)) |
122 | (string-prefix? %store-directory file) | |
123 | (string-prefix? %temporary-directory file) | |
41fc0eb9 LC |
124 | (and %build-directory |
125 | (string-prefix? %build-directory file))))) | |
82dc2b9a | 126 | |
51d0cd9b LC |
127 | (define (store-file-name? file) |
128 | ;; Return #t when FILE is a store file, possibly indirectly. | |
cbbb11c8 | 129 | (string-prefix? %store-directory (readlink* file))) |
51d0cd9b | 130 | |
f307947e LC |
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 | ||
82dc2b9a LC |
140 | (define (library-files-linked args) |
141 | ;; Return the file names of shared libraries explicitly linked against via | |
d8491ba5 | 142 | ;; `-l' or with an absolute file name in ARGS. |
4a2b74bf | 143 | (define path+files+args |
d8491ba5 LC |
144 | (fold (lambda (argument result) |
145 | (match result | |
b5616bc3 LC |
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>. | |
4a2b74bf LC |
153 | (list library-path |
154 | library-files | |
b5616bc3 | 155 | (cons* argument flag rest))) |
4a2b74bf | 156 | ((library-path library-files previous-args) |
d8491ba5 | 157 | (cond ((string-prefix? "-L" argument) ;augment the search path |
4a2b74bf | 158 | (list (append library-path |
d8491ba5 | 159 | (list (string-drop argument 2))) |
4a2b74bf LC |
160 | library-files |
161 | (cons argument previous-args))) | |
d8491ba5 LC |
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))) | |
4a2b74bf LC |
167 | (list library-path |
168 | (if full | |
169 | (cons full library-files) | |
170 | library-files) | |
171 | (cons argument previous-args)))) | |
d8491ba5 | 172 | ((and (string-prefix? %store-directory argument) |
f307947e | 173 | (shared-library? argument)) ;add library |
4a2b74bf LC |
174 | (list library-path |
175 | (cons argument library-files) | |
176 | (cons argument previous-args))) | |
d8491ba5 | 177 | (else |
4a2b74bf LC |
178 | (list library-path |
179 | library-files | |
180 | (cons argument previous-args))))))) | |
181 | (list '() '() '()) | |
d8491ba5 LC |
182 | args)) |
183 | ||
4a2b74bf LC |
184 | (match path+files+args |
185 | ((path files arguments) | |
d8491ba5 LC |
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. | |
82dc2b9a | 191 | (fold-right (lambda (file args) |
51d0cd9b LC |
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. | |
71b67168 LC |
196 | (cond ((and (not %disable-rpath?) |
197 | (store-file-name? file)) | |
51d0cd9b LC |
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))))) | |
82dc2b9a LC |
209 | '() |
210 | library-files)) | |
211 | ||
212 | (define (ld-wrapper . args) | |
213 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. | |
d8491ba5 LC |
214 | (let* ((libs (library-files-linked args)) |
215 | (args (append args (rpath-arguments libs)))) | |
216 | (when %debug? | |
4267c637 LC |
217 | (format (current-error-port) |
218 | "ld-wrapper: libraries linked: ~s~%" libs) | |
d8491ba5 LC |
219 | (format (current-error-port) |
220 | "ld-wrapper: invoking `~a' with ~s~%" | |
221 | %real-ld args)) | |
82dc2b9a LC |
222 | (apply execl %real-ld (basename %real-ld) args))) |
223 | ||
224 | ;;; ld-wrapper.scm ends here |