;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
(test-begin "utils")
-(test-assert "bytevector->base16-string->bytevector"
- (every (lambda (bv)
- (equal? (base16-string->bytevector
- (bytevector->base16-string bv))
- bv))
- (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
-
(test-assert "gnu-triplet->nix-system"
(let ((samples '(("i586-gnu0.3" "i686-gnu")
("x86_64-unknown-linux-gnu" "x86_64-linux")
(test-assert "guile-version>? 10.5"
(not (guile-version>? "10.5")))
+(test-assert "version-prefix?"
+ (and (version-prefix? "4.1" "4.1.2")
+ (version-prefix? "4.1" "4.1")
+ (not (version-prefix? "4.1" "4.16.2"))
+ (not (version-prefix? "4.1" "4"))))
+
(test-equal "string-tokenize*"
'(("foo")
("foo" "bar" "baz")
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
+(test-equal "default-keyword-arguments"
+ '((#:foo 2)
+ (#:foo 2)
+ (#:foo 2 #:bar 3)
+ (#:foo 2 #:bar 3)
+ (#:foo 2 #:bar 3))
+ (list (default-keyword-arguments '() '(#:foo 2))
+ (default-keyword-arguments '(#:foo 2) '(#:foo 4))
+ (default-keyword-arguments '() '(#:bar 3 #:foo 2))
+ (default-keyword-arguments '(#:bar 3) '(#:foo 2))
+ (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
+
+(test-equal "substitute-keyword-arguments"
+ '((#:foo 3)
+ (#:foo 3)
+ (#:foo 3 #:bar (1 2))
+ (#:bar (1 2) #:foo 3)
+ (#:foo 3))
+ (list (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo f) (1+ f)))
+ (substitute-keyword-arguments '()
+ ((#:foo f 2) (1+ f)))
+ (substitute-keyword-arguments '(#:foo 2 #:bar (2))
+ ((#:foo f) (1+ f))
+ ((#:bar b) (cons 1 b)))
+ (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo _) 3)
+ ((#:bar b '(2)) (cons 1 b)))
+ (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo f 1) (1+ f))
+ ((#:bar b) (cons 42 b)))))
+
(test-assert "filtered-port, file"
(let* ((file (search-path %load-path "guix.scm"))
(input (open-file file "r0b")))
(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"