From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:59006) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1f8q9k-0004M9-5X for guix-patches@gnu.org; Wed, 18 Apr 2018 12:42:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1f8q9j-0003jO-1B for guix-patches@gnu.org; Wed, 18 Apr 2018 12:42:04 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:51618) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1f8q9i-0003jK-Tk for guix-patches@gnu.org; Wed, 18 Apr 2018 12:42:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1f8q9i-00027x-NV for guix-patches@gnu.org; Wed, 18 Apr 2018 12:42:02 -0400 Subject: [bug#31208] [PATCH 2/3] gremlin: Add 'strip-runpath'. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 18 Apr 2018 18:40:53 +0200 Message-Id: <20180418164054.29979-2-ludo@gnu.org> In-Reply-To: <20180418164054.29979-1-ludo@gnu.org> References: <20180418164054.29979-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 31208@debbugs.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 +;;; Copyright © 2015, 2018 Ludovic Courtès ;;; ;;; 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") -- 2.17.0