X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/ddc29a782eac30fcf4ff1f07677aa2896dc140e4..f072e9adf58bf751528fc7122bdc71ba8c81e0e7:/tests/utils.scm

diff --git a/tests/utils.scm b/tests/utils.scm
index 0a6e8a0833..a05faabc15 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,29 +1,37 @@
-;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
-;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
-;;; This file is part of Guix.
+;;; This file is part of GNU Guix.
 ;;;
-;;; Guix is free software; you can redistribute it and/or modify it
+;;; 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.
 ;;;
-;;; Guix is distributed in the hope that it will be useful, but
+;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-utils)
+  #:use-module ((guix config) #:select (%gzip))
   #:use-module (guix utils)
-  #:use-module ((guix store) #:select (store-path-package-name))
+  #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
+  #:use-module ((guix search-paths) #:select (string-tokenize*))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
-  #:use-module (ice-9 match))
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist))
+
+(define temp-file
+  (string-append "t-utils-" (number->string (getpid))))
 
 (test-begin "utils")
 
@@ -64,76 +72,269 @@
            ("nixpkgs" "1.0pre22125_a28fe19")
            ("gtk2" "2.38.0"))))
 
-(test-assert "define-record-type*"
-  (begin
-    (define-record-type* <foo> foo make-foo
-      foo?
-      (bar foo-bar)
-      (baz foo-baz (default (+ 40 2))))
-    (and (match (foo (bar 1) (baz 2))
-           (($ <foo> 1 2) #t))
-         (match (foo (baz 2) (bar 1))
-           (($ <foo> 1 2) #t))
-         (match (foo (bar 1))
-           (($ <foo> 1 42) #t)))))
-
-(test-assert "define-record-type* with letrec* behavior"
-  ;; Make sure field initializers can refer to each other as if they were in
-  ;; a `letrec*'.
-  (begin
-    (define-record-type* <bar> bar make-bar
-      foo?
-      (x bar-x)
-      (y bar-y (default (+ 40 2)))
-      (z bar-z))
-    (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
-           (($ <bar> 1 2 4) #t))
-         (match (bar (x 7) (z (* x 3)))
-           (($ <bar> 7 42 21)))
-         (match (bar (z 21) (x (/ z 3)))
-           (($ <bar> 7 42 21))))))
-
-(test-assert "define-record-type* & inherit"
-  (begin
-    (define-record-type* <foo> foo make-foo
-      foo?
-      (bar foo-bar)
-      (baz foo-baz (default (+ 40 2))))
-    (let* ((a (foo (bar 1)))
-           (b (foo (inherit a) (baz 2)))
-           (c (foo (inherit b) (bar -2)))
-           (d (foo (inherit c)))
-           (e (foo (inherit (foo (bar 42))) (baz 77))))
-     (and (match a (($ <foo> 1 42) #t))
-          (match b (($ <foo> 1 2) #t))
-          (match c (($ <foo> -2 2) #t))
-          (equal? c d)
-          (match e (($ <foo> 42 77) #t))))))
-
-(test-assert "define-record-type* & inherit & letrec* behavior"
-  (begin
-    (define-record-type* <foo> foo make-foo
-      foo?
-      (bar foo-bar)
-      (baz foo-baz (default (+ 40 2))))
-    (let* ((a (foo (bar 77)))
-           (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
-           (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
-     (and (match a (($ <foo> 77 42) #t))
-          (match b (($ <foo> 1 2) #t))
-          (equal? b c)))))
+(test-assert "guile-version>? 1.8"
+  (guile-version>? "1.8"))
+
+(test-assert "guile-version>? 10.5"
+  (not (guile-version>? "10.5")))
+
+(test-equal "string-tokenize*"
+  '(("foo")
+    ("foo" "bar" "baz")
+    ("foo" "bar" "")
+    ("foo" "bar" "baz"))
+  (list (string-tokenize* "foo" ":")
+        (string-tokenize* "foo;bar;baz" ";")
+        (string-tokenize* "foo!bar!" "!")
+        (string-tokenize* "foo+-+bar+-+baz" "+-+")))
+
+(test-equal "string-replace-substring"
+  '("foo BAR! baz"
+    "/gnu/store/chbouib"
+    "")
+  (list (string-replace-substring "foo bar baz" "bar" "BAR!")
+        (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
+        (string-replace-substring "" "foo" "bar")))
+
+(test-equal "fold2, 1 list"
+    (list (reverse (iota 5))
+          (map - (reverse (iota 5))))
+  (call-with-values
+      (lambda ()
+        (fold2 (lambda (i r1 r2)
+                 (values (cons i r1)
+                         (cons (- i) r2)))
+               '() '()
+               (iota 5)))
+    list))
+
+(test-equal "fold2, 2 lists"
+    (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
+          (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
+  (call-with-values
+      (lambda ()
+        (fold2 (lambda (k v r1 r2)
+                 (values (alist-cons k v r1)
+                         (alist-cons k (- v) r2)))
+               '() '()
+               '(a b c d)
+               '(0 1 2 3)))
+    list))
+
+(test-equal "split, element is in list"
+  '((foo) (baz))
+  (call-with-values
+      (lambda ()
+        (split '(foo bar baz) 'bar))
+    list))
+
+(test-equal "split, element is not in list"
+  '((foo bar baz) ())
+  (call-with-values
+      (lambda ()
+        (split '(foo bar baz) 'quux))
+    list))
+
+(test-equal "strip-keyword-arguments"
+  '(a #:b b #:c c)
+  (strip-keyword-arguments '(#:foo #:bar #:baz)
+                           '(a #:foo 42 #:b b #:baz 3
+                               #:c c #:bar 4)))
+
+(test-equal "ensure-keyword-arguments"
+  '((#:foo 2)
+    (#:foo 2 #:bar 3)
+    (#:foo 42 #:bar 3))
+  (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
+        (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
+        (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
+
+(let* ((tree (alist->vhash
+              '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
+              hashq))
+       (add-one (lambda (_ r) (1+ r)))
+       (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
+  (test-equal "fold-tree, single root"
+    5 (fold-tree add-one 0 tree-lookup '(0)))
+  (test-equal "fold-tree, two roots"
+    7 (fold-tree add-one 0 tree-lookup '(0 1)))
+  (test-equal "fold-tree, sum"
+    16 (fold-tree + 0 tree-lookup '(0)))
+  (test-equal "fold-tree, internal"
+    18 (fold-tree + 0 tree-lookup '(3 4)))
+  (test-equal "fold-tree, cons"
+    '(1 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(1)) <))
+  (test-equal "fold-tree, overlapping paths"
+    '(1 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(1 4)) <))
+  (test-equal "fold-tree, cons, two roots"
+    '(0 2 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(0 4)) <))
+  (test-equal "fold-tree-leaves, single root"
+    2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
+  (test-equal "fold-tree-leaves, single root, sum"
+    11 (fold-tree-leaves + 0 tree-lookup '(1)))
+  (test-equal "fold-tree-leaves, two roots"
+    3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
+  (test-equal "fold-tree-leaves, two roots, sum"
+    13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
+
+(test-assert "filtered-port, file"
+  (let* ((file  (search-path %load-path "guix.scm"))
+         (input (open-file file "r0b")))
+    (let*-values (((compressed pids1)
+                   (filtered-port `(,%gzip "-c" "--fast") input))
+                  ((decompressed pids2)
+                   (filtered-port `(,%gzip "-d") compressed)))
+      (and (every (compose zero? cdr waitpid)
+                  (append pids1 pids2))
+           (equal? (get-bytevector-all decompressed)
+                   (call-with-input-file file get-bytevector-all))))))
+
+(test-assert "filtered-port, non-file"
+  (let ((data (call-with-input-file (search-path %load-path "guix.scm")
+                get-bytevector-all)))
+    (let*-values (((compressed pids1)
+                   (filtered-port `(,%gzip "-c" "--fast")
+                                  (open-bytevector-input-port data)))
+                  ((decompressed pids2)
+                   (filtered-port `(,%gzip "-d") compressed)))
+      (and (pk (every (compose zero? cdr waitpid)
+                   (append pids1 pids2)))
+           (equal? (get-bytevector-all decompressed) data)))))
+
+(test-assert "filtered-port, does not exist"
+  (let* ((file  (search-path %load-path "guix.scm"))
+         (input (open-file file "r0b")))
+    (let-values (((port pids)
+                  (filtered-port '("/does/not/exist") input)))
+      (any (compose (negate zero?) cdr waitpid)
+           pids))))
+
+(test-assert "compressed-port, decompressed-port, non-file"
+  (let ((data (call-with-input-file (search-path %load-path "guix.scm")
+                get-bytevector-all)))
+    (let*-values (((compressed pids1)
+                   (compressed-port 'xz (open-bytevector-input-port data)))
+                  ((decompressed pids2)
+                   (decompressed-port 'xz compressed)))
+      (and (every (compose zero? cdr waitpid)
+                  (append pids1 pids2))
+           (equal? (get-bytevector-all decompressed) data)))))
+
+(false-if-exception (delete-file temp-file))
+(test-assert "compressed-output-port + decompressed-port"
+  (let* ((file (search-path %load-path "guix/derivations.scm"))
+         (data (call-with-input-file file get-bytevector-all))
+         (port (open-file temp-file "w0b")))
+    (call-with-compressed-output-port 'xz port
+      (lambda (compressed)
+        (put-bytevector compressed data)))
+    (close-port port)
+
+    (bytevector=? data
+                  (call-with-decompressed-port 'xz (open-file temp-file "r0b")
+                    get-bytevector-all))))
+
+(false-if-exception (delete-file temp-file))
+(test-equal "fcntl-flock wait"
+  42                                              ; the child's exit status
+  (let ((file (open-file temp-file "w0b")))
+    ;; Acquire an exclusive lock.
+    (fcntl-flock file 'write-lock)
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           ;; Reopen FILE read-only so we can have a read lock.
+           (let ((file (open-file temp-file "r0b")))
+             ;; Wait until we can acquire the lock.
+             (fcntl-flock file 'read-lock)
+             (primitive-exit (read file)))
+           (primitive-exit 1))
+         (lambda ()
+           (primitive-exit 2))))
+      (pid
+       ;; Write garbage and wait.
+       (display "hello, world!"  file)
+       (force-output file)
+       (sleep 1)
+
+       ;; Write the real answer.
+       (seek file 0 SEEK_SET)
+       (truncate-file file 0)
+       (write 42 file)
+       (force-output file)
+
+       ;; Unlock, which should let the child continue.
+       (fcntl-flock file 'unlock)
+
+       (match (waitpid pid)
+         ((_  . status)
+          (let ((result (status:exit-val status)))
+            (close-port file)
+            result)))))))
+
+(test-equal "fcntl-flock non-blocking"
+  EAGAIN                                          ; the child's exit status
+  (match (pipe)
+    ((input . output)
+     (match (primitive-fork)
+       (0
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close-port output)
+
+            ;; Wait for the green light.
+            (read-char input)
+
+            ;; Open FILE read-only so we can have a read lock.
+            (let ((file (open-file temp-file "w0")))
+              (catch 'flock-error
+                (lambda ()
+                  ;; This attempt should throw EAGAIN.
+                  (fcntl-flock file 'write-lock #:wait? #f))
+                (lambda (key errno)
+                  (primitive-exit (pk 'errno errno)))))
+            (primitive-exit -1))
+          (lambda ()
+            (primitive-exit -2))))
+       (pid
+        (close-port input)
+        (let ((file (open-file temp-file "w0")))
+          ;; Acquire an exclusive lock.
+          (fcntl-flock file 'write-lock)
+
+          ;; Tell the child to continue.
+          (write 'green-light output)
+          (force-output output)
+
+          (match (waitpid pid)
+            ((_  . status)
+             (let ((result (status:exit-val status)))
+               (fcntl-flock file 'unlock)
+               (close-port file)
+               result)))))))))
 
 ;; This is actually in (guix store).
 (test-equal "store-path-package-name"
   "bash-4.2-p24"
   (store-path-package-name
-   "/nix/store/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24"))
+   (string-append (%store-prefix)
+                  "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
+
+(test-equal "canonical-newline-port"
+  "This is a journey\nInto the sound\nA journey ...\n"
+  (let ((port (open-string-input-port
+               "This is a journey\r\nInto the sound\r\nA journey ...\n")))
+    (get-string-all (canonical-newline-port port))))
 
 (test-end)
 
+(false-if-exception (delete-file temp-file))
+
 
 (exit (= (test-runner-fail-count (test-runner-current)) 0))
-
-;;; Local Variables:
-;;; eval: (put 'test-assert 'scheme-indent-function 1)
-;;; End: