tests/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   4 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (test-utils)
  22   #:use-module ((guix config) #:select (%gzip))
  23   #:use-module (guix utils)
  24   #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
  25   #:use-module ((guix search-paths) #:select (string-tokenize*))
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-11)
  28   #:use-module (srfi srfi-64)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (rnrs io ports)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 vlist))
  33
  34 (define temp-file
  35   (string-append "t-utils-" (number->string (getpid))))
  36
  37 (test-begin "utils")
  38
  39 (test-assert "gnu-triplet->nix-system"
  40   (let ((samples '(("i586-gnu0.3" "i686-gnu")
  41                    ("x86_64-unknown-linux-gnu" "x86_64-linux")
  42                    ("i386-pc-linux-gnu" "i686-linux")
  43                    ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
  44                    ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
  45                    ("i686-pc-cygwin" "i686-cygwin"))))
  46     (let-values (((gnu nix) (unzip2 samples)))
  47       (every (lambda (gnu nix)
  48                (equal? nix (gnu-triplet->nix-system gnu)))
  49              gnu nix))))
  50
  51 (test-assert "package-name->name+version"
  52   (every (match-lambda
  53           ((name version)
  54            (let*-values (((full-name)
  55                           (if version
  56                               (string-append name "@" version)
  57                               name))
  58                          ((name* version*)
  59                           (package-name->name+version full-name)))
  60              (and (equal? name* name)
  61                   (equal? version* version)))))
  62          '(("foo" "0.9.1b")
  63            ("foo-14-bar" "320")
  64            ("foo-bar2" #f)
  65            ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
  66            ("nixpkgs" "1.0pre22125_a28fe19")
  67            ("gtk2" "2.38.0"))))
  68
  69 (test-assert "guile-version>? 1.8"
  70   (guile-version>? "1.8"))
  71
  72 (test-assert "guile-version>? 10.5"
  73   (not (guile-version>? "10.5")))
  74
  75 (test-assert "version-prefix?"
  76   (and (version-prefix? "4.1" "4.1.2")
  77        (version-prefix? "4.1" "4.1")
  78        (not (version-prefix? "4.1" "4.16.2"))
  79        (not (version-prefix? "4.1" "4"))))
  80
  81 (test-equal "string-tokenize*"
  82   '(("foo")
  83     ("foo" "bar" "baz")
  84     ("foo" "bar" "")
  85     ("foo" "bar" "baz"))
  86   (list (string-tokenize* "foo" ":")
  87         (string-tokenize* "foo;bar;baz" ";")
  88         (string-tokenize* "foo!bar!" "!")
  89         (string-tokenize* "foo+-+bar+-+baz" "+-+")))
  90
  91 (test-equal "string-replace-substring"
  92   '("foo BAR! baz"
  93     "/gnu/store/chbouib"
  94     "")
  95   (list (string-replace-substring "foo bar baz" "bar" "BAR!")
  96         (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
  97         (string-replace-substring "" "foo" "bar")))
  98
  99 (test-equal "strip-keyword-arguments"
 100   '(a #:b b #:c c)
 101   (strip-keyword-arguments '(#:foo #:bar #:baz)
 102                            '(a #:foo 42 #:b b #:baz 3
 103                                #:c c #:bar 4)))
 104
 105 (test-equal "ensure-keyword-arguments"
 106   '((#:foo 2)
 107     (#:foo 2 #:bar 3)
 108     (#:foo 42 #:bar 3))
 109   (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
 110         (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
 111         (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
 112
 113 (test-equal "default-keyword-arguments"
 114   '((#:foo 2)
 115     (#:foo 2)
 116     (#:foo 2 #:bar 3)
 117     (#:foo 2 #:bar 3)
 118     (#:foo 2 #:bar 3))
 119   (list (default-keyword-arguments '() '(#:foo 2))
 120         (default-keyword-arguments '(#:foo 2) '(#:foo 4))
 121         (default-keyword-arguments '() '(#:bar 3 #:foo 2))
 122         (default-keyword-arguments '(#:bar 3) '(#:foo 2))
 123         (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
 124
 125 (test-equal "substitute-keyword-arguments"
 126   '((#:foo 3)
 127     (#:foo 3)
 128     (#:foo 3 #:bar (1 2))
 129     (#:bar (1 2) #:foo 3)
 130     (#:foo 3))
 131   (list (substitute-keyword-arguments '(#:foo 2)
 132           ((#:foo f) (1+ f)))
 133         (substitute-keyword-arguments '()
 134           ((#:foo f 2) (1+ f)))
 135         (substitute-keyword-arguments '(#:foo 2 #:bar (2))
 136           ((#:foo f) (1+ f))
 137           ((#:bar b) (cons 1 b)))
 138         (substitute-keyword-arguments '(#:foo 2)
 139           ((#:foo _) 3)
 140           ((#:bar b '(2)) (cons 1 b)))
 141         (substitute-keyword-arguments '(#:foo 2)
 142           ((#:foo f 1) (1+ f))
 143           ((#:bar b) (cons 42 b)))))
 144
 145 (test-assert "filtered-port, file"
 146   (let* ((file  (search-path %load-path "guix.scm"))
 147          (input (open-file file "r0b")))
 148     (let*-values (((compressed pids1)
 149                    (filtered-port `(,%gzip "-c" "--fast") input))
 150                   ((decompressed pids2)
 151                    (filtered-port `(,%gzip "-d") compressed)))
 152       (and (every (compose zero? cdr waitpid)
 153                   (append pids1 pids2))
 154            (equal? (get-bytevector-all decompressed)
 155                    (call-with-input-file file get-bytevector-all))))))
 156
 157 (test-assert "filtered-port, non-file"
 158   (let ((data (call-with-input-file (search-path %load-path "guix.scm")
 159                 get-bytevector-all)))
 160     (let*-values (((compressed pids1)
 161                    (filtered-port `(,%gzip "-c" "--fast")
 162                                   (open-bytevector-input-port data)))
 163                   ((decompressed pids2)
 164                    (filtered-port `(,%gzip "-d") compressed)))
 165       (and (pk (every (compose zero? cdr waitpid)
 166                    (append pids1 pids2)))
 167            (equal? (get-bytevector-all decompressed) data)))))
 168
 169 (test-assert "filtered-port, does not exist"
 170   (let* ((file  (search-path %load-path "guix.scm"))
 171          (input (open-file file "r0b")))
 172     (let-values (((port pids)
 173                   (filtered-port '("/does/not/exist") input)))
 174       (any (compose (negate zero?) cdr waitpid)
 175            pids))))
 176
 177 (define (test-compression/decompression method run?)
 178   "Test METHOD, a symbol such as 'gzip.  Call RUN? to determine whether to
 179 skip these tests."
 180   (unless (run?) (test-skip 1))
 181   (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]"
 182                        method)
 183     (let ((data (call-with-input-file (search-path %load-path "guix.scm")
 184                   get-bytevector-all)))
 185       (let*-values (((compressed pids1)
 186                      (compressed-port method (open-bytevector-input-port data)))
 187                     ((decompressed pids2)
 188                      (decompressed-port method compressed)))
 189         (and (every (compose zero? cdr waitpid)
 190                     (pk 'pids method (append pids1 pids2)))
 191              (let ((result (get-bytevector-all decompressed)))
 192                (pk 'len method
 193                    (if (bytevector? result)
 194                        (bytevector-length result)
 195                        result)
 196                    (bytevector-length data))
 197                (equal? result data))))))
 198
 199   (false-if-exception (delete-file temp-file))
 200   (unless (run?) (test-skip 1))
 201   (test-assert (format #f "compressed-output-port + decompressed-port [~a]"
 202                        method)
 203     (let* ((file (search-path %load-path "guix/derivations.scm"))
 204            (data (call-with-input-file file get-bytevector-all))
 205            (port (open-file temp-file "w0b")))
 206       (call-with-compressed-output-port method port
 207         (lambda (compressed)
 208           (put-bytevector compressed data)))
 209       (close-port port)
 210
 211       (bytevector=? data
 212                     (call-with-decompressed-port method (open-file temp-file "r0b")
 213                       get-bytevector-all)))))
 214
 215 (for-each test-compression/decompression
 216           '(gzip xz lzip)
 217           (list (const #t) (const #t) (const #t)))
 218
 219 ;; This is actually in (guix store).
 220 (test-equal "store-path-package-name"
 221   "bash-4.2-p24"
 222   (store-path-package-name
 223    (string-append (%store-prefix)
 224                   "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
 225
 226 (test-equal "canonical-newline-port"
 227   "This is a journey\nInto the sound\nA journey ...\n"
 228   (let ((port (open-string-input-port
 229                "This is a journey\r\nInto the sound\r\nA journey ...\n")))
 230     (get-string-all (canonical-newline-port port))))
 231
 232 (test-equal "canonical-newline-port-1024"
 233   (string-concatenate (make-list 100 "0123456789abcde\n"))
 234   (let ((port (open-string-input-port
 235                (string-concatenate
 236                 (make-list 100 "0123456789abcde\r\n")))))
 237     (get-string-all (canonical-newline-port port))))
 238
 239 (test-equal "edit-expression"
 240   "(display \"GNU Guix\")\n(newline)\n"
 241   (begin
 242     (call-with-output-file temp-file
 243       (lambda (port)
 244         (display "(display \"xiuG UNG\")\n(newline)\n" port)))
 245     (edit-expression `((filename . ,temp-file)
 246                        (line     . 0)
 247                        (column   . 9))
 248                      string-reverse)
 249     (call-with-input-file temp-file get-string-all)))
 250
 251 (test-end)
 252
 253 (false-if-exception (delete-file temp-file))