1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
#!@BASH@
# -*- mode: scheme; coding: utf-8; -*-
# XXX: We have to go through Bash because there's no command-line switch to
# augment %load-compiled-path, and because of the silly 127-byte limit for
# the shebang line in Linux.
# Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
# .go file (see <http://bugs.gnu.org/12519>).
main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build-support ld-wrapper)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (ld-wrapper))
;;; Commentary:
;;;
;;; This is a wrapper for the linker. Its purpose is to inspect the -L and
;;; -l switches passed to the linker, add corresponding -rpath arguments, and
;;; invoke the actual linker with this new set of arguments.
;;;
;;; The alternatives to this hack would be:
;;;
;;; 1. Using $LD_RUN_PATH. However, that would tend to include more than
;;; needed in the RPATH; for instance, given a package with `libfoo' as
;;; an input, all its binaries would have libfoo in their RPATH,
;;; regardless of whether they actually NEED it.
;;;
;;; 2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
;;; `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
;;; However, this doesn't work when $LIBRARY_PATH is used, because the
;;; additional `-L' switches are not matched by the above rule, because
;;; the rule only matches explicit user-provided switches. See
;;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
;;;
;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
;;; libraries outside the store.
;;;
;;; Code:
(define %real-ld
;; Name of the linker that we wrap.
"@LD@")
(define %store-directory
;; File name of the store.
(or (getenv "NIX_STORE") "/gnu/store"))
(define %temporary-directory
;; Temporary directory.
(or (getenv "TMPDIR") "/tmp"))
(define %build-directory
;; Top build directory when run from a builder.
(getenv "NIX_BUILD_TOP"))
(define %allow-impurities?
;; Whether to allow references to libraries outside the store.
(getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
(define %debug?
;; Whether to emit debugging output.
(getenv "GUIX_LD_WRAPPER_DEBUG"))
(define (readlink* file)
;; Call 'readlink' until the result is not a symlink.
(define %max-symlink-depth 50)
(let loop ((file file)
(depth 0))
(catch 'system-error
(lambda ()
(if (>= depth %max-symlink-depth)
file
(loop (readlink file) (+ depth 1))))
(lambda args
(if (= EINVAL (system-error-errno args))
file
(apply throw args))))))
(define (dereference-symlinks file)
;; Same as 'readlink*' but return FILE if the symlink target is invalid or
;; FILE does not exist.
(catch 'system-error
(lambda ()
;; When used from a user environment, FILE may refer to
;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
;; store. Check whether this is the case.
(readlink* file))
(lambda args
(if (= ENOENT (system-error-errno args))
file
(apply throw args)))))
(define (pure-file-name? file)
;; Return #t when FILE is the name of a file either within the store
;; (possibly via a symlink) or within the build directory.
(let ((file (dereference-symlinks file)))
(or (not (string-prefix? "/" file))
(string-prefix? %store-directory file)
(string-prefix? %temporary-directory file)
(and %build-directory
(string-prefix? %build-directory file)))))
(define (store-file-name? file)
;; Return #t when FILE is a store file, possibly indirectly.
(string-prefix? %store-directory (dereference-symlinks file)))
(define (shared-library? file)
;; Return #t when FILE denotes a shared library.
(or (string-suffix? ".so" file)
(let ((index (string-contains file ".so.")))
;; Since we cannot use regexps during bootstrap, roll our own.
(and index
(string-every (char-set-union (char-set #\.) char-set:digit)
(string-drop file (+ index 3)))))))
(define (library-files-linked args)
;; Return the file names of shared libraries explicitly linked against via
;; `-l' or with an absolute file name in ARGS.
(define path+files
(fold (lambda (argument result)
(match result
((library-path . library-files)
(cond ((string-prefix? "-L" argument) ;augment the search path
(cons (append library-path
(list (string-drop argument 2)))
library-files))
((string-prefix? "-l" argument) ;add library
(let* ((lib (string-append "lib"
(string-drop argument 2)
".so"))
(full (search-path library-path lib)))
(if full
(cons library-path
(cons full library-files))
result)))
((and (string-prefix? %store-directory argument)
(shared-library? argument)) ;add library
(cons library-path
(cons argument library-files)))
(else
result)))))
(cons '() '())
args))
(match path+files
((path . files)
(reverse files))))
(define (rpath-arguments library-files)
;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
;; absolute file names.
(fold-right (lambda (file args)
;; Add '-rpath' if and only if FILE is in the store; we don't
;; want to add '-rpath' for files under %BUILD-DIRECTORY or
;; %TEMPORARY-DIRECTORY because that could leak to installed
;; files.
(cond ((store-file-name? file)
(cons* "-rpath" (dirname file) args))
((or %allow-impurities?
(pure-file-name? file))
args)
(else
(begin
(format (current-error-port)
"ld-wrapper: error: attempt to use \
impure library ~s~%"
file)
(exit 1)))))
'()
library-files))
(define (ld-wrapper . args)
;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
(let* ((libs (library-files-linked args))
(args (append args (rpath-arguments libs))))
(when %debug?
(format (current-error-port)
"ld-wrapper: invoking `~a' with ~s~%"
%real-ld args))
(apply execl %real-ld (basename %real-ld) args)))
;;; ld-wrapper.scm ends here
|
