;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (test-packages) #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) #:use-module ((guix gexp) #:select (local-file local-file-file)) #:u
aboutsummaryrefslogtreecommitdiff
blob: c0b5780c30b34c7f9027980f8a5ce7f534840982 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages lirc)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system python)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (gnu packages)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages libusb)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages xml)
  #:use-module (gnu packages xorg)
  #:use-module (gnu packages python)
  #:use-module (gnu packages python-xyz))

(define-public lirc
  (package
    (name "lirc")
    (version "0.10.2")
    (source (origin
              (method url-fetch)
              (uri (string-append "mirror://sourceforge/lirc/LIRC/" version
                                  "/lirc-" version ".tar.bz2"))
              (sha256
               (base32
                "0ai27l6hxfgkwvkqa3fy1b1gqzw2y10md030y5ig4748fj1fqi1x"))
              (patches (search-patches "lirc-localstatedir.patch"
                                       "lirc-reproducible-build.patch"))))
    (build-system gnu-build-system)
    (arguments
     '(#:configure-flags
       '("--localstatedir=/var"
         ;; "configure" script fails to enable "devinput" driver as it
         ;; checks for "/dev/input" directory (which is not available),
         ;; so enable it explicitly.
         "--enable-devinput")
       #:phases
       (modify-phases %standard-phases
         (add-after 'unpack 'disable-kernel-sniffing
           (lambda _
             ;; Correct the faulty assumption that systemd support should be
             ;; hard-wired when a build host's /proc/version contains "Ubuntu".
             (substitute* "configure"
               (("kernelversion=.*") "kernelversion=irrelevant\n"))))
         (add-after 'unpack 'patch-lirc-make-devinput
           (lambda* (#:key inputs #:allow-other-keys)
             ;; 'lirc-make-devinput' script assumes that linux headers
             ;; are placed in "/usr/...".
             (let ((headers (assoc-ref inputs "kernel-headers")))
               (substitute* "tools/lirc-make-devinput"
                 (("/usr/include") (string-append headers "/include"))))))
         (add-after 'unpack 'patch-doc/Makefile.in
           (lambda _
             ;; Lirc wants to install several images and a useless html page
             ;; to "$(localstatedir)/lib/lirc/".  This makes 'install' phase
             ;; fail as localstatedir is "/var", so do not install these
             ;; files there (the same images are installed in
             ;; "share/doc/lirc/images/" anyway).
             (substitute* "doc/Makefile.in"
               (("^vardocs_DATA =.*") "vardocs_DATA =\n")
               (("^varimage_DATA =.*") "varimage_DATA =\n"))))
         (add-after 'unpack 'omit-pip-sourceball
           ;; ‘make install’ invokes ’setup.py sdist’, which has no known (to
           ;; nckx) way to enforce mtimes.  The utility of this is questionable,
           ;; IMO: let's disable it entirely & listen for complaints, if any.
           (lambda _
             (substitute* "Makefile.in"
               (("(PYTHON_TARBALL.*=).*" _ tarball=)
                (string-append tarball= "\n")))))
         (add-before 'configure 'build-reproducibly
           (lambda _
             (setenv "LIRC_IRDB_CACHE_ID" "build time"))))))
    (native-inputs
     (list pkg-config libxslt))
    (inputs
     `(("libx11" ,libx11)
       ("libusb-compat" ,libusb-compat)
       ("alsa-lib" ,alsa-lib)
       ("python" ,python)))
    (home-page "https://www.lirc.org/")
    (synopsis "Linux Infrared Remote Control")
    (description
     "LIRC allows computers to send and receive IR signals of many commonly
used remote controls.  The most important part of LIRC is the @code{lircd}
daemon that decodes IR signals received by the device drivers.  The second
daemon program @code{lircmd} translates IR signals to mouse movements.
The user space applications allow you to control your computer with a remote
control: you can send X events to applications, start programs and much more
on just one button press.")
    (license license:gpl2+)))

(define-public python-lirc
  (let ((commit "c28708bbeb6e02d85f13dd7e0b24e8e86abc215b")
        (revision "2"))
    (package
      (name "python-lirc")
      (version (git-version "1.2.1" revision commit))
      (source
       (origin
         (method git-fetch)
         (uri (git-reference
               (url "https://github.com/tompreston/python-lirc")
               (commit commit)))
         (file-name (git-file-name name version))
         (sha256
          (base32
           "13s9zqyfh871ls1aha47rhmk13b4mcyfckcn2sw70bvc26832gk6"))))
      (build-system python-build-system)
      (inputs
       (list lirc))
      (native-inputs
       (list python-cython))
      (arguments
       `(#:tests? #f         ; the only tests that exist are interactive
         #:phases
         (modify-phases %standard-phases
           (add-before 'build 'build-from-cython-files
             (lambda _ (invoke "make" "py3"))))))
      (home-page "https://github.com/tompreston/python-lirc")
      (synopsis "Python bindings for LIRC")
      (description "@code{lirc} is a Python module which provides LIRC bindings.")
      (license license:gpl3))))
