tests/gremlin.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-gremlin)
  20   #:use-module (guix elf)
  21   #:use-module ((guix utils) #:select (call-with-temporary-directory))
  22   #:use-module (guix build utils)
  23   #:use-module (guix build gremlin)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (srfi srfi-34)
  27   #:use-module (srfi srfi-64)
  28   #:use-module (rnrs io ports)
  29   #:use-module (ice-9 popen)
  30   #:use-module (ice-9 rdelim)
  31   #:use-module (ice-9 regex)
  32   #:use-module (ice-9 match))
  33
  34 (define %guile-executable
  35   (match (false-if-exception (readlink "/proc/self/exe"))
  36     ((? string? program)
  37      (and (file-exists? program) (elf-file? program)
  38           program))
  39     (_
  40      #f)))
  41
  42 (define read-elf
  43   (compose parse-elf get-bytevector-all))
  44
  45 (define c-compiler
  46   (or (which "gcc") (which "cc") (which "g++")))
  47
  48 \f
  49 (test-begin "gremlin")
  50
  51 (unless %guile-executable (test-skip 1))
  52 (test-assert "elf-dynamic-info-needed, executable"
  53   (let* ((elf     (call-with-input-file %guile-executable read-elf))
  54          (dyninfo (elf-dynamic-info elf)))
  55     (or (not dyninfo)                             ;static executable
  56         (lset<= string=?
  57                 (list (string-append "libguile-" (effective-version))
  58                       "libc")
  59                 (map (lambda (lib)
  60                        (string-take lib (string-contains lib ".so")))
  61                      (elf-dynamic-info-needed dyninfo))))))
  62
  63 (unless (and %guile-executable (not (getenv "LD_LIBRARY_PATH"))
  64              (file-needed %guile-executable))     ;statically linked?
  65   (test-skip 1))
  66 (test-assert "file-needed/recursive"
  67   (let* ((needed (file-needed/recursive %guile-executable))
  68          (pipe   (dynamic-wind
  69                    (lambda ()
  70                      ;; Tell ld.so to list loaded objects, like 'ldd' does.
  71                      (setenv "LD_TRACE_LOADED_OBJECTS" "yup"))
  72                    (lambda ()
  73                      (open-pipe* OPEN_READ %guile-executable))
  74                    (lambda ()
  75                      (unsetenv "LD_TRACE_LOADED_OBJECTS")))))
  76     (define ldd-rx
  77       (make-regexp "^[[:blank:]]+([[:graph:]]+ => )?([[:graph:]]+) .*$"))
  78
  79     (define (read-ldd-output port)
  80       ;; Read from PORT output in GNU ldd format.
  81       (let loop ((result '()))
  82         (match (read-line port)
  83           ((? eof-object?)
  84            (reverse result))
  85           ((= (cut regexp-exec ldd-rx <>) m)
  86            (if m
  87                (loop (cons (match:substring m 2) result))
  88                (loop result))))))
  89
  90     (define ground-truth
  91       (remove (cut string-prefix? "linux-vdso.so" <>)
  92               (read-ldd-output pipe)))
  93
  94     (and (zero? (close-pipe pipe))
  95          (lset= string=? (pk 'truth ground-truth) (pk 'needed needed)))))
  96
  97 (test-equal "expand-origin"
  98   '("OOO/../lib"
  99     "OOO"
 100     "../OOO/bar/OOO/baz"
 101     "ORIGIN/foo")
 102   (map (cut expand-origin <> "OOO")
 103        '("$ORIGIN/../lib"
 104          "${ORIGIN}"
 105          "../${ORIGIN}/bar/$ORIGIN/baz"
 106          "ORIGIN/foo")))
 107
 108 (unless c-compiler
 109   (test-skip 1))
 110 (test-equal "strip-runpath"
 111   "hello\n"
 112   (call-with-temporary-directory
 113    (lambda (directory)
 114      (with-directory-excursion directory
 115        (call-with-output-file "t.c"
 116          (lambda (port)
 117            (display "int main () { puts(\"hello\"); }" port)))
 118        (invoke c-compiler "t.c"
 119                "-Wl,--enable-new-dtags" "-Wl,-rpath=/foo" "-Wl,-rpath=/bar")
 120        (let* ((dyninfo (elf-dynamic-info
 121                         (parse-elf (call-with-input-file "a.out"
 122                                      get-bytevector-all))))
 123               (old     (elf-dynamic-info-runpath dyninfo))
 124               (new     (strip-runpath "a.out"))
 125               (new*    (strip-runpath "a.out")))
 126          (validate-needed-in-runpath "a.out")
 127          (and (member "/foo" old) (member "/bar" old)
 128               (not (member "/foo" new))
 129               (not (member "/bar" new))
 130               (equal? new* new)
 131               (let* ((pipe (open-input-pipe "./a.out"))
 132                      (str  (get-string-all pipe)))
 133                 (close-pipe pipe)
 134                 str)))))))
 135
 136 (unless c-compiler
 137   (test-skip 1))
 138 (test-equal "set-file-runpath + file-runpath"
 139   "hello\n"
 140   (call-with-temporary-directory
 141    (lambda (directory)
 142      (with-directory-excursion directory
 143        (call-with-output-file "t.c"
 144          (lambda (port)
 145            (display "int main () { puts(\"hello\"); }" port)))
 146
 147        (invoke c-compiler "t.c"
 148                "-Wl,--enable-new-dtags" "-Wl,-rpath=/xxxxxxxxx")
 149
 150        (let ((original-runpath (file-runpath "a.out")))
 151          (and (member "/xxxxxxxxx" original-runpath)
 152               (guard (c ((runpath-too-long-error? c)
 153                          (string=? "a.out" (runpath-too-long-error-file c))))
 154                 (set-file-runpath "a.out" (list (make-string 777 #\y))))
 155               (let ((runpath (delete "/xxxxxxxxx" original-runpath)))
 156                 (set-file-runpath "a.out" runpath)
 157                 (equal? runpath (file-runpath "a.out")))
 158               (let* ((pipe (open-input-pipe "./a.out"))
 159                      (str  (get-string-all pipe)))
 160                 (close-pipe pipe)
 161                 str)))))))
 162
 163 (test-end "gremlin")