projects/guix·blob javascript-team · refs

150 lines · 6.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2018 Ludovic Courtès <[email protected]>
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-debug-link)
20 #:use-module (guix elf)
21 #:use-module (guix build utils)
22 #:use-module (guix build debug-link)
23 #:use-module (guix gexp)
24 #:use-module (guix store)
25 #:use-module (guix tests)
26 #:use-module (guix monads)
27 #:use-module (guix derivations)
28 #:use-module (gnu packages bootstrap)
29 #:use-module (srfi srfi-1)
30 #:use-module (srfi srfi-26)
31 #:use-module (srfi srfi-64)
32 #:use-module (rnrs io ports)
33 #:use-module (ice-9 match))
34
35(define %guile-executable
36 (match (false-if-exception (readlink "/proc/self/exe"))
37 ((? string? program)
38 (and (file-exists? program) (elf-file? program)
39 program))
40 (_
41 #f)))
42
43(define read-elf
44 (compose parse-elf get-bytevector-all))
45
46
47(test-begin "debug-link")
48
49(unless %guile-executable (test-skip 1))
50(test-assert "elf-debuglink"
51 (let ((elf (call-with-input-file %guile-executable read-elf)))
52 (match (call-with-values (lambda () (elf-debuglink elf)) list)
53 ((#f #f) ;no '.gnu_debuglink' section
54 (pk 'no-debuglink #t))
55 (((? string? file) (? integer? crc))
56 (string-suffix? ".debug" file)))))
57
58;; Since we need %BOOTSTRAP-GCC and co., we have to skip the following tests
59;; when networking is unreachable because we'd fail to download it.
60(unless (network-reachable?) (test-skip 1))
61(test-assertm "elf-debuglink"
62 ;; Check whether we can compute the CRC just like objcopy, and whether we
63 ;; can retrieve it.
64 (let* ((code (plain-file "test.c" "int main () { return 42; }"))
65 (exp (with-imported-modules '((guix build utils)
66 (guix build debug-link)
67 (guix elf))
68 #~(begin
69 (use-modules (guix build utils)
70 (guix build debug-link)
71 (guix elf)
72 (rnrs io ports))
73
74 (define read-elf
75 (compose parse-elf get-bytevector-all))
76
77 (setenv "PATH" (string-join '(#$%bootstrap-gcc
78 #$%bootstrap-binutils)
79 "/bin:" 'suffix))
80 (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
81 (copy-file "exe" "exe.debug")
82 (invoke "strip" "--only-keep-debug" "exe.debug")
83 (invoke "strip" "--strip-debug" "exe")
84 (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
85 "exe")
86 (call-with-values (lambda ()
87 (elf-debuglink
88 (call-with-input-file "exe"
89 read-elf)))
90 (lambda (file crc)
91 (call-with-output-file #$output
92 (lambda (port)
93 (let ((expected (call-with-input-file "exe.debug"
94 debuglink-crc32)))
95 (write (list file (= crc expected))
96 port))))))))))
97 (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
98 (x (built-derivations (list drv))))
99 (call-with-input-file (derivation->output-path drv)
100 (lambda (port)
101 (return (match (read port)
102 (("exe.debug" #t) #t)
103 (x (pk 'fail x #f)))))))))
104
105(unless (network-reachable?) (test-skip 1))
106(test-assertm "set-debuglink-crc"
107 ;; Check whether 'set-debuglink-crc' successfully updates the CRC.
108 (let* ((code (plain-file "test.c" "int main () { return 42; }"))
109 (debug (plain-file "exe.debug" "a"))
110 (exp (with-imported-modules '((guix build utils)
111 (guix build debug-link)
112 (guix elf))
113 #~(begin
114 (use-modules (guix build utils)
115 (guix build debug-link)
116 (guix elf)
117 (rnrs io ports))
118
119 (define read-elf
120 (compose parse-elf get-bytevector-all))
121
122 (setenv "PATH" (string-join '(#$%bootstrap-gcc
123 #$%bootstrap-binutils)
124 "/bin:" 'suffix))
125 (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
126 (copy-file "exe" "exe.debug")
127 (invoke "strip" "--only-keep-debug" "exe.debug")
128 (invoke "strip" "--strip-debug" "exe")
129 (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
130 "exe")
131 (set-debuglink-crc "exe" #$debug)
132 (call-with-values (lambda ()
133 (elf-debuglink
134 (call-with-input-file "exe"
135 read-elf)))
136 (lambda (file crc)
137 (call-with-output-file #$output
138 (lambda (port)
139 (write (list file crc) port)))))))))
140 (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
141 (x (built-derivations (list drv))))
142 (call-with-input-file (derivation->output-path drv)
143 (lambda (port)
144 (return (match (read port)
145 (("exe.debug" crc)
146 (= crc (debuglink-crc32 (open-input-string "a"))))
147 (x
148 (pk 'fail x #f)))))))))
149
150(test-end "debug-link")