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)" |
82dc2b9a LC |
11 | exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@" |
12 | !# | |
4155e2a9 | 13 | ;;; GNU Guix --- Functional package management for GNU |
8be3b8a3 | 14 | ;;; Copyright © 2012, 2013, 2014 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 LC |
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. | |
8be3b8a3 | 66 | (or (getenv "NIX_STORE") "/gnu/store")) |
82dc2b9a LC |
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) | |
cfbf7877 LC |
85 | ;; Return #t when FILE is the name of a file either within the store |
86 | ;; (possibly via a symlink) or within the build directory. | |
87 | (define %max-symlink-depth 50) | |
88 | ||
89 | (let loop ((file file) | |
90 | (depth 0)) | |
91 | (or (not (string-prefix? "/" file)) | |
92 | (string-prefix? %store-directory file) | |
93 | (string-prefix? %temporary-directory file) | |
94 | (if %build-directory | |
95 | (string-prefix? %build-directory file) | |
96 | ||
97 | ;; When used from a user environment, FILE may refer to | |
98 | ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the | |
99 | ;; store. Check whether this is the case. | |
100 | (let ((s (false-if-exception (lstat file)))) | |
101 | (and s | |
102 | (eq? 'symlink (stat:type s)) | |
103 | (< depth %max-symlink-depth) | |
104 | (loop (readlink file) (+ 1 depth)))))))) | |
82dc2b9a LC |
105 | |
106 | (define (switch-arguments switch args) | |
107 | ;; Return the arguments passed for the occurrences of SWITCH--e.g., | |
108 | ;; "-L"--in ARGS. | |
109 | (let ((prefix-len (string-length switch))) | |
110 | (fold-right (lambda (arg path) | |
111 | (if (string-prefix? switch arg) | |
112 | (cons (substring arg prefix-len) path) | |
113 | path)) | |
114 | '() | |
115 | args))) | |
116 | ||
117 | (define (library-path args) | |
118 | ;; Return the library search path extracted from `-L' switches in ARGS. | |
119 | ;; Note: allow references to out-of-store directories. When this leads to | |
120 | ;; actual impurities, this is caught later. | |
121 | (switch-arguments "-L" args)) | |
122 | ||
123 | (define (library-files-linked args) | |
124 | ;; Return the file names of shared libraries explicitly linked against via | |
125 | ;; `-l' in ARGS. | |
126 | (map (lambda (lib) | |
127 | (string-append "lib" lib ".so")) | |
128 | (switch-arguments "-l" args))) | |
129 | ||
130 | (define (rpath-arguments lib-path library-files) | |
131 | ;; Return the `-rpath' argument list for each of LIBRARY-FILES found in | |
132 | ;; LIB-PATH. | |
133 | (fold-right (lambda (file args) | |
134 | (let ((absolute (search-path lib-path file))) | |
135 | (if absolute | |
136 | (if (or %allow-impurities? | |
137 | (pure-file-name? absolute)) | |
138 | (cons* "-rpath" (dirname absolute) | |
139 | args) | |
140 | (begin | |
141 | (format (current-error-port) | |
142 | "ld-wrapper: error: attempt to use impure library ~s~%" | |
143 | absolute) | |
144 | (exit 1))) | |
145 | args))) | |
146 | '() | |
147 | library-files)) | |
148 | ||
149 | (define (ld-wrapper . args) | |
150 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. | |
151 | (let* ((lib-path (library-path args)) | |
152 | (libs (library-files-linked args)) | |
153 | (args (append args (rpath-arguments lib-path libs)))) | |
154 | (if %debug? | |
155 | (format (current-error-port) | |
156 | "ld-wrapper: invoking `~a' with ~s~%" | |
157 | %real-ld args)) | |
158 | (apply execl %real-ld (basename %real-ld) args))) | |
159 | ||
160 | ;;; ld-wrapper.scm ends here |