gremlin.scm 6.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186
  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. (define-module (test-gremlin)
  19. #:use-module (guix elf)
  20. #:use-module ((guix utils) #:select (call-with-temporary-directory))
  21. #:use-module (guix build utils)
  22. #:use-module (guix build gremlin)
  23. #:use-module (srfi srfi-1)
  24. #:use-module (srfi srfi-26)
  25. #:use-module (srfi srfi-34)
  26. #:use-module (srfi srfi-64)
  27. #:use-module (rnrs io ports)
  28. #:use-module (ice-9 popen)
  29. #:use-module (ice-9 rdelim)
  30. #:use-module (ice-9 regex)
  31. #:use-module (ice-9 match))
  32. (define %guile-executable
  33. (match (false-if-exception (readlink "/proc/self/exe"))
  34. ((? string? program)
  35. (and (file-exists? program) (elf-file? program)
  36. program))
  37. (_
  38. #f)))
  39. (define read-elf
  40. (compose parse-elf get-bytevector-all))
  41. (define c-compiler
  42. (or (which "gcc") (which "cc") (which "g++")))
  43. (test-begin "gremlin")
  44. (unless %guile-executable (test-skip 1))
  45. (test-assert "elf-dynamic-info-needed, executable"
  46. (let* ((elf (call-with-input-file %guile-executable read-elf))
  47. (dyninfo (elf-dynamic-info elf)))
  48. (or (not dyninfo) ;static executable
  49. (lset<= string=?
  50. (list (string-append "libguile-" (effective-version))
  51. "libc")
  52. (map (lambda (lib)
  53. (string-take lib (string-contains lib ".so")))
  54. (elf-dynamic-info-needed dyninfo))))))
  55. (unless (and %guile-executable (not (getenv "LD_LIBRARY_PATH"))
  56. (file-needed %guile-executable) ;statically linked?
  57. ;; When Guix has been built on a foreign distro, using a
  58. ;; toolchain and libraries from that foreign distro, it is not
  59. ;; unusual for the runpath to be empty.
  60. (pair? (file-runpath %guile-executable)))
  61. (test-skip 1))
  62. (test-assert "file-needed/recursive"
  63. (let* ((needed (file-needed/recursive %guile-executable))
  64. (pipe (dynamic-wind
  65. (lambda ()
  66. ;; Tell ld.so to list loaded objects, like 'ldd' does.
  67. (setenv "LD_TRACE_LOADED_OBJECTS" "yup"))
  68. (lambda ()
  69. (open-pipe* OPEN_READ %guile-executable))
  70. (lambda ()
  71. (unsetenv "LD_TRACE_LOADED_OBJECTS")))))
  72. (define ldd-rx
  73. (make-regexp "^[[:blank:]]+([[:graph:]]+ => )?([[:graph:]]+) .*$"))
  74. (define (read-ldd-output port)
  75. ;; Read from PORT output in GNU ldd format.
  76. (let loop ((result '()))
  77. (match (read-line port)
  78. ((? eof-object?)
  79. (reverse result))
  80. ((= (cut regexp-exec ldd-rx <>) m)
  81. (if m
  82. (loop (cons (match:substring m 2) result))
  83. (loop result))))))
  84. (define ground-truth
  85. (remove (cut string-prefix? "linux-vdso.so" <>)
  86. (read-ldd-output pipe)))
  87. (and (zero? (close-pipe pipe))
  88. (lset= string=? (pk 'truth ground-truth) (pk 'needed needed)))))
  89. (test-equal "expand-origin"
  90. '("OOO/../lib"
  91. "OOO"
  92. "../OOO/bar/OOO/baz"
  93. "ORIGIN/foo")
  94. (map (cut expand-origin <> "OOO")
  95. '("$ORIGIN/../lib"
  96. "${ORIGIN}"
  97. "../${ORIGIN}/bar/$ORIGIN/baz"
  98. "ORIGIN/foo")))
  99. (unless c-compiler
  100. (test-skip 1))
  101. (test-equal "strip-runpath"
  102. "hello\n"
  103. (call-with-temporary-directory
  104. (lambda (directory)
  105. (with-directory-excursion directory
  106. (call-with-output-file "t.c"
  107. (lambda (port)
  108. (display "int main () { puts(\"hello\"); }" port)))
  109. (invoke c-compiler "t.c"
  110. "-Wl,--enable-new-dtags" "-Wl,-rpath=/foo" "-Wl,-rpath=/bar")
  111. (let* ((dyninfo (elf-dynamic-info
  112. (parse-elf (call-with-input-file "a.out"
  113. get-bytevector-all))))
  114. (old (elf-dynamic-info-runpath dyninfo))
  115. (new (strip-runpath "a.out"))
  116. (new* (strip-runpath "a.out")))
  117. (validate-needed-in-runpath "a.out")
  118. (and (member "/foo" old) (member "/bar" old)
  119. (not (member "/foo" new))
  120. (not (member "/bar" new))
  121. (equal? new* new)
  122. (let* ((pipe (open-input-pipe "./a.out"))
  123. (str (get-string-all pipe)))
  124. (close-pipe pipe)
  125. str)))))))
  126. (unless c-compiler
  127. (test-skip 1))
  128. (test-equal "set-file-runpath + file-runpath"
  129. "hello\n"
  130. (call-with-temporary-directory
  131. (lambda (directory)
  132. (with-directory-excursion directory
  133. (call-with-output-file "t.c"
  134. (lambda (port)
  135. (display "int main () { puts(\"hello\"); }" port)))
  136. (invoke c-compiler "t.c"
  137. "-Wl,--enable-new-dtags" "-Wl,-rpath=/xxxxxxxxx")
  138. (let ((original-runpath (file-runpath "a.out")))
  139. (and (member "/xxxxxxxxx" original-runpath)
  140. (guard (c ((runpath-too-long-error? c)
  141. (string=? "a.out" (runpath-too-long-error-file c))))
  142. (set-file-runpath "a.out" (list (make-string 777 #\y))))
  143. (let ((runpath (delete "/xxxxxxxxx" original-runpath)))
  144. (set-file-runpath "a.out" runpath)
  145. (equal? runpath (file-runpath "a.out")))
  146. (let* ((pipe (open-input-pipe "./a.out"))
  147. (str (get-string-all pipe)))
  148. (close-pipe pipe)
  149. str)))))))
  150. (unless c-compiler
  151. (test-skip 1))
  152. (test-equal "elf-dynamic-info-soname"
  153. "libfoo.so.2"
  154. (call-with-temporary-directory
  155. (lambda (directory)
  156. (with-directory-excursion directory
  157. (call-with-output-file "t.c"
  158. (lambda (port)
  159. (display "// empty file" port)))
  160. (invoke c-compiler "t.c"
  161. "-shared" "-Wl,-soname,libfoo.so.2")
  162. (let* ((dyninfo (elf-dynamic-info
  163. (parse-elf (call-with-input-file "a.out"
  164. get-bytevector-all))))
  165. (soname (elf-dynamic-info-soname dyninfo)))
  166. soname)))))
  167. (test-end "gremlin")