From: "Ludovic Courtès" <ludo@gnu.org>
To: 31208@debbugs.gnu.org
Subject: [bug#31208] [PATCH 2/3] gremlin: Add 'strip-runpath'.
Date: Wed, 18 Apr 2018 18:40:53 +0200 [thread overview]
Message-ID: <20180418164054.29979-2-ludo@gnu.org> (raw)
In-Reply-To: <20180418164054.29979-1-ludo@gnu.org>
* guix/build/gremlin.scm (strip-runpath): New procedure.
* tests/gremlin.scm (c-compiler): New variable.
("strip-runpath"): New test.
---
guix/build/gremlin.scm | 46 +++++++++++++++++++++++++++++++++++++++++-
tests/gremlin.scm | 35 +++++++++++++++++++++++++++++++-
2 files changed, 79 insertions(+), 2 deletions(-)
diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index 78d133311..e8ea66dfb 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 288555496..1b47d5c38 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++")))
+
\f
(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")
--
2.17.0
next prev parent reply other threads:[~2018-04-18 16:42 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-04-18 16:38 [bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin) Ludovic Courtès
2018-04-18 16:40 ` [bug#31208] [PATCH 1/3] gremlin: Preserve offset info for dynamic entries Ludovic Courtès
2018-04-18 16:40 ` Ludovic Courtès [this message]
2018-04-18 16:40 ` [bug#31208] [PATCH 3/3] build-system/meson: Use 'strip-runpath' instead of PatchELF Ludovic Courtès
2018-05-04 20:52 ` [bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin) Ludovic Courtès
[not found] ` <CADh9keX7zyDOoNFstawVKdinxNOMKfff3jQuZUOvxFDawZP9Hw@mail.gmail.com>
2018-05-05 20:02 ` Ludovic Courtès
2018-05-07 9:24 ` bug#31208: " Ludovic Courtès
2018-05-07 9:32 ` [bug#31208] " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180418164054.29979-2-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=31208@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.