02/04: gremlin: Add 'file-needed/recursive'.

[guix-commits]

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

commit 53fd256e5ba43e516fb9d6eaf085b88fe8bd12b6
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Nov 27 16:35:45 2020 +0100

    gremlin: Add 'file-needed/recursive'.
    
    * guix/build/gremlin.scm (file-needed/recursive): New procedure.
    * tests/gremlin.scm ("file-needed/recursive"): New test.
---
 guix/build/gremlin.scm | 41 +++++++++++++++++++++++++++++++++++++++++
 tests/gremlin.scm      | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 77 insertions(+)

diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index 4460482..a2d2169 100644
--- a/guix/build/gremlin.scm
+++ b/guix/build/gremlin.scm
@@ -44,6 +44,7 @@
             file-dynamic-info
             file-runpath
             file-needed
+            file-needed/recursive
 
             missing-runpath-error?
             missing-runpath-error-file
@@ -259,6 +260,46 @@ FILE lacks dynamic info."
 dynamic info."
   (and=> (file-dynamic-info file) elf-dynamic-info-needed))
 
+(define (file-needed/recursive file)
+  "Return two values: the list of absolute .so file names FILE depends on,
+recursively, and the list of .so file names that could not be found.  File
+names are resolved by searching the RUNPATH of the file that NEEDs them.
+
+This is similar to the info returned by the 'ldd' command."
+  (let loop ((files  (list file))
+             (result '())
+             (not-found '()))
+    (match files
+      (()
+       (values (reverse result)
+               (reverse (delete-duplicates not-found))))
+      ((file . rest)
+       (match (file-dynamic-info file)
+         (#f
+          (loop rest result not-found))
+         (info
+          (let ((runpath (elf-dynamic-info-runpath info))
+                (needed  (elf-dynamic-info-needed info)))
+            (if (and runpath needed)
+                (let* ((runpath  (map (cute expand-origin <> (dirname file))
+                                      runpath))
+                       (resolved (map (cut search-path runpath <>)
+                                      needed))
+                       (failed   (filter-map (lambda (needed resolved)
+                                               (and (not resolved)
+                                                    (not (libc-library? 
needed))
+                                                    needed))
+                                             needed resolved))
+                       (needed   (remove (lambda (value)
+                                           (or (not value)
+                                               ;; XXX: quadratic
+                                               (member value result)))
+                                         resolved)))
+                  (loop (append rest needed)
+                        (append needed result)
+                        (append failed not-found)))
+                (loop rest result not-found)))))))))
+
 (define %libc-libraries
   ;; List of libraries as of glibc 2.21 (there are more but those are
   ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.)
diff --git a/tests/gremlin.scm b/tests/gremlin.scm
index f191adb..9ddac14 100644
--- a/tests/gremlin.scm
+++ b/tests/gremlin.scm
@@ -27,6 +27,8 @@
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
   #:use-module (ice-9 match))
 
 (define %guile-executable
@@ -58,6 +60,40 @@
                        (string-take lib (string-contains lib ".so")))
                      (elf-dynamic-info-needed dyninfo))))))
 
+(unless (and %guile-executable (not (getenv "LD_LIBRARY_PATH"))
+             (file-needed %guile-executable))     ;statically linked?
+  (test-skip 1))
+(test-assert "file-needed/recursive"
+  (let* ((needed (file-needed/recursive %guile-executable))
+         (pipe   (dynamic-wind
+                   (lambda ()
+                     ;; Tell ld.so to list loaded objects, like 'ldd' does.
+                     (setenv "LD_TRACE_LOADED_OBJECTS" "yup"))
+                   (lambda ()
+                     (open-pipe* OPEN_READ %guile-executable))
+                   (lambda ()
+                     (unsetenv "LD_TRACE_LOADED_OBJECTS")))))
+    (define ldd-rx
+      (make-regexp "^[[:blank:]]+([[:graph:]]+ => )?([[:graph:]]+) .*$"))
+
+    (define (read-ldd-output port)
+      ;; Read from PORT output in GNU ldd format.
+      (let loop ((result '()))
+        (match (read-line port)
+          ((? eof-object?)
+           (reverse result))
+          ((= (cut regexp-exec ldd-rx <>) m)
+           (if m
+               (loop (cons (match:substring m 2) result))
+               (loop result))))))
+
+    (define ground-truth
+      (remove (cut string-prefix? "linux-vdso.so" <>)
+              (read-ldd-output pipe)))
+
+    (and (zero? (close-pipe pipe))
+         (lset= string=? (pk 'truth ground-truth) (pk 'needed needed)))))
+
 (test-equal "expand-origin"
   '("OOO/../lib"
     "OOO"