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)) | |
41fc0eb9 LC |
95 | (catch 'system-error |
96 | (lambda () | |
97 | (if (>= depth %max-symlink-depth) | |
98 | file | |
99 | (loop (readlink file) (+ depth 1)))) | |
100 | (lambda args | |
101 | (if (= EINVAL (system-error-errno args)) | |
102 | file | |
103 | (apply throw args)))))) | |
104 | ||
105 | (define (dereference-symlinks file) | |
106 | ;; Same as 'readlink*' but return FILE if the symlink target is invalid or | |
107 | ;; FILE does not exist. | |
108 | (catch 'system-error | |
109 | (lambda () | |
110 | ;; When used from a user environment, FILE may refer to | |
111 | ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the | |
112 | ;; store. Check whether this is the case. | |
113 | (readlink* file)) | |
114 | (lambda args | |
115 | (if (= ENOENT (system-error-errno args)) | |
116 | file | |
117 | (apply throw args))))) | |
118 | ||
119 | (define (pure-file-name? file) | |
120 | ;; Return #t when FILE is the name of a file either within the store | |
121 | ;; (possibly via a symlink) or within the build directory. | |
122 | (let ((file (dereference-symlinks file))) | |
cfbf7877 LC |
123 | (or (not (string-prefix? "/" file)) |
124 | (string-prefix? %store-directory file) | |
125 | (string-prefix? %temporary-directory file) | |
41fc0eb9 LC |
126 | (and %build-directory |
127 | (string-prefix? %build-directory file))))) | |
82dc2b9a | 128 | |
51d0cd9b LC |
129 | (define (store-file-name? file) |
130 | ;; Return #t when FILE is a store file, possibly indirectly. | |
131 | (string-prefix? %store-directory (dereference-symlinks file))) | |
132 | ||
f307947e LC |
133 | (define (shared-library? file) |
134 | ;; Return #t when FILE denotes a shared library. | |
135 | (or (string-suffix? ".so" file) | |
136 | (let ((index (string-contains file ".so."))) | |
137 | ;; Since we cannot use regexps during bootstrap, roll our own. | |
138 | (and index | |
139 | (string-every (char-set-union (char-set #\.) char-set:digit) | |
140 | (string-drop file (+ index 3))))))) | |
141 | ||
82dc2b9a LC |
142 | (define (library-files-linked args) |
143 | ;; Return the file names of shared libraries explicitly linked against via | |
d8491ba5 LC |
144 | ;; `-l' or with an absolute file name in ARGS. |
145 | (define path+files | |
146 | (fold (lambda (argument result) | |
147 | (match result | |
148 | ((library-path . library-files) | |
149 | (cond ((string-prefix? "-L" argument) ;augment the search path | |
150 | (cons (append library-path | |
151 | (list (string-drop argument 2))) | |
152 | library-files)) | |
153 | ((string-prefix? "-l" argument) ;add library | |
154 | (let* ((lib (string-append "lib" | |
155 | (string-drop argument 2) | |
156 | ".so")) | |
157 | (full (search-path library-path lib))) | |
158 | (if full | |
159 | (cons library-path | |
160 | (cons full library-files)) | |
161 | result))) | |
162 | ((and (string-prefix? %store-directory argument) | |
f307947e | 163 | (shared-library? argument)) ;add library |
d8491ba5 LC |
164 | (cons library-path |
165 | (cons argument library-files))) | |
166 | (else | |
167 | result))))) | |
168 | (cons '() '()) | |
169 | args)) | |
170 | ||
171 | (match path+files | |
172 | ((path . files) | |
173 | (reverse files)))) | |
174 | ||
175 | (define (rpath-arguments library-files) | |
176 | ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of | |
177 | ;; absolute file names. | |
82dc2b9a | 178 | (fold-right (lambda (file args) |
51d0cd9b LC |
179 | ;; Add '-rpath' if and only if FILE is in the store; we don't |
180 | ;; want to add '-rpath' for files under %BUILD-DIRECTORY or | |
181 | ;; %TEMPORARY-DIRECTORY because that could leak to installed | |
182 | ;; files. | |
71b67168 LC |
183 | (cond ((and (not %disable-rpath?) |
184 | (store-file-name? file)) | |
51d0cd9b LC |
185 | (cons* "-rpath" (dirname file) args)) |
186 | ((or %allow-impurities? | |
187 | (pure-file-name? file)) | |
188 | args) | |
189 | (else | |
190 | (begin | |
191 | (format (current-error-port) | |
192 | "ld-wrapper: error: attempt to use \ | |
193 | impure library ~s~%" | |
194 | file) | |
195 | (exit 1))))) | |
82dc2b9a LC |
196 | '() |
197 | library-files)) | |
198 | ||
199 | (define (ld-wrapper . args) | |
200 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. | |
d8491ba5 LC |
201 | (let* ((libs (library-files-linked args)) |
202 | (args (append args (rpath-arguments libs)))) | |
203 | (when %debug? | |
204 | (format (current-error-port) | |
205 | "ld-wrapper: invoking `~a' with ~s~%" | |
206 | %real-ld args)) | |
82dc2b9a LC |
207 | (apply execl %real-ld (basename %real-ld) args))) |
208 | ||
209 | ;;; ld-wrapper.scm ends here |