Commit | Line | Data |
---|---|---|
93c33389 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2018 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-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 | ||
93c33389 LC |
46 | \f |
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") |