1 files changed, 80 insertions, 3 deletions

diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 5ae537150f..5062479360 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -18,12 +18,15 @@
 
 (define-module (guix build gnu-build-system)
   #:use-module (guix build utils)
+  #:use-module (guix build gremlin)
+  #:use-module (guix elf)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (rnrs io ports)
   #:export (%standard-phases
             gnu-build))
 
@@ -161,7 +164,10 @@ files such as `.in' templates.  Most scripts honor $SHELL and
 $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
 `missing' script."
   (for-each patch-shebang
-            (remove file-is-directory? (find-files "." ".*"))))
+            (remove (lambda (file)
+                      (or (not (file-exists? file)) ;dangling symlink
+                          (file-is-directory? file)))
+                    (find-files "."))))
 
 (define (patch-generated-file-shebangs . rest)
   "Patch shebangs in generated files, including `SHELL' variables in
@@ -170,9 +176,10 @@ makefiles."
   ;; `configure'.
   (for-each patch-shebang
             (filter (lambda (file)
-                      (and (executable-file? file)
+                      (and (file-exists? file)
+                           (executable-file? file)
                            (not (file-is-directory? file))))
-                    (find-files "." ".*")))
+                    (find-files ".")))
 
   ;; Patch `SHELL' in generated makefiles.
   (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
@@ -398,6 +405,64 @@ makefiles."
                                        strip-directories)))
                          outputs))))
 
+(define (every* pred lst)
+  "This is like 'every', but process all the elements of LST instead of
+stopping as soon as PRED returns false.  This is useful when PRED has side
+effects, such as displaying warnings or error messages."
+  (let loop ((lst    lst)
+             (result #t))
+    (match lst
+      (()
+       result)
+      ((head . tail)
+       (loop tail (and (pred head) result))))))
+
+(define* (validate-runpath #:key
+                           (validate-runpath? #t)
+                           (elf-directories '("lib" "lib64" "libexec"
+                                              "bin" "sbin"))
+                           outputs #:allow-other-keys)
+  "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
+ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
+
+Since the ELF parser needs to have a copy of files in memory, better run this
+phase after stripping."
+  (define (sub-directory parent)
+    (lambda (directory)
+      (let ((directory (string-append parent "/" directory)))
+        (and (directory-exists? directory) directory))))
+
+  (define (validate directory)
+    (define (file=? file1 file2)
+      (let ((st1 (stat file1))
+            (st2 (stat file2)))
+        (= (stat:ino st1) (stat:ino st2))))
+
+    ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
+    ;; duplicates.
+    (let ((files (delete-duplicates (find-files directory (lambda (file stat)
+                                                            (elf-file? file)))
+                                    file=?)))
+      (format (current-error-port)
+              "validating RUNPATH of ~a binaries in ~s...~%"
+              (length files) directory)
+      (every* validate-needed-in-runpath files)))
+
+  (if validate-runpath?
+      (let ((dirs (append-map (match-lambda
+                                (("debug" . _)
+                                 ;; The "debug" output is full of ELF files
+                                 ;; that are not worth checking.
+                                 '())
+                                ((name . output)
+                                 (filter-map (sub-directory output)
+                                             elf-directories)))
+                              outputs)))
+        (every* validate dirs))
+      (begin
+        (format (current-error-port) "skipping RUNPATH validation~%")
+        #t)))
+
 (define* (validate-documentation-location #:key outputs
                                           #:allow-other-keys)
   "Documentation should go to 'share/info' and 'share/man', not just 'info/'
@@ -477,6 +542,16 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
         (format #t "not compressing documentation~%")
         #t)))
 
+(define* (delete-info-dir-file #:key outputs #:allow-other-keys)
+  "Delete any 'share/info/dir' file from OUTPUTS."
+  (for-each (match-lambda
+          ((output . directory)
+           (let ((info-dir-file (string-append directory "/share/info/dir")))
+             (when (file-exists? info-dir-file)
+               (delete-file info-dir-file)))))
+            outputs)
+  #t)
+
 (define %standard-phases
   ;; Standard build phases, as a list of symbol/procedure pairs.
   (let-syntax ((phases (syntax-rules ()
@@ -486,7 +561,9 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
             patch-source-shebangs configure patch-generated-file-shebangs
             build check install
             patch-shebangs strip
+            validate-runpath
             validate-documentation-location
+            delete-info-dir-file
             compress-documentation)))