summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/gremlin.scm132
-rw-r--r--guix/build/meson-build-system.scm8
-rw-r--r--guix/build/r-build-system.scm2
3 files changed, 100 insertions, 42 deletions
diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index bb019967e5..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:
;;;
@@ -99,10 +100,16 @@ dynamic linking information."
;; } d_un;
;; } Elf64_Dyn;
+(define-record-type <dynamic-entry>
+ (dynamic-entry type value offset)
+ dynamic-entry?
+ (type dynamic-entry-type) ;DT_*
+ (value dynamic-entry-value) ;string | number | ...
+ (offset dynamic-entry-offset)) ;integer
+
(define (raw-dynamic-entries elf segment)
- "Return as a list of type/value pairs all the dynamic entries found in
-SEGMENT, the 'PT_DYNAMIC' segment of ELF. In the result, each car is a DT_
-value, and the interpretation of the cdr depends on the type."
+ "Return as a list of <dynamic-entry> for the dynamic entries found in
+SEGMENT, the 'PT_DYNAMIC' segment of ELF."
(define start
(elf-segment-offset segment))
(define bytes
@@ -123,7 +130,9 @@ value, and the interpretation of the cdr depends on the type."
(if (= type DT_NULL) ;finished?
(reverse result)
(loop (+ offset (* 2 word-size))
- (alist-cons type value result)))))))
+ (cons (dynamic-entry type value
+ (+ start offset word-size))
+ result)))))))
(define (vma->offset elf vma)
"Convert VMA, a virtual memory address, to an offset within ELF.
@@ -148,35 +157,33 @@ offset."
(define (dynamic-entries elf segment)
"Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
-of ELF, as a list of type/value pairs. The type is a DT_ value, and the value
-may be a string or an integer depending on the entry type (for instance, the
-value of DT_NEEDED entries is a string.)"
+of ELF, as a list of <dynamic-entry>. The value of each entry may be a string
+or an integer depending on the entry type (for instance, the value of
+DT_NEEDED entries is a string.) Likewise the offset is the offset within the
+string table if the type is a string."
(define entries
(raw-dynamic-entries elf segment))
(define string-table-offset
- (any (match-lambda
- ((type . value)
- (and (= type DT_STRTAB) value))
- (_ #f))
+ (any (lambda (entry)
+ (and (= (dynamic-entry-type entry) DT_STRTAB)
+ (dynamic-entry-value entry)))
entries))
- (define (interpret-dynamic-entry type value)
- (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
- (if string-table-offset
- (pointer->string
- (bytevector->pointer (elf-bytes elf)
- (vma->offset
- elf
- (+ string-table-offset value))))
- value))
- (else
- value)))
-
- (map (match-lambda
- ((type . value)
- (cons type (interpret-dynamic-entry type value))))
- entries))
+ (define (interpret-dynamic-entry entry)
+ (let ((type (dynamic-entry-type entry))
+ (value (dynamic-entry-value entry)))
+ (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
+ (if string-table-offset
+ (let* ((offset (vma->offset elf (+ string-table-offset value)))
+ (value (pointer->string
+ (bytevector->pointer (elf-bytes elf) offset))))
+ (dynamic-entry type value offset))
+ (dynamic-entry type value (dynamic-entry-offset entry))))
+ (else
+ (dynamic-entry type value (dynamic-entry-offset entry))))))
+
+ (map interpret-dynamic-entry entries))
;;;
@@ -200,21 +207,29 @@ value of DT_NEEDED entries is a string.)"
(define (elf-dynamic-info elf)
"Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
#f if ELF lacks dynamic-link information."
+ (define (matching-entry type)
+ (lambda (entry)
+ (= type (dynamic-entry-type entry))))
+
(match (dynamic-link-segment elf)
(#f #f)
((? elf-segment? dynamic)
(let ((entries (dynamic-entries elf dynamic)))
- (%elf-dynamic-info (assv-ref entries DT_SONAME)
- (filter-map (match-lambda
- ((type . value)
- (and (= type DT_NEEDED) value))
- (_ #f))
+ (%elf-dynamic-info (find (matching-entry DT_SONAME) entries)
+ (filter-map (lambda (entry)
+ (and (= (dynamic-entry-type entry)
+ DT_NEEDED)
+ (dynamic-entry-value entry)))
entries)
- (or (and=> (assv-ref entries DT_RPATH)
- search-path->list)
+ (or (and=> (find (matching-entry DT_RPATH)
+ entries)
+ (compose search-path->list
+ dynamic-entry-value))
'())
- (or (and=> (assv-ref entries DT_RUNPATH)
- search-path->list)
+ (or (and=> (find (matching-entry DT_RUNPATH)
+ entries)
+ (compose search-path->list
+ dynamic-entry-value))
'()))))))
(define %libc-libraries
@@ -306,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/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
index e4aae8212f..9724764424 100644
--- a/guix/build/meson-build-system.scm
+++ b/guix/build/meson-build-system.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -75,9 +76,8 @@
"1"))
(if tests?
(invoke "ninja" test-target)
- (begin
- (format #t "test suite not run~%")
- #t)))
+ (format #t "test suite not run~%"))
+ #t)
(define* (install #:rest args)
(invoke "ninja" "install"))
@@ -134,7 +134,7 @@ for example libraries only needed for the tests."
(find-files dir elf-pred))
existing-elf-dirs))))
(for-each (lambda (elf-file)
- (invoke "patchelf" "--shrink-rpath" elf-file)
+ (strip-runpath elf-file)
(handle-file elf-file elf-list))
elf-list)))))
(for-each handle-output outputs)
diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm
index 4d8ac5b479..2c0b322da9 100644
--- a/guix/build/r-build-system.scm
+++ b/guix/build/r-build-system.scm
@@ -44,7 +44,7 @@
(unless (zero? code)
(raise (condition ((@@ (guix build utils) &invoke-error)
(program "R")
- (arguments (string-append params " " command))
+ (arguments (cons command params))
(exit-status (status:exit-val code))
(term-signal (status:term-sig code))
(stop-signal (status:stop-sig code)))))))))