tests/gremlin.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2018, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2022 Chris Marusich <cmmarusich@gmail.com>
   4 ;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (test-gremlin)
  22   #:use-module (guix elf)
  23   #:use-module (guix tests)
  24   #:use-module ((guix utils) #:select (call-with-temporary-directory
  25                                        target-aarch64?))
  26   #:use-module (guix build utils)
  27   #:use-module (guix build gremlin)
  28   #:use-module (gnu packages bootstrap)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-64)
  33   #:use-module (rnrs io ports)
  34   #:use-module (ice-9 popen)
  35   #:use-module (ice-9 rdelim)
  36   #:use-module (ice-9 regex)
  37   #:use-module (ice-9 match))
  38
  39 (define %guile-executable
  40   (match (false-if-exception (readlink "/proc/self/exe"))
  41     ((? string? program)
  42      (and (file-exists? program) (elf-file? program)
  43           program))
  44     (_
  45      #f)))
  46
  47 (define read-elf
  48   (compose parse-elf get-bytevector-all))
  49
  50 (define c-compiler
  51   (or (which "gcc") (which "cc") (which "g++")))
  52
  53 \f
  54 (test-begin "gremlin")
  55
  56 (unless %guile-executable (test-skip 1))
  57 (test-assert "elf-dynamic-info-needed, executable"
  58   (let* ((elf     (call-with-input-file %guile-executable read-elf))
  59          (dyninfo (elf-dynamic-info elf)))
  60     (or (not dyninfo)                             ;static executable
  61         (lset<= string=?
  62                 (list (string-append "libguile-" (effective-version))
  63                       "libc")
  64                 (map (lambda (lib)
  65                        (string-take lib (string-contains lib ".so")))
  66                      (elf-dynamic-info-needed dyninfo))))))
  67
  68 (unless (and %guile-executable (not (getenv "LD_LIBRARY_PATH"))
  69              (file-needed %guile-executable) ;statically linked?
  70              ;; When Guix has been built on a foreign distro, using a
  71              ;; toolchain and libraries from that foreign distro, it is not
  72              ;; unusual for the runpath to be empty.
  73              (pair? (file-runpath %guile-executable)))
  74   (test-skip 1))
  75 (test-assert "file-needed/recursive"
  76   (let* ((needed (file-needed/recursive %guile-executable))
  77          (pipe   (dynamic-wind
  78                    (lambda ()
  79                      ;; Tell ld.so to list loaded objects, like 'ldd' does.
  80                      (setenv "LD_TRACE_LOADED_OBJECTS" "yup"))
  81                    (lambda ()
  82                      (open-pipe* OPEN_READ %guile-executable))
  83                    (lambda ()
  84                      (unsetenv "LD_TRACE_LOADED_OBJECTS")))))
  85     (define ldd-rx
  86       (make-regexp "^[[:blank:]]+([[:graph:]]+ => )?([[:graph:]]+) .*$"))
  87
  88     (define (read-ldd-output port)
  89       ;; Read from PORT output in GNU ldd format.
  90       (let loop ((result '()))
  91         (match (read-line port)
  92           ((? eof-object?)
  93            (reverse result))
  94           ((= (cut regexp-exec ldd-rx <>) m)
  95            (if m
  96                (loop (cons (match:substring m 2) result))
  97                (loop result))))))
  98     (define ground-truth
  99       (remove (lambda (entry)
 100                 ;; See vdso(7) for the list of vDSO names across
 101                 ;; architectures.
 102                 (or (string-prefix? "linux-vdso.so" entry)
 103                     (string-prefix? "linux-vdso32.so" entry) ;32-bit powerpc
 104                     (string-prefix? "linux-vdso64.so" entry) ;64-bit powerpc
 105                     (string-prefix? "linux-gate.so" entry)   ;i386
 106                     ;; FIXME: ELF files on aarch64 do not always include a
 107                     ;; NEEDED entry for the dynamic linker, and it is unclear
 108                     ;; if that is OK.  See: https://issues.guix.gnu.org/52943
 109                     (and (target-aarch64?)
 110                          (string-contains entry (glibc-dynamic-linker)))))
 111               (read-ldd-output pipe)))
 112
 113     (and (zero? (close-pipe pipe))
 114          ;; It's OK if file-needed/recursive returns multiple entries that are
 115          ;; different strings referring to the same file.  This appears to be a
 116          ;; benign edge case.  See: https://issues.guix.gnu.org/52940
 117          (lset= file=? (pk 'truth ground-truth) (pk 'needed needed)))))
 118
 119 (test-equal "expand-origin"
 120   '("OOO/../lib"
 121     "OOO"
 122     "../OOO/bar/OOO/baz"
 123     "ORIGIN/foo")
 124   (map (cut expand-origin <> "OOO")
 125        '("$ORIGIN/../lib"
 126          "${ORIGIN}"
 127          "../${ORIGIN}/bar/$ORIGIN/baz"
 128          "ORIGIN/foo")))
 129
 130 (unless c-compiler
 131   (test-skip 1))
 132 (test-equal "strip-runpath"
 133   "hello\n"
 134   (call-with-temporary-directory
 135    (lambda (directory)
 136      (with-directory-excursion directory
 137        (call-with-output-file "t.c"
 138          (lambda (port)
 139            (display "int main () { puts(\"hello\"); }" port)))
 140        (invoke c-compiler "t.c"
 141                "-Wl,--enable-new-dtags" "-Wl,-rpath=/foo" "-Wl,-rpath=/bar")
 142        (let* ((dyninfo (elf-dynamic-info
 143                         (parse-elf (call-with-input-file "a.out"
 144                                      get-bytevector-all))))
 145               (old     (elf-dynamic-info-runpath dyninfo))
 146               (new     (strip-runpath "a.out"))
 147               (new*    (strip-runpath "a.out")))
 148          (validate-needed-in-runpath "a.out")
 149          (and (member "/foo" old) (member "/bar" old)
 150               (not (member "/foo" new))
 151               (not (member "/bar" new))
 152               (equal? new* new)
 153               (let* ((pipe (open-input-pipe "./a.out"))
 154                      (str  (get-string-all pipe)))
 155                 (close-pipe pipe)
 156                 str)))))))
 157
 158 (unless c-compiler
 159   (test-skip 1))
 160 (test-equal "set-file-runpath + file-runpath"
 161   "hello\n"
 162   (call-with-temporary-directory
 163    (lambda (directory)
 164      (with-directory-excursion directory
 165        (call-with-output-file "t.c"
 166          (lambda (port)
 167            (display "int main () { puts(\"hello\"); }" port)))
 168
 169        (invoke c-compiler "t.c"
 170                "-Wl,--enable-new-dtags" "-Wl,-rpath=/xxxxxxxxx")
 171
 172        (let ((original-runpath (file-runpath "a.out")))
 173          (and (member "/xxxxxxxxx" original-runpath)
 174               (guard (c ((runpath-too-long-error? c)
 175                          (string=? "a.out" (runpath-too-long-error-file c))))
 176                 (set-file-runpath "a.out" (list (make-string 777 #\y))))
 177               (let ((runpath (delete "/xxxxxxxxx" original-runpath)))
 178                 (set-file-runpath "a.out" runpath)
 179                 (equal? runpath (file-runpath "a.out")))
 180               (let* ((pipe (open-input-pipe "./a.out"))
 181                      (str  (get-string-all pipe)))
 182                 (close-pipe pipe)
 183                 str)))))))
 184
 185 (unless c-compiler
 186   (test-skip 1))
 187 (test-equal "elf-dynamic-info-soname"
 188   "libfoo.so.2"
 189   (call-with-temporary-directory
 190    (lambda (directory)
 191      (with-directory-excursion directory
 192        (call-with-output-file "t.c"
 193          (lambda (port)
 194            (display "// empty file" port)))
 195        (invoke c-compiler "t.c"
 196                "-shared" "-Wl,-soname,libfoo.so.2")
 197        (let* ((dyninfo (elf-dynamic-info
 198                        (parse-elf (call-with-input-file "a.out"
 199                                     get-bytevector-all))))
 200               (soname  (elf-dynamic-info-soname dyninfo)))
 201          soname)))))
 202
 203 (test-end "gremlin")