From 1ffa7090b99dfd2f54fa883929c5e78d7852657a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 Jan 2013 01:06:24 +0100 Subject: distro: Change the module name space to (gnu ...). * distro: Rename to... * gnu: ... this. Update module names accordingly. * Makefile.am: Adjust accordingly. * po/POTFILES.in: Likewise. * distro.scm: Search for files under /gnu/packages instead of /distro/packages. * gnu/packages/base.scm (ld-wrapper-boot3): Likewise. --- gnu/packages/ld-wrapper.scm | 147 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 147 insertions(+) create mode 100644 gnu/packages/ld-wrapper.scm (limited to 'gnu/packages/ld-wrapper.scm') diff --git a/gnu/packages/ld-wrapper.scm b/gnu/packages/ld-wrapper.scm new file mode 100644 index 0000000000..fd5a4cbd0c --- /dev/null +++ b/gnu/packages/ld-wrapper.scm @@ -0,0 +1,147 @@ +#!@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 ). + +main="(@ (gnu build-support ld-wrapper) ld-wrapper)" +exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@" +!# +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu build-support ld-wrapper) + #:use-module (srfi srfi-1) + #: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 +;;; 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") "/nix/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 (pure-file-name? file) + ;; Return #t when FILE is the name of a file either within the store or + ;; within the build directory. + (or (not (string-prefix? "/" file)) + (string-prefix? %store-directory file) + (string-prefix? %temporary-directory file) + (and %build-directory + (string-prefix? %build-directory file)))) + +(define (switch-arguments switch args) + ;; Return the arguments passed for the occurrences of SWITCH--e.g., + ;; "-L"--in ARGS. + (let ((prefix-len (string-length switch))) + (fold-right (lambda (arg path) + (if (string-prefix? switch arg) + (cons (substring arg prefix-len) path) + path)) + '() + args))) + +(define (library-path args) + ;; Return the library search path extracted from `-L' switches in ARGS. + ;; Note: allow references to out-of-store directories. When this leads to + ;; actual impurities, this is caught later. + (switch-arguments "-L" args)) + +(define (library-files-linked args) + ;; Return the file names of shared libraries explicitly linked against via + ;; `-l' in ARGS. + (map (lambda (lib) + (string-append "lib" lib ".so")) + (switch-arguments "-l" args))) + +(define (rpath-arguments lib-path library-files) + ;; Return the `-rpath' argument list for each of LIBRARY-FILES found in + ;; LIB-PATH. + (fold-right (lambda (file args) + (let ((absolute (search-path lib-path file))) + (if absolute + (if (or %allow-impurities? + (pure-file-name? absolute)) + (cons* "-rpath" (dirname absolute) + args) + (begin + (format (current-error-port) + "ld-wrapper: error: attempt to use impure library ~s~%" + absolute) + (exit 1))) + args))) + '() + library-files)) + +(define (ld-wrapper . args) + ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. + (let* ((lib-path (library-path args)) + (libs (library-files-linked args)) + (args (append args (rpath-arguments lib-path libs)))) + (if %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 -- cgit v1.2.3