Non puoi selezionare più di 25 argomenti Gli argomenti devono iniziare con una lettera o un numero, possono includere trattini ('-') e possono essere lunghi fino a 35 caratteri.
 
 
 
 
 
 

161 righe
6.1 KiB

  1. #!@BASH@
  2. # -*- mode: scheme; coding: utf-8; -*-
  3. # XXX: We have to go through Bash because there's no command-line switch to
  4. # augment %load-compiled-path, and because of the silly 127-byte limit for
  5. # the shebang line in Linux.
  6. # Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
  7. # .go file (see <http://bugs.gnu.org/12519>).
  8. main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
  9. exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@"
  10. !#
  11. ;;; GNU Guix --- Functional package management for GNU
  12. ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
  13. ;;;
  14. ;;; This file is part of GNU Guix.
  15. ;;;
  16. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  17. ;;; under the terms of the GNU General Public License as published by
  18. ;;; the Free Software Foundation; either version 3 of the License, or (at
  19. ;;; your option) any later version.
  20. ;;;
  21. ;;; GNU Guix is distributed in the hope that it will be useful, but
  22. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  24. ;;; GNU General Public License for more details.
  25. ;;;
  26. ;;; You should have received a copy of the GNU General Public License
  27. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  28. (define-module (gnu build-support ld-wrapper)
  29. #:use-module (srfi srfi-1)
  30. #:export (ld-wrapper))
  31. ;;; Commentary:
  32. ;;;
  33. ;;; This is a wrapper for the linker. Its purpose is to inspect the -L and
  34. ;;; -l switches passed to the linker, add corresponding -rpath arguments, and
  35. ;;; invoke the actual linker with this new set of arguments.
  36. ;;;
  37. ;;; The alternatives to this hack would be:
  38. ;;;
  39. ;;; 1. Using $LD_RUN_PATH. However, that would tend to include more than
  40. ;;; needed in the RPATH; for instance, given a package with `libfoo' as
  41. ;;; an input, all its binaries would have libfoo in their RPATH,
  42. ;;; regardless of whether they actually NEED it.
  43. ;;;
  44. ;;; 2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
  45. ;;; `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
  46. ;;; However, this doesn't work when $LIBRARY_PATH is used, because the
  47. ;;; additional `-L' switches are not matched by the above rule, because
  48. ;;; the rule only matches explicit user-provided switches. See
  49. ;;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
  50. ;;;
  51. ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
  52. ;;; libraries outside the store.
  53. ;;;
  54. ;;; Code:
  55. (define %real-ld
  56. ;; Name of the linker that we wrap.
  57. "@LD@")
  58. (define %store-directory
  59. ;; File name of the store.
  60. (or (getenv "NIX_STORE") "/nix/store"))
  61. (define %temporary-directory
  62. ;; Temporary directory.
  63. (or (getenv "TMPDIR") "/tmp"))
  64. (define %build-directory
  65. ;; Top build directory when run from a builder.
  66. (getenv "NIX_BUILD_TOP"))
  67. (define %allow-impurities?
  68. ;; Whether to allow references to libraries outside the store.
  69. (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
  70. (define %debug?
  71. ;; Whether to emit debugging output.
  72. (getenv "GUIX_LD_WRAPPER_DEBUG"))
  73. (define (pure-file-name? file)
  74. ;; Return #t when FILE is the name of a file either within the store
  75. ;; (possibly via a symlink) or within the build directory.
  76. (define %max-symlink-depth 50)
  77. (let loop ((file file)
  78. (depth 0))
  79. (or (not (string-prefix? "/" file))
  80. (string-prefix? %store-directory file)
  81. (string-prefix? %temporary-directory file)
  82. (if %build-directory
  83. (string-prefix? %build-directory file)
  84. ;; When used from a user environment, FILE may refer to
  85. ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
  86. ;; store. Check whether this is the case.
  87. (let ((s (false-if-exception (lstat file))))
  88. (and s
  89. (eq? 'symlink (stat:type s))
  90. (< depth %max-symlink-depth)
  91. (loop (readlink file) (+ 1 depth))))))))
  92. (define (switch-arguments switch args)
  93. ;; Return the arguments passed for the occurrences of SWITCH--e.g.,
  94. ;; "-L"--in ARGS.
  95. (let ((prefix-len (string-length switch)))
  96. (fold-right (lambda (arg path)
  97. (if (string-prefix? switch arg)
  98. (cons (substring arg prefix-len) path)
  99. path))
  100. '()
  101. args)))
  102. (define (library-path args)
  103. ;; Return the library search path extracted from `-L' switches in ARGS.
  104. ;; Note: allow references to out-of-store directories. When this leads to
  105. ;; actual impurities, this is caught later.
  106. (switch-arguments "-L" args))
  107. (define (library-files-linked args)
  108. ;; Return the file names of shared libraries explicitly linked against via
  109. ;; `-l' in ARGS.
  110. (map (lambda (lib)
  111. (string-append "lib" lib ".so"))
  112. (switch-arguments "-l" args)))
  113. (define (rpath-arguments lib-path library-files)
  114. ;; Return the `-rpath' argument list for each of LIBRARY-FILES found in
  115. ;; LIB-PATH.
  116. (fold-right (lambda (file args)
  117. (let ((absolute (search-path lib-path file)))
  118. (if absolute
  119. (if (or %allow-impurities?
  120. (pure-file-name? absolute))
  121. (cons* "-rpath" (dirname absolute)
  122. args)
  123. (begin
  124. (format (current-error-port)
  125. "ld-wrapper: error: attempt to use impure library ~s~%"
  126. absolute)
  127. (exit 1)))
  128. args)))
  129. '()
  130. library-files))
  131. (define (ld-wrapper . args)
  132. ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
  133. (let* ((lib-path (library-path args))
  134. (libs (library-files-linked args))
  135. (args (append args (rpath-arguments lib-path libs))))
  136. (if %debug?
  137. (format (current-error-port)
  138. "ld-wrapper: invoking `~a' with ~s~%"
  139. %real-ld args))
  140. (apply execl %real-ld (basename %real-ld) args)))
  141. ;;; ld-wrapper.scm ends here