diff options
| -rw-r--r-- | guix/build/gremlin.scm | 46 | ||||
| -rw-r--r-- | tests/gremlin.scm | 35 |
2 files changed, 79 insertions, 2 deletions
diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm index 78d1333117..e8ea66dfb3 100644 --- a/guix/build/gremlin.scm +++ b/guix/build/gremlin.scm @@ -41,7 +41,8 @@ elf-dynamic-info-runpath expand-origin - validate-needed-in-runpath)) + validate-needed-in-runpath + strip-runpath)) ;;; Commentary: ;;; @@ -320,4 +321,47 @@ be found in RUNPATH ~s~%" ;; (format (current-error-port) "~a is OK~%" file)) (null? not-found)))))) +(define (strip-runpath file) + "Remove from the DT_RUNPATH of FILE any entries that are not necessary +according to DT_NEEDED." + (define (minimal-runpath needed runpath) + (filter (lambda (directory) + (and (string-prefix? "/" directory) + (any (lambda (lib) + (file-exists? (string-append directory "/" lib))) + needed))) + runpath)) + + (define port + (open-file file "r+b")) + + (catch #t + (lambda () + (let* ((elf (parse-elf (get-bytevector-all port))) + (entries (dynamic-entries elf (dynamic-link-segment elf))) + (needed (filter-map (lambda (entry) + (and (= (dynamic-entry-type entry) + DT_NEEDED) + (dynamic-entry-value entry))) + entries)) + (runpath (find (lambda (entry) + (= DT_RUNPATH (dynamic-entry-type entry))) + entries)) + (old (search-path->list + (dynamic-entry-value runpath))) + (new (minimal-runpath needed old))) + (unless (equal? old new) + (format (current-error-port) + "~a: stripping RUNPATH to ~s (removed ~s)~%" + file new + (lset-difference string=? old new)) + (seek port (dynamic-entry-offset runpath) SEEK_SET) + (put-bytevector port (string->utf8 (string-join new ":"))) + (put-u8 port 0)) + (close-port port) + new)) + (lambda (key . args) + (false-if-exception (close-port port)) + (apply throw key args)))) + ;;; gremlin.scm ends here diff --git a/tests/gremlin.scm b/tests/gremlin.scm index 2885554967..1b47d5c384 100644 --- a/tests/gremlin.scm +++ b/tests/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,12 +18,14 @@ (define-module (test-gremlin) #:use-module (guix elf) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) #: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 popen) #:use-module (ice-9 match)) (define %guile-executable @@ -37,6 +39,9 @@ (define read-elf (compose parse-elf get-bytevector-all)) +(define c-compiler + (or (which "gcc") (which "cc") (which "g++"))) + (test-begin "gremlin") @@ -63,4 +68,32 @@ "../${ORIGIN}/bar/$ORIGIN/baz" "ORIGIN/foo"))) +(unless c-compiler + (test-skip 1)) +(test-equal "strip-runpath" + "hello\n" + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (call-with-output-file "t.c" + (lambda (port) + (display "int main () { puts(\"hello\"); }" port))) + (invoke c-compiler "t.c" + "-Wl,-rpath=/foo" "-Wl,-rpath=/bar") + (let* ((dyninfo (elf-dynamic-info + (parse-elf (call-with-input-file "a.out" + get-bytevector-all)))) + (old (elf-dynamic-info-runpath dyninfo)) + (new (strip-runpath "a.out")) + (new* (strip-runpath "a.out"))) + (validate-needed-in-runpath "a.out") + (and (member "/foo" old) (member "/bar" old) + (not (member "/foo" new)) + (not (member "/bar" new)) + (equal? new* new) + (let* ((pipe (open-input-pipe "./a.out")) + (str (get-string-all pipe))) + (close-pipe pipe) + str))))))) + (test-end "gremlin") |