tore source) (equal? (call-with-input-file source get-bytevector-all) (call-with-input-file file get-bytevector-all))))) (test-assert "package-source-derivation, store path" (let* ((file (add-to-store %store "guix.scm" #t "sha256" (search-path %load-path "guix.scm"))) (package (package (inherit (dummy-package "p")) (source file))) (source (package-source-derivation %store (package-source package)))) (string=? file source))) (test-assert "package-source-derivation, indirect store path" (let* ((dir (add-to-store %store "guix-build" #t "sha256" (dirname (search-path %load-path "guix/build/utils.scm")))) (package (package (inherit (dummy-package "p")) (source (string-append dir "/utils.scm")))) (source (package-source-derivation %store (package-source package)))) (and (direct-store-path? source) (string-suffix? "utils.scm" source)))) (test-assert "package-source-derivation, local-file" (let* ((file (local-file "../guix/base32.scm")) (package (package (inherit (dummy-package "p")) (source file))) (source (package-source-derivation %store (package-source package)))) (and (store-path? source) (string-suffix? "base32.scm" source) (valid-path? %store source) (equal? (call-with-input-file source get-bytevector-all) (call-with-input-file (search-path %load-path "guix/base32.scm") get-bytevector-all))))) (unless (network-reachable?) (test-skip 1)) (test-equal "package-source-derivation, snippet" "OK" (let* ((source (bootstrap-origin (origin (inherit (bootstrap-guile-origin (%current-system))) (patch-inputs `(("tar" ,%bootstrap-coreutils&co) ("xz" ,%bootstrap-coreutils&co) ("patch" ,%bootstrap-coreutils&co))) (patch-guile %bootstrap-guile) (modules '((guix build utils))) (snippet '(begin ;; We end up in 'bin', because it's the first ;; directory, alphabetically. Not a very good ;; example but hey. (chmod "." #o777) (symlink "guile" "guile-rocks") (copy-recursively "../share/guile/2.0/scripts" "scripts") ;; Make sure '.file_list' can be created. (chmod ".." #o777)))))) (package (package (inherit (dummy-package "with-snippet")) (source source) (build-system trivial-build-system) (inputs `(("tar" ,(search-bootstrap-binary "tar" (%current-system))) ("xz" ,(search-bootstrap-binary "xz" (%current-system))))) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((tar (assoc-ref %build-inputs "tar")) (xz (assoc-ref %build-inputs "xz")) (source (assoc-ref %build-inputs "source"))) (and (zero? (system* tar "xvf" source "--use-compress-program" xz)) (string=? "guile" (readlink "bin/guile-rocks")) (file-exists? "bin/scripts/compile.scm") (let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (p) (display "OK" p)))))))))) (drv (package-derivation %store package)) (out (derivation->output-path drv))) (and (build-derivations %store (list (pk 'snippet-drv drv))) (call-with-input-file out get-string-all)))) (test-assert "return value" (let ((drv (package-derivation %store (dummy-package "p")))) (and (derivation? drv) (file-exists? (derivation-file-name drv))))) (test-assert "package-output" (let* ((package (dummy-package "p")) (drv (package-derivation %store package))) (and (derivation? drv) (string=? (derivation->output-path drv) (package-output %store package "out"))))) (test-assert "patch not found yields a run-time error" (guard (c ((condition-has-type? c &message) (and (string-contains (condition-message c) "does-not-exist.patch") (string-contains (condition-message c) "not found")))) (let ((p (package (inherit (dummy-package "p")) (source (origin (method (const #f)) (uri "http://whatever") (patches (list (search-patch "does-not-exist.patch"))) (sha256 (base32 "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4"))))))) (package-derivation %store p) #f))) (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module))))))) (test-equal "&package-input-error" (list dummy (current-module)) (guard (c ((package-input-error? c) (list (package-error-package c) (package-error-invalid-input c)))) (package-derivation %store dummy)))) (test-assert "reference to non-existent output" ;; See . (parameterize ((%graft? #f)) (let* ((dep (dummy-package "dep")) (p (dummy-package "p" (inputs `(("dep" ,dep "non-existent")))))) (guard (c ((derivation-missing-output-error? c) (and (string=? (derivation-missing-output c) "non-existent") (equal? (package-derivation %store dep) (derivation-error-derivation c))))) (package-derivation %store p))))) (test-assert "trivial" (let* ((p (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #:builder (begin (mkdir %output) (call-with-output-file (string-append %output "/test") (lambda (p) (display '(hello guix) p)))))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) (let ((p (pk 'drv d (derivation->output-path d)))) (equal? '(hello guix) (call-with-input-file (string-append p "/test") read)))))) (test-assert "trivial with local file as input" (let* ((i (search-path %load-path "ice-9/boot-9.scm")) (p (package (inherit (dummy-package "trivial-with-input-file")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #:builder (copy-file (assoc-ref %build-inputs "input") %output))) (inputs `(("input" ,i))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) (let ((p (pk 'drv d (derivation->output-path d)))) (equal? (call-with-input-file p get-bytevector-all) (call-with-input-file i get-bytevector-all)))))) (test-assert "trivial with source" (let* ((i (search-path %load-path "ice-9/boot-9.scm")) (p (package (inherit (dummy-package "trivial-with-source")) (build-system trivial-build-system) (source i) (arguments `(#:guile ,%bootstrap-guile #:builder (copy-file (assoc-ref %build-inputs "source") %output))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) (let ((p (derivation->output-path d))) (equal? (call-with-input-file p get-bytevector-all) (call-with-input-file i get-bytevector-all)))))) (test-assert "trivial with system-dependent input" (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out")) (bash (assoc-ref %build-inputs "bash"))) (zero? (system* bash "-c" (format #f "echo hello > ~a" out)))))) (inputs `(("bash" ,(search-bootstrap-binary "bash" (%current-system))))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) (let ((p (pk 'drv d (derivation->output-path d)))) (eq? 'hello (call-with-input-file p read)))))) (test-assert "trivial with #:allowed-references" (let* ((p (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:allowed-references (,%bootstrap-guile) #:builder (begin (mkdir %output) ;; The reference to itself isn't allowed so building it ;; should fail. (symlink %output (string-append %output "/self"))))))) (d (package-derivation %store p))) (guard (c ((nix-protocol-error? c) #t)) (build-derivations %store (list d)) #f))) (test-assert "search paths" (let* ((p (make-prompt-tag "return-search-paths")) (s (build-system (name 'raw) (description "Raw build system with direct store access") (lower (lambda* (name #:key source inputs system target #:allow-other-keys) (bag (name name) (system system) (target target) (build-inputs inputs) (build (lambda* (store name inputs #:key outputs system search-paths) search-paths))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (files '("share/guile/site/2.0"))) (search-path-specification (variable "GUILE_LOAD_COMPILED_PATH") (files '("share/guile/site/2.0"))))) (a (package (inherit (dummy-package "guile")) (build-system s) (native-search-paths x))) (b (package (inherit (dummy-package "guile-foo")) (build-system s) (inputs `(("guile" ,a))))) (c (package (inherit (dummy-package "guile-bar")) (build-system s) (inputs `(("guile" ,a) ("guile-foo" ,b)))))) (let-syntax ((collect (syntax-rules () ((_ body ...) (call-with-prompt p (lambda () body ...) (lambda (k search-paths) search-paths)))))) (and (null? (collect (package-derivation %store a))) (equal? x (collect (package-derivation %store b))) (equal? x (collect (package-derivation %store c))))))) (test-assert "package-transitive-native-search-paths" (let* ((sp (lambda (name) (list (search-path-specification (variable name) (files '("foo/bar")))))) (p0 (dummy-package "p0" (native-search-paths (sp "PATH0")))) (p1 (dummy-package "p1" (native-search-paths (sp "PATH1")))) (p2 (dummy-package "p2" (native-search-paths (sp "PATH2")) (inputs `(("p0" ,p0))) (propagated-inputs `(("p1" ,p1))))) (p3 (dummy-package "p3" (native-search-paths (sp "PATH3")) (native-inputs `(("p0" ,p0))) (propagated-inputs `(("p2" ,p2)))))) (lset= string=? '("PATH1" "PATH2" "PATH3") (map search-path-specification-variable (package-transitive-native-search-paths p3))))) (test-assert "package-cross-derivation" (let ((drv (package-cross-derivation %store (dummy-package "p") "mips64el-linux-gnu"))) (and (derivation? drv) (file-exists? (derivation-file-name drv))))) (test-assert "package-cross-derivation, trivial-build-system" (let ((p (package (inherit (dummy-package "p")) (build-system trivial-build-system) (arguments '(#:builder (exit 1)))))) (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu"))) (derivation? drv)))) (test-assert "package-cross-derivation, no cross builder" (let* ((b (build-system (inherit trivial-build-system) (lower (const #f)))) (p (package (inherit (dummy-package "p")) (build-system b)))) (guard (c ((package-cross-build-system-error? c) (eq? (package-error-package c) p))) (package-cross-derivation %store p "mips64el-linux-gnu") #f))) ;; XXX: The next two tests can trigger builds when the distro defines ;; replacements on core packages, so they're disable for lack of a better ;; solution. ;; (test-equal "package-derivation, direct graft" ;; (package-derivation %store gnu-make #:graft? #f) ;; (let ((p (package (inherit coreutils) ;; (replacement gnu-make)))) ;; (package-derivation %store p #:graft? #t))) ;; (test-equal "package-cross-derivation, direct graft" ;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu" ;; #:graft? #f) ;; (let ((p (package (inherit coreutils) ;; (replacement gnu-make)))) ;; (package-cross-derivation %store p "mips64el-linux-gnu" ;; #:graft? #t))) (test-assert "package-grafts, indirect grafts" (let* ((new (dummy-package "dep" (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) (inputs `(("dep" ,dep*)))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) ;; XXX: This test would require building the cross toolchain just to see if it ;; needs grafting, which is obviously too expensive, and thus disabled. ;; ;; (test-assert "package-grafts, indirect grafts, cross" ;; (let* ((new (dummy-package "dep" ;; (arguments '(#:implicit-inputs? #f)))) ;; (dep (package (inherit new) (version "0.0"))) ;; (dep* (package (inherit dep) (replacement new))) ;; (dummy (dummy-package "dummy" ;; (arguments '(#:implicit-inputs? #f)) ;; (inputs `(("dep" ,dep*))))) ;; (target "mips64el-linux-gnu")) ;; ;; XXX: There might be additional grafts, for instance if the distro ;; ;; defines replacements for core packages like Perl. ;; (member (graft ;; (origin (package-cross-derivation %store dep target)) ;; (replacement ;; (package-cross-derivation %store new target))) ;; (package-grafts %store dummy #:target target)))) (test-assert "package-grafts, indirect grafts, propagated inputs" (let* ((new (dummy-package "dep" (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (prop (dummy-package "propagated" (propagated-inputs `(("dep" ,dep*))) (arguments '(#:implicit-inputs? #f)))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) (inputs `(("prop" ,prop)))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) (test-assert "package-grafts, same replacement twice" (let* ((new (dummy-package "dep" (version "1") (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0") (replacement new))) (p1 (dummy-package "intermediate1" (arguments '(#:implicit-inputs? #f)) (inputs `(("dep" ,dep))))) (p2 (dummy-package "intermediate2" (arguments '(#:implicit-inputs? #f)) ;; Here we copy DEP to have an equivalent package that is not ;; 'eq?' to DEP. This is similar to what happens with ;; 'package-with-explicit-inputs' & co. (inputs `(("dep" ,(package (inherit dep))))))) (p3 (dummy-package "final" (arguments '(#:implicit-inputs? #f)) (inputs `(("p1" ,p1) ("p2" ,p2)))))) (equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store (package (inherit dep) (replacement #f)))) (replacement (package-derivation %store new))))))) (test-assert "replacement also grafted" ;; We build a DAG as below, where dotted arrows represent replacements and ;; solid arrows represent dependencies: ;; ;; P1 ·············> P1R ;; |\__________________. ;; v v ;; P2 ·············> P2R ;; | ;; v ;; P3 ;; ;; We want to make sure that: ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R))) ;; where: ;; (A,B) is a graft to replace A by B ;; grafted(DRV,G) denoted DRV with graft G applied (let* ((p1r (dummy-package "P1" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (call-with-output-file (string-append out "/replacement") (const #t))))))) (p1 (package (inherit p1r) (name "p1") (replacement p1r) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))))) (p2r (dummy-package "P2" (build-system trivial-build-system) (inputs `(("p1" ,p1))) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") "p1") (call-with-output-file (string-append out "/replacement") (const #t))))))) (p2 (package (inherit p2r) (name "p2") (replacement p2r) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") "p1")))))) (p3 (dummy-package "p3" (build-system trivial-build-system) (inputs `(("p2" ,p2))) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p2") "p2"))))))) (lset= equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store p1 #:graft? #f)) (replacement (package-derivation %store p1r))) (graft (origin (package-derivation %store p2 #:graft? #f)) (replacement (package-derivation %store p2r #:graft? #t))))))) ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to ;;; find out about their run-time dependencies, so this test is no longer ;;; applicable since it would trigger a full rebuild. ;; ;; (test-assert "package-derivation, indirect grafts" ;; (let* ((new (dummy-package "dep" ;; (arguments '(#:implicit-inputs? #f)))) ;; (dep (package (inherit new) (version "0.0"))) ;; (dep* (package (inherit dep) (replacement new))) ;; (dummy (dummy-package "dummy" ;; (arguments '(#:implicit-inputs? #f)) ;; (inputs `(("dep" ,dep*))))) ;; (guile (package-derivation %store (canonical-package guile-2.0) ;; #:graft? #f))) ;; (equal? (package-derivation %store dummy) ;; (graft-derivation %store ;; (package-derivation %store dummy #:graft? #f) ;; (package-grafts %store dummy) ;; ;; Use the same Guile as 'package-derivation'. ;; #:guile guile)))) (test-equal "package->bag" `("foo86-hurd" #f (,(package-source gnu-make)) (,(canonical-package glibc)) (,(canonical-package coreutils))) (let ((bag (package->bag gnu-make "foo86-hurd"))) (list (bag-system bag) (bag-target bag) (assoc-ref (bag-build-inputs bag) "source") (assoc-ref (bag-build-inputs bag) "libc") (assoc-ref (bag-build-inputs bag) "coreutils")))) (test-equal "package->bag, cross-compilation" `(,(%current-system) "foo86-hurd" (,(package-source gnu-make)) (,(canonical-package glibc)) (,(canonical-package coreutils))) (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd"))) (list (bag-system bag) (bag-target bag) (assoc-ref (bag-build-inputs bag) "source") (assoc-ref (bag-build-inputs bag) "libc") (assoc-ref (bag-build-inputs bag) "coreutils")))) (test-assert "package->bag, propagated inputs" (let* ((dep (dummy-package "dep")) (prop (dummy-package "prop" (propagated-inputs `(("dep" ,dep))))) (dummy (dummy-package "dummy" (inputs `(("prop" ,prop))))) (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f)))) (match (assoc "dep" inputs) (("dep" package) (eq? package dep))))) (test-assert "bag->derivation" (parameterize ((%graft? #f)) (let ((bag (package->bag gnu-make)) (drv (package-derivation %store gnu-make))) (parameterize ((%current-system "foox86-hurd")) ;should have no effect (equal? drv (bag->derivation %store bag)))))) (test-assert "bag->derivation, cross-compilation" (parameterize ((%graft? #f)) (let* ((target "mips64el-linux-gnu") (bag (package->bag gnu-make (%current-system) target)) (drv (package-cross-derivation %store gnu-make target))) (parameterize ((%current-system "foox86-hurd") ;should have no effect (%current-target-system "foo64-linux-gnu")) (equal? drv (bag->derivation %store bag)))))) (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) (test-assert "GNU Make, bootstrap" ;; GNU Make is the first program built during bootstrap; we choose it ;; here so that the test doesn't last for too long. (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0))) (and (package? gnu-make) (or (location? (package-location gnu-make)) (not (package-location gnu-make))) (let* ((drv (package-derivation %store gnu-make)) (out (derivation->output-path drv))) (and (build-derivations %store (list drv)) (file-exists? (string-append out "/bin/make"))))))) (test-equal "package-mapping" 42 (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) (p0 (dummy-package "example" (inputs `(("foo" ,coreutils) ("bar" ,grep) ("baz" ,dep))))) (transform (lambda (p) (package (inherit p) (source 42)))) (rewrite (package-mapping transform)) (p1 (rewrite p0))) (and (eq? p1 (rewrite p0)) (eqv? 42 (package-source p1)) (match (package-inputs p1) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) (and (eq? dep1 (rewrite coreutils)) ;memoization (eq? dep2 (rewrite grep)) (eq? dep3 (rewrite dep)) (eqv? 42 (package-source dep1) (package-source dep2) (package-source dep3)) (match (package-native-inputs dep3) ((("x" dep)) (and (eq? dep (rewrite grep)) (package-source dep)))))))))) (test-assert "package-input-rewriting" (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) (p0 (dummy-package "example" (inputs `(("foo" ,coreutils) ("bar" ,grep) ("baz" ,dep))))) (rewrite (package-input-rewriting `((,coreutils . ,sed) (,grep . ,findutils)) (cut string-append "r-" <>))) (p1 (rewrite p0)) (p2 (rewrite p0))) (and (not (eq? p1 p0)) (eq? p1 p2) ;memoization (string=? "r-example" (package-name p1)) (match (package-inputs p1) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) (and (eq? dep1 sed) (eq? dep2 findutils) (string=? (package-name dep3) "r-chbouib") (eq? dep3 (rewrite dep)) ;memoization (match (package-native-inputs dep3) ((("x" dep)) (eq? dep findutils))))))))) (test-eq "fold-packages" hello (fold-packages (lambda (p r) (if (string=? (package-name p) "hello") p r)) #f)) (test-assert "fold-packages, hidden package" ;; There are two public variables providing "guile@2.0" ('guile-final' in ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter ;; should show up. (match (fold-packages (lambda (p r) (if (and (string=? (package-name p) "guile") (string-prefix? "2.0" (package-version p))) (cons p r) r)) '()) ((one) (eq? one guile-2.0)))) (test-assert "find-packages-by-name" (match (find-packages-by-name "hello") (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) (test-assert "find-packages-by-name with version" (match (find-packages-by-name "hello" (package-version hello)) (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) (test-assert "--search-paths with pattern" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables when file patterns are used (in particular, it must follow ;; symlinks when looking for 'catalog.xml'.) To do that, we rely on the ;; libxml2 package specification, which contains such a definition. (let* ((p1 (package (name "foo") (version "0") (source #f) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:modules ((guix build utils)) #:builder (begin (use-modules (guix build utils)) (let ((out (assoc-ref %outputs "out"))) (mkdir-p (string-append out "/xml/bar/baz")) (call-with-output-file (string-append out "/xml/bar/baz/catalog.xml") (lambda (port) (display "xml? wat?!" port))))))) (synopsis #f) (description #f) (home-page #f) (license #f))) (p2 (package ;; Provide a fake libxml2 to avoid building the real one. This ;; is OK because 'guix package' gets search path specifications ;; from the same-named package found in the distro. (name "libxml2") (version "0.0.0") (source #f) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))) (native-search-paths (package-native-search-paths libxml2)) (synopsis #f) (description #f) (home-page #f) (license #f))) (prof (run-with-store %store (profile-derivation (manifest (map package->manifest-entry (list p1 p2))) #:hooks '() #:locales? #f) #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof)) (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n" (regexp-quote (derivation->output-path prof))) (with-output-to-string (lambda () (guix-package "-p" (derivation->output-path prof) "--search-paths")))))) (test-assert "--search-paths with single-item search path" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their ;; separator, meaning that the first match wins. (let* ((p1 (dummy-package "foo" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:modules ((guix build utils)) #:builder (begin (use-modules (guix build utils)) (let ((out (assoc-ref %outputs "out"))) (mkdir-p (string-append out "/etc/ssl/certs")) (call-with-output-file (string-append out "/etc/ssl/certs/ca-certificates.crt") (const #t)))))))) (p2 (package (inherit p1) (name "bar"))) (p3 (dummy-package "git" ;; Provide a fake Git to avoid building the real one. (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))) (native-search-paths (package-native-search-paths git)))) (prof1 (run-with-store %store (profile-derivation (packages->manifest (list p1 p3)) #:hooks '() #:locales? #f) #:guile-for-build (%guile-for-build))) (prof2 (run-with-store %store (profile-derivation (packages->manifest (list p2 p3)) #:hooks '() #:locales? #f) #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof1 prof2)) (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt" (regexp-quote (derivation->output-path prof1))) (with-output-to-string (lambda () (guix-package "-p" (derivation->output-path prof1) "-p" (derivation->output-path prof2) "--search-paths")))))) (test-equal "specification->package when not found" 'quit (catch 'quit (lambda () ;; This should call 'leave', producing an error message. (specification->package "this-package-does-not-exist")) (lambda (key . args) key))) (test-end "packages") ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) ;;; End: