gremlin: Add 'strip-runpath'.

* guix/build/gremlin.scm (strip-runpath): New procedure.
* tests/gremlin.scm (c-compiler): New variable.
("strip-runpath"): New test.
This commit is contained in:
Ludovic Courtès 2018-04-17 13:38:12 +02:00
parent ad4835fe01
commit b178fc2369
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 79 additions and 2 deletions

View File

@ -41,7 +41,8 @@
elf-dynamic-info-runpath elf-dynamic-info-runpath
expand-origin expand-origin
validate-needed-in-runpath)) validate-needed-in-runpath
strip-runpath))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -320,4 +321,47 @@ be found in RUNPATH ~s~%"
;; (format (current-error-port) "~a is OK~%" file)) ;; (format (current-error-port) "~a is OK~%" file))
(null? not-found)))))) (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 ;;; gremlin.scm ends here

View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,12 +18,14 @@
(define-module (test-gremlin) (define-module (test-gremlin)
#:use-module (guix elf) #:use-module (guix elf)
#:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build gremlin) #:use-module (guix build gremlin)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (ice-9 popen)
#:use-module (ice-9 match)) #:use-module (ice-9 match))
(define %guile-executable (define %guile-executable
@ -37,6 +39,9 @@
(define read-elf (define read-elf
(compose parse-elf get-bytevector-all)) (compose parse-elf get-bytevector-all))
(define c-compiler
(or (which "gcc") (which "cc") (which "g++")))
(test-begin "gremlin") (test-begin "gremlin")
@ -63,4 +68,32 @@
"../${ORIGIN}/bar/$ORIGIN/baz" "../${ORIGIN}/bar/$ORIGIN/baz"
"ORIGIN/foo"))) "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") (test-end "gremlin")