tests/build-utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
   4 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   5 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22
  23 (define-module (test build-utils)
  24   #:use-module (guix tests)
  25   #:use-module (guix build utils)
  26   #:use-module ((guix utils)
  27                 #:select (%current-system call-with-temporary-directory))
  28   #:use-module (gnu packages)
  29   #:use-module (gnu packages bootstrap)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-35)
  32   #:use-module (srfi srfi-64)
  33   #:use-module (rnrs io ports)
  34   #:use-module (ice-9 popen))
  35
  36 \f
  37 (test-begin "build-utils")
  38
  39 (test-equal "alist-cons-before"
  40   '((a . 1) (x . 42) (b . 2) (c . 3))
  41   (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  42
  43 (test-equal "alist-cons-before, reference not found"
  44   '((a . 1) (b . 2) (c . 3) (x . 42))
  45   (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  46
  47 (test-equal "alist-cons-after"
  48   '((a . 1) (b . 2) (x . 42) (c . 3))
  49   (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  50
  51 (test-equal "alist-cons-after, reference not found"
  52   '((a . 1) (b . 2) (c . 3) (x . 42))
  53   (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  54
  55 (test-equal "alist-replace"
  56   '((a . 1) (b . 77) (c . 3))
  57   (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
  58
  59 (test-assert "alist-replace, key not found"
  60   (not (false-if-exception
  61         (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
  62
  63 (test-equal "fold-port-matches"
  64   (make-list 3 "Guix")
  65   (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
  66     (lambda (port)
  67       (fold-port-matches cons '() "Guix" port))))
  68
  69 (test-equal "fold-port-matches, trickier"
  70   (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
  71   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  72     (lambda (port)
  73       (fold-port-matches cons '()
  74                          (list (char-set #\G #\g)
  75                                (char-set #\u)
  76                                (char-set #\i)
  77                                (char-set #\x #\X))
  78                          port))))
  79
  80 (test-equal "fold-port-matches, with unmatched chars"
  81   '("Guix" #\, #\space
  82     "guix" #\, #\space
  83     #\G #\u #\i "Guix" "guiX" #\, #\space
  84     "Guix")
  85   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  86     (lambda (port)
  87       (reverse
  88        (fold-port-matches cons '()
  89                           (list (char-set #\G #\g)
  90                                 (char-set #\u)
  91                                 (char-set #\i)
  92                                 (char-set #\x #\X))
  93                           port
  94                           cons)))))
  95
  96 (test-equal "wrap-program, one input, multiple calls"
  97   "hello world\n"
  98   (call-with-temporary-directory
  99    (lambda (directory)
 100      (let ((bash (search-bootstrap-binary "bash" (%current-system)))
 101            (foo  (string-append directory "/foo")))
 102
 103        (call-with-output-file foo
 104          (lambda (p)
 105            (format p
 106                    "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
 107                    bash)))
 108        (chmod foo #o777)
 109
 110        ;; wrap-program uses `which' to find bash for the wrapper shebang, but
 111        ;; it can't know about the bootstrap bash in the store, since it's not
 112        ;; named "bash".  Help it out a bit by providing a symlink it this
 113        ;; package's output.
 114        (with-environment-variable "PATH" (dirname bash)
 115          (wrap-program foo `("GUIX_FOO" prefix ("hello")))
 116          (wrap-program foo `("GUIX_BAR" prefix ("world")))
 117
 118          ;; The bootstrap Bash is linked against an old libc and would abort
 119          ;; with an assertion failure when trying to load incompatible locale
 120          ;; data.
 121          (unsetenv "LOCPATH")
 122
 123          (let* ((pipe (open-input-pipe foo))
 124                 (str  (get-string-all pipe)))
 125            (with-directory-excursion directory
 126              (for-each delete-file '("foo" ".foo-real")))
 127            (and (zero? (close-pipe pipe))
 128                 str)))))))
 129
 130 (test-assert "invoke/quiet, success"
 131   (begin
 132     (invoke/quiet "true")
 133     #t))
 134
 135 (test-assert "invoke/quiet, failure"
 136   (guard (c ((message-condition? c)
 137              (string-contains (condition-message c) "This is an error.")))
 138     (invoke/quiet "sh" "-c" "echo This is an error. ; false")
 139     #f))
 140
 141 (test-assert "invoke/quiet, failure, message on stderr"
 142   (guard (c ((message-condition? c)
 143              (string-contains (condition-message c)
 144                               "This is another error.")))
 145     (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
 146     #f))
 147
 148 (let ((script-contents "\
 149 #!/anything/cabbage-bash-1.2.3/bin/sh
 150
 151 echo hello world"))
 152
 153   (test-equal "wrap-script, simple case"
 154     (string-append
 155      (format #f "\
 156 #!~a --no-auto-compile
 157 #!#; Guix wrapper
 158 #\\-~s
 159 #\\-~s
 160 "
 161              (which "guile")
 162              '(begin (let ((current (getenv "GUIX_FOO")))
 163                        (setenv "GUIX_FOO"
 164                                (if current
 165                                    (string-append "/some/path:/some/other/path"
 166                                                   ":" current)
 167                                    "/some/path:/some/other/path"))))
 168              '(let ((cl (command-line)))
 169                 (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
 170                        (car cl)
 171                        (cons (car cl)
 172                              (append '("") cl)))))
 173      script-contents)
 174     (call-with-temporary-directory
 175      (lambda (directory)
 176        (let ((script-file-name (string-append directory "/foo")))
 177          (call-with-output-file script-file-name
 178            (lambda (port)
 179              (display script-contents port)))
 180          (chmod script-file-name #o777)
 181          (wrap-script script-file-name
 182                       `("GUIX_FOO" prefix ("/some/path"
 183                                            "/some/other/path")))
 184          (let ((str (call-with-input-file script-file-name get-string-all)))
 185            (with-directory-excursion directory
 186              (delete-file "foo"))
 187            str))))))
 188
 189 (let ((script-contents "\
 190 #!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
 191 # vim:fileencoding=utf-8
 192 print('hello world')"))
 193
 194   (test-equal "wrap-script, with encoding declaration"
 195     (string-append
 196      (format #f "\
 197 #!MYGUILE --no-auto-compile
 198 #!#; # vim:fileencoding=utf-8
 199 #\\-~s
 200 #\\-~s
 201 "
 202              '(begin (let ((current (getenv "GUIX_FOO")))
 203                        (setenv "GUIX_FOO"
 204                                (if current
 205                                    (string-append "/some/path:/some/other/path"
 206                                                   ":" current)
 207                                    "/some/path:/some/other/path"))))
 208              `(let ((cl (command-line)))
 209                 (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
 210                        (car cl)
 211                        (cons (car cl)
 212                              (append '("" "-and" "-args") cl)))))
 213      script-contents)
 214     (call-with-temporary-directory
 215      (lambda (directory)
 216        (let ((script-file-name (string-append directory "/foo")))
 217          (call-with-output-file script-file-name
 218            (lambda (port)
 219              (format port script-contents)))
 220          (chmod script-file-name #o777)
 221
 222          (wrap-script script-file-name
 223                       #:guile "MYGUILE"
 224                       `("GUIX_FOO" prefix ("/some/path"
 225                                            "/some/other/path")))
 226          (let ((str (call-with-input-file script-file-name get-string-all)))
 227            (with-directory-excursion directory
 228              (delete-file "foo"))
 229            str))))))
 230
 231 (test-assert "wrap-script, raises condition"
 232   (call-with-temporary-directory
 233    (lambda (directory)
 234      (let ((script-file-name (string-append directory "/foo")))
 235        (call-with-output-file script-file-name
 236          (lambda (port)
 237            (format port "This is not a script")))
 238        (chmod script-file-name #o777)
 239        (guard (c ((wrap-error? c) #t))
 240          (wrap-script script-file-name
 241                       #:guile "MYGUILE"
 242                       `("GUIX_FOO" prefix ("/some/path"
 243                                            "/some/other/path")))
 244          #f)))))
 245
 246 (test-equal "substitute*, text contains a NUL byte, UTF-8"
 247   "c\0d"
 248   (with-fluids ((%default-port-encoding "UTF-8")
 249                 (%default-port-conversion-strategy 'error))
 250     ;; The GNU libc is locale sensitive.  Depending on the value of LANG, the
 251     ;; test could fail with "string contains #\\nul character: ~S" or "cannot
 252     ;; convert wide string to output locale".
 253     (setlocale LC_ALL "en_US.UTF-8")
 254     (call-with-temporary-output-file
 255      (lambda (file port)
 256        (format port "a\0b")
 257        (flush-output-port port)
 258
 259        (substitute* file
 260          (("a") "c")
 261          (("b") "d"))
 262
 263        (with-input-from-file file
 264          (lambda _
 265            (get-string-all (current-input-port))))))))
 266
 267 (test-equal "search-input-file: exception if not found"
 268   `((path)
 269     (file . "does-not-exist"))
 270   (guard (e ((search-error? e)
 271              `((path . ,(search-error-path e))
 272                (file . ,(search-error-file e)))))
 273     (search-input-file '() "does-not-exist")))
 274
 275 (test-equal "search-input-file: can find if existent"
 276   (which "guile")
 277   (search-input-file
 278     `(("guile/bin" . ,(dirname (which "guile"))))
 279     "guile"))
 280
 281 (test-equal "search-input-file: can search in multiple directories"
 282   (which "guile")
 283   (call-with-temporary-directory
 284     (lambda (directory)
 285       (search-input-file
 286         `(("irrelevant" . ,directory)
 287           ("guile/bin" . ,(dirname (which "guile"))))
 288         "guile"))))
 289
 290
 291 (test-end)