projects/guix·blob java-team · refs

946 lines · 35.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2021-2024, 2026 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 (tests-style)
20 #:use-module ((gcrypt hash) #:select (port-sha256))
21 #:use-module (guix packages)
22 #:use-module (guix read-print)
23 #:use-module (guix scripts style)
24 #:use-module ((guix utils)
25 #:select (guile-version>?
26 call-with-temporary-directory))
27 #:use-module ((guix build utils) #:select (substitute*))
28 #:use-module (guix gexp) ;for the reader extension
29 #:use-module (guix diagnostics)
30 #:use-module (guix git)
31 #:use-module (guix tests)
32 #:use-module (guix tests git)
33 #:use-module (gnu packages)
34 #:use-module (gnu packages acl)
35 #:use-module (gnu packages multiprecision)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-26)
38 #:use-module (srfi srfi-64)
39 #:use-module (ice-9 match)
40 #:use-module (ice-9 rdelim)
41 #:use-module (ice-9 pretty-print)
42 #:use-module (ice-9 vlist))
43
44(define* (call-with-test-package inputs proc #:optional suffix)
45 (let ((module-name (if suffix
46 (string-append "my-packages-" suffix)
47 "my-packages"))
48 (name (if suffix
49 (string-append "my-coreutils-" suffix)
50 "my-coreutils")))
51 (call-with-temporary-directory
52 (lambda (directory)
53 (call-with-output-file (string-append directory "/" module-name ".scm")
54 (lambda (port)
55 (pretty-print
56 `(begin
57 (define-module (,(string->symbol module-name))
58 #:use-module (guix)
59 #:use-module (guix git-download) ; for -S git-source
60 #:use-module ((gnu packages) #:select (search-patches))
61 #:use-module (guix licenses)
62 #:use-module (gnu packages acl)
63 #:use-module (gnu packages base)
64 #:use-module (gnu packages multiprecision)
65 #:use-module (srfi srfi-1))
66
67 (define base
68 (package
69 (inherit coreutils)
70 (inputs '())
71 (native-inputs '())
72 (propagated-inputs '())))
73
74 (define (sdl-union . lst)
75 (package
76 (inherit base)
77 (name "sdl-union")))
78
79 (define-public ,(string->symbol name)
80 (package
81 (inherit base)
82 (name ,name)
83 ,@inputs
84 ;; XXX: The field below was added so that the 'inputs'
85 ;; field doesn't come last; if it did, 'read-package-field'
86 ;; in the tests below would read the three closing parens
87 ;; for each test.
88 (properties '()))))
89 port)))
90
91 (proc directory)))))
92
93(define test-directory
94 ;; Directory where the package definition lives.
95 (make-parameter #f))
96
97(define-syntax-rule (with-test-package fields exp ...)
98 (call-with-test-package fields
99 (lambda (directory)
100 (define file
101 (string-append directory "/my-packages.scm"))
102
103 ;; Run as a separate process to make sure FILE is reloaded.
104 (system* "guix" "style" "-L" directory "-S" "inputs"
105 "my-coreutils")
106 (system* "cat" file)
107
108 (load file)
109 (parameterize ((test-directory directory))
110 exp ...))))
111
112(define* (read-lines port line #:optional (count 1))
113 "Read COUNT lines from PORT, starting from LINE."
114 (let loop ((lines '())
115 (count count))
116 (cond ((< (port-line port) (- line 1))
117 (read-char port)
118 (loop lines count))
119 ((zero? count)
120 (string-concatenate-reverse lines))
121 (else
122 (match (read-line port 'concat)
123 ((? eof-object?)
124 (loop lines 0))
125 (line
126 (loop (cons line lines) (- count 1))))))))
127
128(define* (read-package-field package field #:optional (count 1))
129 (let* ((location (package-field-location package field))
130 (file (location-file location))
131 (line (location-line location))
132 (absolute-file (if (string-prefix? "/" file)
133 file
134 (string-append (test-directory) "/"
135 file)))
136 (lines (call-with-input-file absolute-file
137 (lambda (port)
138 (read-lines port line count)))))
139 (call-with-input-string lines read-with-comments/sequence)))
140
141
142(test-begin "style")
143
144(test-equal "nothing to rewrite"
145 '()
146 (with-test-package '()
147 (package-direct-inputs (@ (my-packages) my-coreutils))))
148
149(test-equal "input labels, mismatch"
150 (list `(("foo" ,gmp) ("bar" ,acl))
151 '((inputs `(("foo" ,gmp) ("bar" ,acl)))))
152 (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
153 (list (package-direct-inputs (@ (my-packages) my-coreutils))
154 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
155
156(test-equal "input labels, simple"
157 (list `(("gmp" ,gmp) ("acl" ,acl))
158 '((inputs (list gmp acl))))
159 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
160 (list (package-direct-inputs (@ (my-packages) my-coreutils))
161 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
162
163(test-equal "input labels, long list with one item per line"
164 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
165 '((list gmp acl gmp acl gmp acl gmp acl) unbalanced))
166 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
167 ("gmp" ,gmp) ("acl" ,acl)
168 ("gmp" ,gmp) ("acl" ,acl)
169 ("gmp" ,gmp) ("acl" ,acl))))
170 (list (package-direct-inputs (@ (my-packages) my-coreutils))
171 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
172
173(test-equal "input labels, sdl-union"
174 '((inputs (list gmp acl (sdl-union 1 2 3 4))))
175 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
176 ("sdl-union" ,(sdl-union 1 2 3 4)))))
177 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
178
179(test-equal "input labels, output"
180 (list `(("gmp" ,gmp "debug") ("acl" ,acl))
181 '((inputs (list `(,gmp "debug") acl))))
182 (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
183 (list (package-direct-inputs (@ (my-packages) my-coreutils))
184 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
185
186(test-equal "input labels, prepend"
187 (list `(("gmp" ,gmp) ("acl" ,acl))
188 '((modify-inputs (package-propagated-inputs coreutils)
189 (prepend gmp acl)) unbalanced))
190 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
191 ,@(package-propagated-inputs coreutils))))
192 (list (package-inputs (@ (my-packages) my-coreutils))
193 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
194
195(test-equal "input labels, prepend + delete"
196 (list `(("gmp" ,gmp) ("acl" ,acl))
197 `((modify-inputs (package-propagated-inputs coreutils)
198 (delete "gmp")
199 (prepend gmp acl)) unbalanced))
200 (with-test-package '((inputs `(("gmp" ,gmp)
201 ("acl" ,acl)
202 ,@(alist-delete "gmp"
203 (package-propagated-inputs coreutils)))))
204 (list (package-inputs (@ (my-packages) my-coreutils))
205 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
206
207(test-equal "input labels, prepend + delete multiple"
208 (list `(("gmp" ,gmp) ("acl" ,acl))
209 '((modify-inputs (package-propagated-inputs coreutils)
210 (delete "foo" "bar" "baz")
211 (prepend gmp acl)) unbalanced))
212 (with-test-package '((inputs `(("gmp" ,gmp)
213 ("acl" ,acl)
214 ,@(fold alist-delete
215 (package-propagated-inputs coreutils)
216 '("foo" "bar" "baz")))))
217 (list (package-inputs (@ (my-packages) my-coreutils))
218 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
219
220(test-equal "input labels, replace"
221 (list '() ;there's no "gmp" input to replace
222 '((modify-inputs (package-propagated-inputs coreutils)
223 (replace "gmp" gmp)) unbalanced))
224 (with-test-package '((inputs `(("gmp" ,gmp)
225 ,@(alist-delete "gmp"
226 (package-propagated-inputs coreutils)))))
227 (list (package-inputs (@ (my-packages) my-coreutils))
228 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
229
230(test-equal "input labels, 'safe' policy"
231 (list `(("gmp" ,gmp) ("acl" ,acl))
232 '((inputs (list gmp acl))))
233 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
234 (arguments '())) ;no build system arguments
235 (lambda (directory)
236 (define file
237 (string-append directory "/my-packages.scm"))
238
239 (system* "guix" "style" "-L" directory "my-coreutils"
240 "-S" "inputs"
241 "--input-simplification=safe")
242
243 (load file)
244 (list (package-inputs (@ (my-packages) my-coreutils))
245 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
246
247(test-equal "input labels, 'safe' policy, trivial arguments"
248 (list `(("gmp" ,gmp) ("mpfr" ,mpfr))
249 `((inputs (list gmp mpfr))))
250 (call-with-test-package '((inputs `(("GMP" ,gmp) ("Mpfr" ,mpfr)))
251 (arguments ;"trivial" arguments
252 '(#:tests? #f
253 #:test-target "whatever")))
254 (lambda (directory)
255 (define file
256 (string-append directory "/my-packages.scm"))
257
258 (system* "guix" "style" "-L" directory "my-coreutils"
259 "-S" "inputs"
260 "--input-simplification=safe")
261
262 (load file)
263 (list (package-inputs (@ (my-packages) my-coreutils))
264 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
265
266(test-equal "input labels, 'safe' policy, nothing changed"
267 (list `(("GMP" ,gmp) ("ACL" ,acl))
268 '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))))
269 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
270 ;; Non-empty argument list, so potentially unsafe
271 ;; input simplification.
272 (arguments
273 '(#:configure-flags
274 (assoc-ref %build-inputs "GMP"))))
275 (lambda (directory)
276 (define file
277 (string-append directory "/my-packages.scm"))
278
279 (system* "guix" "style" "-L" directory "my-coreutils"
280 "-S" "inputs"
281 "--input-simplification=safe")
282
283 (load file)
284 (list (package-inputs (@ (my-packages) my-coreutils))
285 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
286
287(test-equal "input labels, margin comment"
288 (list `(("gmp" ,gmp))
289 `(("acl" ,acl))
290 `((inputs (list gmp)) ,(comment ";margin comment\n" #t))
291 `((native-inputs (list acl)) ,(comment ";another one\n" #t)))
292 (call-with-test-package '((inputs `(("gmp" ,gmp)))
293 (native-inputs `(("acl" ,acl))))
294 (lambda (directory)
295 (define file
296 (string-append directory "/my-packages.scm"))
297
298 (substitute* file
299 (("\"gmp\"(.*)$" _ rest)
300 (string-append "\"gmp\"" (string-trim-right rest)
301 " ;margin comment\n"))
302 (("\"acl\"(.*)$" _ rest)
303 (string-append "\"acl\"" (string-trim-right rest)
304 " ;another one\n")))
305 (system* "cat" file)
306
307 (system* "guix" "style" "-L" directory "-S" "inputs"
308 "my-coreutils")
309
310 (load file)
311 (list (package-inputs (@ (my-packages) my-coreutils))
312 (package-native-inputs (@ (my-packages) my-coreutils))
313 (read-package-field (@ (my-packages) my-coreutils) 'inputs)
314 (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
315
316(test-equal "input labels, margin comment on long list"
317 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
318 `((list gmp ,(comment ";margin comment\n" #t)
319 acl
320 gmp ,(comment ";margin comment\n" #t)
321 acl
322 gmp ,(comment ";margin comment\n" #t)
323 acl
324 gmp ,(comment ";margin comment\n" #t)
325 acl)
326 unbalanced))
327 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
328 ("gmp" ,gmp) ("acl" ,acl)
329 ("gmp" ,gmp) ("acl" ,acl)
330 ("gmp" ,gmp) ("acl" ,acl))))
331 (lambda (directory)
332 (define file
333 (string-append directory "/my-packages.scm"))
334
335 (substitute* file
336 (("\"gmp\"(.*)$" _ rest)
337 (string-append "\"gmp\"" (string-trim-right rest)
338 " ;margin comment\n")))
339 (system* "cat" file)
340
341 (system* "guix" "style" "-L" directory "-S" "inputs"
342 "my-coreutils")
343
344 (load file)
345 (list (package-inputs (@ (my-packages) my-coreutils))
346 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
347
348(test-equal "input labels, line comment"
349 (list `(("gmp" ,gmp) ("acl" ,acl))
350 `((inputs (list gmp
351 ,(comment ";; line comment!\n")
352 acl))))
353 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
354 (lambda (directory)
355 (define file
356 (string-append directory "/my-packages.scm"))
357
358 (substitute* file
359 ((",gmp\\)(.*)$" _ rest)
360 (string-append ",gmp)\n ;; line comment!\n" rest)))
361
362 (system* "guix" "style" "-L" directory "-S" "inputs"
363 "my-coreutils")
364
365 (load file)
366 (list (package-inputs (@ (my-packages) my-coreutils))
367 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
368
369(test-equal "input labels, modify-inputs and margin comment"
370 (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
371 `((modify-inputs (package-propagated-inputs coreutils)
372 (prepend gmp ,(comment ";margin comment\n" #t)
373 acl ,(comment ";another one\n" #t)
374 mpfr)) unbalanced))
375 (call-with-test-package '((inputs
376 `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
377 ,@(package-propagated-inputs coreutils))))
378 (lambda (directory)
379 (define file
380 (string-append directory "/my-packages.scm"))
381
382 (substitute* file
383 ((",gmp\\)(.*)$" _ rest)
384 (string-append ",gmp) ;margin comment" rest))
385 ((",acl\\)(.*)$" _ rest)
386 (string-append ",acl) ;another one" rest)))
387
388 (system* "guix" "style" "-L" directory "-S" "inputs"
389 "my-coreutils")
390
391 (load file)
392 (list (package-inputs (@ (my-packages) my-coreutils))
393 (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
394
395(test-assert "gexpify arguments, already gexpified"
396 (call-with-test-package '((arguments
397 (list #:configure-flags #~'("--help"))))
398 (lambda (directory)
399 (define file
400 (string-append directory "/my-packages.scm"))
401 (define (fingerprint file)
402 (let ((stat (stat file)))
403 (list (stat:mtime stat) (stat:size stat))))
404 (define before
405 (fingerprint file))
406
407 (system* "guix" "style" "-L" directory "my-coreutils"
408 "-S" "arguments")
409
410 (equal? (fingerprint file) before))))
411
412(test-equal "gexpify arguments, non-gexp arguments, margin comment"
413 (list (list #:tests? #f #:test-target "check")
414 `((arguments (list #:tests? #f ,(comment ";no tests\n" #t)
415 #:test-target "check"))))
416 (call-with-test-package '((arguments
417 '(#:tests? #f
418 #:test-target "check")))
419 (lambda (directory)
420 (define file
421 (string-append directory "/my-packages.scm"))
422
423 (substitute* file
424 (("#:tests\\? #f" all)
425 (string-append all " ;no tests\n")))
426
427 (system* "guix" "style" "-L" directory "my-coreutils"
428 "-S" "arguments")
429
430 (load file)
431 (list (package-arguments (@ (my-packages) my-coreutils))
432 (read-package-field (@ (my-packages) my-coreutils) 'arguments 2)))))
433
434(test-equal "gexpify arguments, phases and flags"
435 `((list #:tests? #f
436 #:configure-flags #~'("--fast")
437 #:make-flags #~(list (string-append "CC=" #$(cc-for-target)))
438 #:phases #~(modify-phases %standard-phases
439 ,(comment ";; Line comment.\n")
440 whatever))
441 unbalanced)
442 (call-with-test-package '((arguments
443 `(#:tests? #f
444 #:configure-flags '("--fast")
445 #:make-flags
446 (list (string-append "CC=" ,(cc-for-target)))
447 #:phases (modify-phases %standard-phases
448 whatever))))
449 (lambda (directory)
450 (define file
451 (string-append directory "/my-packages.scm"))
452
453 (substitute* file
454 (("whatever")
455 "\n;; Line comment.
456 whatever"))
457 (system* "guix" "style" "-L" directory "my-coreutils"
458 "-S" "arguments")
459
460 (load file)
461 (read-package-field (@ (my-packages) my-coreutils) 'arguments 7))))
462
463(test-equal "gexpify arguments, append arguments"
464 `((append (list #:tests? #f
465 #:configure-flags #~'("--fast"))
466 (package-arguments coreutils)) unbalanced)
467 (call-with-test-package '((arguments
468 `(#:tests? #f
469 #:configure-flags '("--fast")
470 ,@(package-arguments coreutils))))
471 (lambda (directory)
472 (define file
473 (string-append directory "/my-packages.scm"))
474
475 (system* "guix" "style" "-L" directory "my-coreutils"
476 "-S" "arguments")
477
478 (load file)
479 (read-package-field (@ (my-packages) my-coreutils) 'arguments 3))))
480
481(test-equal "gexpify arguments, substitute-keyword-arguments"
482 `((substitute-keyword-arguments (package-arguments coreutils)
483 ((#:tests? _ #f)
484 #t)
485 ((#:make-flags flags #~'())
486 #~(cons "-DXYZ=yes" #$flags))) unbalanced)
487 (call-with-test-package '((arguments
488 (substitute-keyword-arguments
489 (package-arguments coreutils)
490 ((#:tests? _ #f) #t)
491 ((#:make-flags flags ''())
492 `(cons "-DXYZ=yes" ,flags)))))
493 (lambda (directory)
494 (define file
495 (string-append directory "/my-packages.scm"))
496
497 (system* "guix" "style" "-L" directory "my-coreutils"
498 "-S" "arguments")
499
500 (load file)
501 (read-package-field (@ (my-packages) my-coreutils) 'arguments 7))))
502
503(test-equal "gexpify arguments, substitute-keyword-arguments + unquote-splicing"
504 `((substitute-keyword-arguments (package-arguments coreutils)
505 ((#:make-flags flags #~'())
506 #~(cons "-DXYZ=yes" #$@(if #t flags '())))) unbalanced)
507 (call-with-test-package '((arguments
508 (substitute-keyword-arguments
509 (package-arguments coreutils)
510 ((#:make-flags flags ''())
511 `(cons "-DXYZ=yes" ,@(if #t flags '()))))))
512 (lambda (directory)
513 (define file
514 (string-append directory "/my-packages.scm"))
515
516 (system* "guix" "style" "-L" directory "my-coreutils"
517 "-S" "arguments")
518
519 (load file)
520 (read-package-field (@ (my-packages) my-coreutils) 'arguments 6))))
521
522(test-equal "gexpify arguments, append substitute-keyword-arguments"
523 `((append (list #:tests? #f)
524 (substitute-keyword-arguments (package-arguments coreutils)
525 ((#:make-flags flags)
526 #~(append `("-n" ,%output) #$flags)))) unbalanced)
527 (call-with-test-package '((arguments
528 `(#:tests? #f
529 ,@(substitute-keyword-arguments
530 (package-arguments coreutils)
531 ((#:make-flags flags)
532 `(append `("-n" ,%output) ,flags))))))
533 (lambda (directory)
534 (define file
535 (string-append directory "/my-packages.scm"))
536
537 (system* "guix" "style" "-L" directory "my-coreutils"
538 "-S" "arguments")
539
540 (load file)
541 (read-package-field (@ (my-packages) my-coreutils) 'arguments 5))))
542
543;;;
544;;; url-fetch->git-fetch transformation
545;;;
546
547(define %temporary-repository-file-name-too-long?
548 ;; Whether the file name of the repository created by
549 ;; 'with-temporary-git-repository' would be "too long." If it is too long
550 ;; --e.g,
551 ;; file:///tmp/guix-build-guix-1.5.0-3.17ec386.drv-0/guix-directory.lhhGOq--,
552 ;; the indentation rules differ, which would cause test failures below.
553 (> (string-length (or (getenv "TMPDIR") "/tmp")) 30))
554
555(when %temporary-repository-file-name-too-long?
556 (test-skip 1))
557(test-equal "url-fetch->git-fetch, basic transformation"
558 `((origin
559 (method git-fetch)
560 (uri (git-reference (url "https://github.com/foo/bar")
561 (commit version)))
562 (file-name (git-file-name name version))
563 (sha256
564 (base32 "0j8vhvfj1d3jvbrd4kh20m50knmwj19xk0l3s78z1xxayp3c5zkk")))
565 unbalanced
566 (properties (quote ()))
567 unbalanced unbalanced unbalanced)
568 (call-with-test-package
569 '((home-page "@substitute-me@")
570 (version "1.0")
571 (source
572 (origin
573 (method url-fetch)
574 (uri (string-append "https://example.com/foo-" version ".tar.gz"))
575 (sha256
576 (base32 "0000000000000000000000000000000000000000000000000000")))))
577 (lambda (directory)
578 (define file
579 (string-append directory "/my-packages-0.scm"))
580
581 (parameterize ((test-directory directory))
582 (with-temporary-git-repository repository
583 `((add "README" "Initial commit")
584 (commit "First commit")
585 (tag "1.0" "Initial release"))
586 (mock ((guix import utils) git-repository-url? (const #t))
587 (substitute* file
588 (("@substitute-me@")
589 (string-append "file://" repository)))
590 ;; XXX: Calling guix-style is necessary to use mock.
591 (guix-style "-L" directory "-S" "git-source" "my-coreutils-0")
592 (substitute* file
593 (((string-append "file://" repository))
594 "https://github.com/foo/bar"))
595
596 (load file)
597 (read-package-field (@ (my-packages-0) my-coreutils-0) 'source 8)))))
598 "0"))
599
600(when %temporary-repository-file-name-too-long?
601 (test-skip 1))
602(test-equal "url-fetch->git-fetch, preserved field"
603 `((origin
604 (method git-fetch)
605 (uri (git-reference
606 (url "https://github.com/foo/bar")
607 (commit version)))
608 (file-name (git-file-name name version))
609 (sha256
610 (base32 "0j8vhvfj1d3jvbrd4kh20m50knmwj19xk0l3s78z1xxayp3c5zkk"))
611 (patches (search-patches "foo.patch")))
612 unbalanced
613 (properties (quote ()))
614 unbalanced unbalanced unbalanced)
615 (call-with-test-package
616 '((home-page "@substitute-me@")
617 (version "1.0")
618 (source
619 (origin
620 (method url-fetch)
621 (uri "https://example.com/foo.tar.gz")
622 (sha256
623 (base32 "0000000000000000000000000000000000000000000000000000"))
624 (patches (search-patches "foo.patch")))))
625 (lambda (directory)
626 (define file
627 (string-append directory "/my-packages-1.scm"))
628 (call-with-output-file (string-append directory "/foo.patch")
629 (const #t))
630
631 (parameterize ((test-directory directory))
632 (with-temporary-git-repository repository
633 `((add "README" "Initial commit")
634 (commit "First commit")
635 (tag "1.0" "Initial release"))
636 (mock ((guix import utils) git-repository-url? (const #t))
637 (mock ((gnu packages) specification->package+output
638 (lambda (spec)
639 (car
640 (vhash-fold* cons '() spec
641 (fold-packages
642 (lambda (p r)
643 (vhash-cons (package-name p) p r))
644 vlist-null)))))
645 (substitute* file
646 (("@substitute-me@")
647 (string-append "file://" repository)))
648 ;; XXX: Calling guix-style is necessary to use mock.
649 (guix-style "-L" directory "-S" "git-source" "my-coreutils-1")
650 (substitute* file
651 (((string-append "file://" repository))
652 "https://github.com/foo/bar"))
653 (load file)
654 (read-package-field
655 (@ (my-packages-1) my-coreutils-1) 'source 9))))))
656 "1"))
657
658(unless (false-if-exception
659 (getaddrinfo "https.git.savannah.gnu.org" "https"))
660 (test-skip 1))
661(test-equal "url-fetch->git-fetch, mirror:// URL"
662 '((origin
663 (method git-fetch)
664 (uri (git-reference
665 (url "https://https.git.savannah.gnu.org/git/sed.git")
666 (commit (string-append "v" version))))
667 (file-name (git-file-name name version))
668 (sha256
669 (base32 "00p6v3aa22jz365scmifr06fspkylzrvbqda0waz4x06q5qv0263")))
670 unbalanced
671 (properties (quote ()))
672 unbalanced unbalanced unbalanced)
673 (call-with-test-package
674 '((version "4.9")
675 (source
676 (origin
677 (method url-fetch)
678 (uri (string-append "mirror://gnu/sed/sed-"
679 version ".tar.gz"))
680 (sha256
681 (base32 "0000000000000000000000000000000000000000000000000000")))))
682 (lambda (directory)
683 (define file
684 (string-append directory "/my-packages-1.scm"))
685
686 ;; Note: This ends up cloning the 'sed' repository on Savannah.
687 (system* "guix" "style" "-L" directory "-S" "git-source" "my-coreutils-1")
688
689 (load file)
690 (read-package-field (@ (my-packages-1) my-coreutils-1) 'source 8))
691 "1"))
692
693(test-assert "url-fetch->git-fetch, non-git home-page unchanged"
694 (call-with-test-package
695 '((home-page "https://www.example.com")
696 (source
697 (origin
698 (method url-fetch)
699 (uri "https://example.com/foo.tar.gz")
700 (sha256
701 (base32 "0000000000000000000000000000000000000000000000000000")))))
702 (lambda (directory)
703 (define file
704 (string-append directory "/my-packages.scm"))
705 (define before-hash
706 (call-with-input-file file port-sha256))
707
708 (system* "guix" "style" "-L" directory "-S" "git-source"
709 "my-coreutils")
710
711 ;; File should be unchanged
712 (equal? (call-with-input-file file port-sha256) before-hash))))
713
714(test-assert "url-fetch->git-fetch, already git-fetch unchanged"
715 (call-with-test-package
716 '((home-page "https://github.com/foo/bar")
717 (source
718 (origin
719 (method git-fetch)
720 (uri (git-reference
721 (url "https://github.com/foo/bar")
722 (commit version)))
723 (file-name (git-file-name name version))
724 (sha256
725 (base32 "0000000000000000000000000000000000000000000000000000")))))
726 (lambda (directory)
727 (define file
728 (string-append directory "/my-packages.scm"))
729 (define before-hash
730 (call-with-input-file file port-sha256))
731
732 (system* "guix" "style" "-L" directory "-S" "git-source"
733 "my-coreutils")
734
735 ;; File should be unchanged
736 (equal? (call-with-input-file file port-sha256) before-hash))))
737
738
739;;;
740;;; remove-input, remove-native-input, remove-propagated-input
741;;;
742
743(test-equal "remove-input, single input removed"
744 '((inputs (list)))
745 (call-with-test-package '((inputs (list gmp)))
746 (lambda (directory)
747 (define file
748 (string-append directory "/my-packages.scm"))
749
750 (system* "guix" "style" "-L" directory
751 "-S" "remove-input" "--parameter=gmp"
752 "my-coreutils")
753
754 (load file)
755 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
756
757(test-equal "remove-input, one of multiple inputs removed"
758 `(("acl" ,acl))
759 (call-with-test-package '((inputs (list gmp acl)))
760 (lambda (directory)
761 (define file
762 (string-append directory "/my-packages.scm"))
763
764 (system* "guix" "style" "-L" directory
765 "-S" "remove-input" "--parameter=gmp"
766 "my-coreutils")
767
768 (load file)
769 (package-inputs (@ (my-packages) my-coreutils)))))
770
771(test-equal "remove-input, middle input removed from list"
772 `(("gmp" ,gmp) ("mpfr" ,mpfr))
773 (call-with-test-package '((inputs (list gmp acl mpfr)))
774 (lambda (directory)
775 (define file
776 (string-append directory "/my-packages.scm"))
777
778 (system* "guix" "style" "-L" directory
779 "-S" "remove-input" "--parameter=acl"
780 "my-coreutils")
781
782 (load file)
783 (package-inputs (@ (my-packages) my-coreutils)))))
784
785(test-equal "remove-input, non-existent input unchanged"
786 `(("gmp" ,gmp) ("acl" ,acl))
787 (call-with-test-package '((inputs (list gmp acl)))
788 (lambda (directory)
789 (define file
790 (string-append directory "/my-packages.scm"))
791
792 (system* "guix" "style" "-L" directory
793 "-S" "remove-input" "--parameter=mpfr"
794 "my-coreutils")
795
796 (load file)
797 (package-inputs (@ (my-packages) my-coreutils)))))
798
799(test-equal "remove-input, input with output specifier"
800 `(("acl" ,acl))
801 (call-with-test-package '((inputs (list `(,gmp "debug") acl)))
802 (lambda (directory)
803 (define file
804 (string-append directory "/my-packages.scm"))
805
806 (system* "guix" "style" "-L" directory
807 "-S" "remove-input" "--parameter=gmp:debug"
808 "my-coreutils")
809
810 (load file)
811 (package-inputs (@ (my-packages) my-coreutils)))))
812
813;; (test-skip 100)
814
815(test-equal "remove-native-input, single input removed"
816 '()
817 (call-with-test-package '((native-inputs (list gmp)))
818 (lambda (directory)
819 (define file
820 (string-append directory "/my-packages.scm"))
821
822 (system* "guix" "style" "-L" directory
823 "-S" "remove-native-input" "--parameter=gmp"
824 "my-coreutils")
825
826 (load file)
827 (package-native-inputs (@ (my-packages) my-coreutils)))))
828
829(test-equal "remove-native-input, one of multiple inputs removed"
830 `(("acl" ,acl))
831 (call-with-test-package '((native-inputs (list gmp acl)))
832 (lambda (directory)
833 (define file
834 (string-append directory "/my-packages.scm"))
835
836 (system* "guix" "style" "-L" directory
837 "-S" "remove-native-input" "--parameter=gmp"
838 "my-coreutils")
839
840 (load file)
841 (package-native-inputs (@ (my-packages) my-coreutils)))))
842
843(test-equal "remove-native-input, does not affect inputs field"
844 `(("gmp" ,gmp))
845 (call-with-test-package '((inputs (list gmp))
846 (native-inputs (list acl)))
847 (lambda (directory)
848 (define file
849 (string-append directory "/my-packages.scm"))
850
851 (system* "guix" "style" "-L" directory
852 "-S" "remove-native-input" "--parameter=acl"
853 "my-coreutils")
854
855 (load file)
856 (package-inputs (@ (my-packages) my-coreutils)))))
857
858(test-equal "remove-propagated-input, single input removed"
859 '()
860 (call-with-test-package '((propagated-inputs (list gmp)))
861 (lambda (directory)
862 (define file
863 (string-append directory "/my-packages.scm"))
864
865 (system* "guix" "style" "-L" directory
866 "-S" "remove-propagated-input" "--parameter=gmp"
867 "my-coreutils")
868
869 (load file)
870 (package-propagated-inputs (@ (my-packages) my-coreutils)))))
871
872(test-equal "remove-propagated-input, one of multiple inputs removed"
873 `(("acl" ,acl))
874 (call-with-test-package '((propagated-inputs (list gmp acl)))
875 (lambda (directory)
876 (define file
877 (string-append directory "/my-packages.scm"))
878
879 (system* "guix" "style" "-L" directory
880 "-S" "remove-propagated-input" "--parameter=gmp"
881 "my-coreutils")
882
883 (load file)
884 (package-propagated-inputs (@ (my-packages) my-coreutils)))))
885
886(test-equal "remove-propagated-input, does not affect other fields"
887 (list `(("gmp" ,gmp)) `(("acl" ,acl)))
888 (call-with-test-package '((inputs (list gmp))
889 (native-inputs (list acl))
890 (propagated-inputs (list mpfr)))
891 (lambda (directory)
892 (define file
893 (string-append directory "/my-packages.scm"))
894
895 (system* "guix" "style" "-L" directory
896 "-S" "remove-propagated-input" "--parameter=mpfr"
897 "my-coreutils")
898
899 (load file)
900 (list (package-inputs (@ (my-packages) my-coreutils))
901 (package-native-inputs (@ (my-packages) my-coreutils))))))
902
903(test-equal "remove-input from all three fields independently"
904 (list '() '() '())
905 (call-with-test-package '((inputs (list gmp))
906 (native-inputs (list acl))
907 (propagated-inputs (list mpfr)))
908 (lambda (directory)
909 (define file
910 (string-append directory "/my-packages.scm"))
911
912 (system* "guix" "style" "-L" directory
913 "-S" "remove-input" "--parameter=gmp"
914 "my-coreutils")
915 (system* "guix" "style" "-L" directory
916 "-S" "remove-native-input" "--parameter=acl"
917 "my-coreutils")
918 (system* "guix" "style" "-L" directory
919 "-S" "remove-propagated-input" "--parameter=mpfr"
920 "my-coreutils")
921
922 (load file)
923 (list (package-inputs (@ (my-packages) my-coreutils))
924 (package-native-inputs (@ (my-packages) my-coreutils))
925 (package-propagated-inputs (@ (my-packages) my-coreutils))))))
926
927(test-assert "remove-input, dry-run does not modify file"
928 (call-with-test-package '((inputs (list gmp acl)))
929 (lambda (directory)
930 (define file
931 (string-append directory "/my-packages.scm"))
932 (define before-hash
933 (call-with-input-file file port-sha256))
934
935 (system* "guix" "style" "-L" directory "-n"
936 "-S" "remove-input" "--parameter=gmp"
937 "my-coreutils")
938
939 (equal? (call-with-input-file file port-sha256) before-hash))))
940
941(test-end)
942
943;; Local Variables:
944;; eval: (put 'with-test-package 'scheme-indent-function 1)
945;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
946;; End: