01/04: gremlin: Add support for the expansion of $ORIGIN in RUNPATH.

[Ludovic Courtès]

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

commit cd91504df27aa0f311735c61f3b7b7ee3fee861a
Author: Ludovic Courtès <address@hidden>
Date:   Thu Apr 23 11:23:14 2015 +0200

    gremlin: Add support for the expansion of $ORIGIN in RUNPATH.
    
    * guix/build/gremlin.scm (expand-variable, expand-origin): New
      procedures.
      (validate-needed-in-runpath): Map 'expand-origin' to the RUNPATH field
      of DYNINFO.
    * tests/gremlin.scm ("expand-origin"): New test.
---
 guix/build/gremlin.scm |   36 +++++++++++++++++++++++++++++++-----
 tests/gremlin.scm      |   12 ++++++++++++
 2 files changed, 43 insertions(+), 5 deletions(-)

diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index 30b0603..fed529b 100644
--- a/guix/build/gremlin.scm
+++ b/guix/build/gremlin.scm
@@ -39,6 +39,7 @@
             elf-dynamic-info-needed
             elf-dynamic-info-rpath
             elf-dynamic-info-runpath
+            expand-origin
 
             validate-needed-in-runpath))
 
@@ -236,6 +237,30 @@ value of DT_NEEDED entries is a string.)"
           (string-prefix? libc-lib lib))
         %libc-libraries))
 
+(define (expand-variable str variable value)
+  "Replace occurrences of '$VARIABLE' or '${VARIABLE}' in STR with VALUE."
+  (define variables
+    (list (string-append "$" variable)
+          (string-append "${" variable "}")))
+
+  (let loop ((thing variables)
+             (str   str))
+    (match thing
+      (()
+       str)
+      ((head tail ...)
+       (let ((index (string-contains str head))
+             (len   (string-length head)))
+         (loop (if index variables tail)
+               (if index
+                   (string-replace str value
+                                   index (+ index len))
+                   str)))))))
+
+(define (expand-origin str directory)
+  "Replace occurrences of '$ORIGIN' in STR with DIRECTORY."
+  (expand-variable str "ORIGIN" directory))
+
 (define* (validate-needed-in-runpath file
                                      #:key (always-found? libc-library?))
   "Return #t if all the libraries listed as FILE's 'DT_NEEDED' entries are
@@ -254,17 +279,18 @@ exceeds total size~%"
 
     (let* ((elf     (call-with-input-file file
                       (compose parse-elf get-bytevector-all)))
+           (expand  (cute expand-origin <> (dirname file)))
            (dyninfo (elf-dynamic-info elf)))
       (when dyninfo
-        (let* ((runpath   (filter store-file-name?
-                                  (elf-dynamic-info-runpath dyninfo)))
-               (bogus     (remove store-file-name?
-                                  (elf-dynamic-info-runpath dyninfo)))
+        ;; XXX: In theory we should also expand $PLATFORM and $LIB, but these
+        ;; appear to be really unused.
+        (let* ((expanded  (map expand (elf-dynamic-info-runpath dyninfo)))
+               (runpath   (filter store-file-name? expanded))
+               (bogus     (remove store-file-name? expanded))
                (needed    (remove always-found?
                                   (elf-dynamic-info-needed dyninfo)))
                (not-found (remove (cut search-path runpath <>)
                                   needed)))
-          ;; XXX: $ORIGIN is not supported.
           (unless (null? bogus)
             (format (current-error-port)
                     "~a: warning: RUNPATH contains bogus entries: ~s~%"
diff --git a/tests/gremlin.scm b/tests/gremlin.scm
index 225a72f..dc9f78c 100644
--- a/tests/gremlin.scm
+++ b/tests/gremlin.scm
@@ -21,6 +21,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build gremlin)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match))
@@ -51,6 +52,17 @@
                        (string-take lib (string-contains lib ".so")))
                      (elf-dynamic-info-needed dyninfo))))))
 
+(test-equal "expand-origin"
+  '("OOO/../lib"
+    "OOO"
+    "../OOO/bar/OOO/baz"
+    "ORIGIN/foo")
+  (map (cut expand-origin <> "OOO")
+       '("$ORIGIN/../lib"
+         "${ORIGIN}"
+         "../${ORIGIN}/bar/$ORIGIN/baz"
+         "ORIGIN/foo")))
+
 (test-end "gremlin")