tests/build-utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2015 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
  20 (define-module (test-build-utils)
  21   #:use-module (guix tests)
  22   #:use-module (guix store)
  23   #:use-module (guix derivations)
  24   #:use-module (guix build utils)
  25   #:use-module (guix packages)
  26   #:use-module (guix build-system)
  27   #:use-module (guix build-system trivial)
  28   #:use-module (gnu packages)
  29   #:use-module (gnu packages bootstrap)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-64)
  32   #:use-module (rnrs io ports)
  33   #:use-module (ice-9 popen))
  34
  35 (define %store
  36   (open-connection-for-tests))
  37
  38 \f
  39 (test-begin "build-utils")
  40
  41 (test-equal "alist-cons-before"
  42   '((a . 1) (x . 42) (b . 2) (c . 3))
  43   (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  44
  45 (test-equal "alist-cons-before, reference not found"
  46   '((a . 1) (b . 2) (c . 3) (x . 42))
  47   (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  48
  49 (test-equal "alist-cons-after"
  50   '((a . 1) (b . 2) (x . 42) (c . 3))
  51   (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  52
  53 (test-equal "alist-cons-after, reference not found"
  54   '((a . 1) (b . 2) (c . 3) (x . 42))
  55   (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  56
  57 (test-equal "alist-replace"
  58   '((a . 1) (b . 77) (c . 3))
  59   (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
  60
  61 (test-assert "alist-replace, key not found"
  62   (not (false-if-exception
  63         (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
  64
  65 (test-equal "fold-port-matches"
  66   (make-list 3 "Guix")
  67   (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
  68     (lambda (port)
  69       (fold-port-matches cons '() "Guix" port))))
  70
  71 (test-equal "fold-port-matches, trickier"
  72   (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
  73   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  74     (lambda (port)
  75       (fold-port-matches cons '()
  76                          (list (char-set #\G #\g)
  77                                (char-set #\u)
  78                                (char-set #\i)
  79                                (char-set #\x #\X))
  80                          port))))
  81
  82 (test-equal "fold-port-matches, with unmatched chars"
  83   '("Guix" #\, #\space
  84     "guix" #\, #\space
  85     #\G #\u #\i "Guix" "guiX" #\, #\space
  86     "Guix")
  87   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  88     (lambda (port)
  89       (reverse
  90        (fold-port-matches cons '()
  91                           (list (char-set #\G #\g)
  92                                 (char-set #\u)
  93                                 (char-set #\i)
  94                                 (char-set #\x #\X))
  95                           port
  96                           cons)))))
  97
  98 (test-assert "wrap-program, one input, multiple calls"
  99   (let* ((p (package
 100               (name "test-wrap-program") (version "0") (source #f)
 101               (synopsis #f) (description #f) (license #f) (home-page #f)
 102               (build-system trivial-build-system)
 103               (arguments
 104                `(#:guile ,%bootstrap-guile
 105                  #:modules ((guix build utils))
 106                  #:builder
 107                  (let* ((out  (assoc-ref %outputs "out"))
 108                         (bash (assoc-ref %build-inputs "bash"))
 109                         (foo  (string-append out "/foo")))
 110                    (begin
 111                      (use-modules (guix build utils))
 112                      (mkdir out)
 113                      (call-with-output-file foo
 114                        (lambda (p)
 115                          (format p
 116                                  "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
 117                                  bash)))
 118                      (chmod foo #o777)
 119                      ;; wrap-program uses `which' to find bash for the wrapper
 120                      ;; shebang, but it can't know about the bootstrap bash in
 121                      ;; the store, since it's not named "bash".  Help it out a
 122                      ;; bit by providing a symlink it this package's output.
 123                      (symlink bash (string-append out "/bash"))
 124                      (setenv "PATH" out)
 125                      (wrap-program foo `("GUIX_FOO" prefix ("hello")))
 126                      (wrap-program foo `("GUIX_BAR" prefix ("world")))
 127                      #t))))
 128               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 129                                                           (%current-system)))))))
 130          (d (package-derivation %store p)))
 131
 132     ;; The bootstrap Bash is linked against an old libc and would abort with
 133     ;; an assertion failure when trying to load incompatible locale data.
 134     (unsetenv "LOCPATH")
 135
 136     (and (build-derivations %store (pk 'drv d (list d)))
 137          (let* ((p    (derivation->output-path d))
 138                 (foo  (string-append p "/foo"))
 139                 (pipe (open-input-pipe foo))
 140                 (str  (get-string-all pipe)))
 141            (equal? str "hello world\n")))))
 142
 143 (test-end)
 144
 145 \f
 146 (exit (= (test-runner-fail-count (test-runner-current)) 0))