# 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>).
+# Unset 'GUILE_LOAD_COMPILED_PATH' to make sure we do not stumble upon
+# incompatible .go files. See
+# <https://lists.gnu.org/archive/html/guile-devel/2016-03/msg00000.html>.
+unset GUILE_LOAD_COMPILED_PATH
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>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu build-support ld-wrapper)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
+ #:autoload (ice-9 rdelim) (read-delimited)
#:export (ld-wrapper))
;;; Commentary:
(define %allow-impurities?
;; Whether to allow references to libraries outside the store.
- (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
+ ;; Allow them by default for convenience.
+ (let ((value (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")))
+ (or (not value)
+ (let ((value (string-downcase value)))
+ (cond ((member value '("yes" "y" "t" "true" "1"))
+ #t)
+ ((member value '("no" "n" "f" "false" "0"))
+ #f)
+ (else
+ (format (current-error-port)
+ "ld-wrapper: ~s: invalid value for \
+'GUIX_LD_WRAPPER_ALLOW_IMPURITIES'~%"
+ value)))))))
(define %debug?
;; Whether to emit debugging output.
(begin
(format (current-error-port)
"ld-wrapper: error: attempt to use \
-impure library ~s~%"
- file)
+library outside of ~a: ~s~%"
+ %store-directory file)
(exit 1)))))
'()
library-files))
+(define (expand-arguments args)
+ ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are
+ ;; expanded (info "(gcc) Overall Options").
+ (define (response-file-arguments file)
+ (define (tokenize port)
+ ;; Return a list of all strings found in PORT. Quote characters are
+ ;; removed, but whitespaces within quoted strings are preserved.
+ (let loop ((tokens '()))
+ (let* ((token+delimiter (read-delimited " '\"\n" port 'split))
+ (token (car token+delimiter))
+ (delim (cdr token+delimiter)))
+ (if (eof-object? token)
+ (reverse tokens)
+ (case delim
+ ((#\") (loop (cons (read-delimited "\"" port) tokens)))
+ ((#\') (loop (cons (read-delimited "'" port) tokens)))
+ (else (if (> (string-length token) 0)
+ (loop (cons token tokens))
+ (loop tokens))))))))
+
+ (when %debug?
+ (format (current-error-port)
+ "ld-wrapper: attempting to read arguments from '~a'~%" file))
+
+ (call-with-input-file file tokenize))
+
+ (define result
+ (fold-right (lambda (arg result)
+ (if (string-prefix? "@" arg)
+ (let ((file (string-drop arg 1)))
+ (append (catch 'system-error
+ (lambda ()
+ (response-file-arguments file))
+ (lambda args
+ ;; FILE doesn't exist or cannot be read so
+ ;; leave ARG as is.
+ (list arg)))
+ result))
+ (cons arg result)))
+ '()
+ args))
+
+ ;; If there are "@" arguments in RESULT *and* we can expand them (they don't
+ ;; refer to nonexistent files), then recurse.
+ (if (equal? result args)
+ result
+ (expand-arguments result)))
+
(define (ld-wrapper . args)
;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
- (let* ((path (library-search-path args))
+ (let* ((args (expand-arguments args))
+ (path (library-search-path args))
(libs (library-files-linked args path))
(args (append args (rpath-arguments libs))))
(when %debug?
"ld-wrapper: libraries linked: ~s~%" libs)
(format (current-error-port)
"ld-wrapper: invoking `~a' with ~s~%"
- %real-ld args))
+ %real-ld args)
+ (force-output (current-error-port)))
(apply execl %real-ld (basename %real-ld) args)))
;;; ld-wrapper.scm ends here