gnu: Add JSON-XS.

[jackhill/guix/guix.git] / tests / utils.scm

diff --git a/tests/utils.scm b/tests/utils.scm
index adac5d4..a662c9a 100644 (file)
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,7 +26,8 @@
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
-  #:use-module (ice-9 match))
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist))
 
 (define temp-file
   (string-append "t-utils-" (number->string (getpid))))
@@ -118,6 +120,43 @@
                '(0 1 2 3)))
     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)))
+
+(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")))
@@ -142,10 +181,43 @@
                    (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 "w0")))
+  (let ((file (open-file temp-file "w0b")))
     ;; Acquire an exclusive lock.
     (fcntl-flock file 'write-lock)
     (match (primitive-fork)
@@ -154,7 +226,7 @@
          (const #t)
          (lambda ()
            ;; Reopen FILE read-only so we can have a read lock.
-           (let ((file (open-file temp-file "r")))
+           (let ((file (open-file temp-file "r0b")))
              ;; Wait until we can acquire the lock.
              (fcntl-flock file 'read-lock)
              (primitive-exit (read file)))
@@ -197,19 +269,19 @@
             (read-char input)
 
             ;; Open FILE read-only so we can have a read lock.
-            (let ((file (open-file temp-file "w")))
+            (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 errno))))
+                  (primitive-exit (pk 'errno errno)))))
             (primitive-exit -1))
           (lambda ()
             (primitive-exit -2))))
        (pid
         (close-port input)
-        (let ((file (open-file temp-file "w")))
+        (let ((file (open-file temp-file "w0")))
           ;; Acquire an exclusive lock.
           (fcntl-flock file 'write-lock)