02/03: ld-wrapper: Add '-rpath' flag for libraries passed by file name.

[Ludovic Courtès]

civodul pushed a commit to branch core-updates
in repository guix.

commit d8491ba5630d31a58b89dfe5d423988ce736266b
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 4 22:21:11 2015 +0100

    ld-wrapper: Add '-rpath' flag for libraries passed by file name.
    
    Discussed at
    <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00028.html>.
    
    * gnu/packages/ld-wrapper.scm (switch-arguments, library-path): Remove.
      (library-files-linked): Rewrite to include the name of libraries
      passed by file names, and to honor the current -L search path instead
      of the final one.
      (rpath-arguments): Remove 'lib-path' parameter.  Expect LIBRARY-FILES
      to be a list of absolute file names.
      (ld-wrapper): Adjust accordingly.
---
 gnu/packages/ld-wrapper.scm |   95 ++++++++++++++++++++++--------------------
 1 files changed, 50 insertions(+), 45 deletions(-)

diff --git a/gnu/packages/ld-wrapper.scm b/gnu/packages/ld-wrapper.scm
index d3eb083..1985617 100644
--- a/gnu/packages/ld-wrapper.scm
+++ b/gnu/packages/ld-wrapper.scm
@@ -11,7 +11,7 @@ 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, 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,6 +30,7 @@ exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr 
(command-line)))" "
 
 (define-module (gnu build-support ld-wrapper)
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
   #:export (ld-wrapper))
 
 ;;; Commentary:
@@ -103,58 +104,62 @@ exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main 
(cdr (command-line)))" "
                    (< depth %max-symlink-depth)
                    (loop (readlink file) (+ 1 depth))))))))
 
-(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.
+  ;; `-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)
+                           (string-suffix? ".so" 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)
-                (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)))
+                (if (or %allow-impurities?
+                        (pure-file-name? file))
+                    (cons* "-rpath" (dirname file) args)
+                    (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* ((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))
+  (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