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

;;; 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 GNU Guix.
;;;
;;; 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.
;;;
;;; 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 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-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 (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")

(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")
                   ("i386-pc-linux-gnu" "i686-linux")
                   ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
                   ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
                   ("i686-pc-cygwin" "i686-cygwin"))))
    (let-values (((gnu nix) (unzip2 samples)))
      (every (lambda (gnu nix)
               (equal? nix (gnu-triplet->nix-system gnu)))
             gnu nix))))

(test-assert "package-name->name+version"
  (every (match-lambda
          ((name version)
           (let*-values (((full-name)
                          (if version
                              (string-append name "-" version)
                              name))
                         ((name* version*)
                          (package-name->name+version full-name)))
             (and (equal? name* name)
                  (equal? version* version)))))
         '(("foo" "0.9.1b")
           ("foo-bar" "1.0")
           ("foo-bar2" #f)
           ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
           ("nixpkgs" "1.0pre22125_a28fe19")
           ("gtk2" "2.38.0"))))

(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
   (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))

\f
(exit (= (test-runner-fail-count (test-runner-current)) 0))
Commit	Line	Data
233e7676	1	;;; GNU Guix --- Functional package management for GNU
6071122b	2	;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
516e3b6f	3	;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
e3deeebb	4	;;;
233e7676	5	;;; This file is part of GNU Guix.
e3deeebb	6	;;;
233e7676	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
e3deeebb LC	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
233e7676	12	;;; GNU Guix is distributed in the hope that it will be useful, but
e3deeebb LC	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
233e7676	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
e3deeebb	19
e3deeebb	20	(define-module (test-utils)
e0fbbc88	21	#:use-module ((guix config) #:select (%gzip))
e3deeebb	22	#:use-module (guix utils)
b980f0f9	23	#:use-module ((guix store) #:select (%store-prefix store-path-package-name))
d838e702	24	#:use-module ((guix search-paths) #:select (string-tokenize*))
e3deeebb	25	#:use-module (srfi srfi-1)
98090557	26	#:use-module (srfi srfi-11)
e3deeebb	27	#:use-module (srfi srfi-64)
f9c7080a	28	#:use-module (rnrs bytevectors)
e0fbbc88	29	#:use-module (rnrs io ports)
516e3b6f EB	30	#:use-module (ice-9 match)
516e3b6f EB	31	#:use-module (ice-9 vlist))
e3deeebb	32
827d5563 LC	33	(define temp-file
	34	(string-append "t-utils-" (number->string (getpid))))
	35
e3deeebb LC	36	(test-begin "utils")
e3deeebb LC	37
6d800a80 LC	38	(test-assert "bytevector->base16-string->bytevector"
	39	(every (lambda (bv)
	40	(equal? (base16-string->bytevector
	41	(bytevector->base16-string bv))
	42	bv))
	43	(map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
	44
98090557 LC	45	(test-assert "gnu-triplet->nix-system"
	46	(let ((samples '(("i586-gnu0.3" "i686-gnu")
	47	("x86_64-unknown-linux-gnu" "x86_64-linux")
	48	("i386-pc-linux-gnu" "i686-linux")
	49	("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
	50	("x86_64-apple-darwin10.8.0" "x86_64-darwin")
	51	("i686-pc-cygwin" "i686-cygwin"))))
	52	(let-values (((gnu nix) (unzip2 samples)))
	53	(every (lambda (gnu nix)
	54	(equal? nix (gnu-triplet->nix-system gnu)))
	55	gnu nix))))
	56
9b48fb88 LC	57	(test-assert "package-name->name+version"
	58	(every (match-lambda
	59	((name version)
	60	(let*-values (((full-name)
	61	(if version
	62	(string-append name "-" version)
	63	name))
	64	((name* version*)
	65	(package-name->name+version full-name)))
	66	(and (equal? name* name)
	67	(equal? version* version)))))
	68	'(("foo" "0.9.1b")
	69	("foo-bar" "1.0")
	70	("foo-bar2" #f)
	71	("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
	72	("nixpkgs" "1.0pre22125_a28fe19")
	73	("gtk2" "2.38.0"))))
	74
7db3ff4a LC	75	(test-assert "guile-version>? 1.8"
	76	(guile-version>? "1.8"))
	77
	78	(test-assert "guile-version>? 10.5"
	79	(not (guile-version>? "10.5")))
	80
2bcfb9e0 LC	81	(test-equal "string-tokenize*"
	82	'(("foo")
	83	("foo" "bar" "baz")
	84	("foo" "bar" "")
	85	("foo" "bar" "baz"))
d838e702 LC	86	(list (string-tokenize* "foo" ":")
	87	(string-tokenize* "foo;bar;baz" ";")
	88	(string-tokenize* "foo!bar!" "!")
	89	(string-tokenize* "foo+-+bar+-+baz" "+-+")))
2bcfb9e0	90
56b943de LC	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
04fd96ca LC	99	(test-equal "fold2, 1 list"
	100	(list (reverse (iota 5))
	101	(map - (reverse (iota 5))))
	102	(call-with-values
	103	(lambda ()
	104	(fold2 (lambda (i r1 r2)
	105	(values (cons i r1)
	106	(cons (- i) r2)))
	107	'() '()
	108	(iota 5)))
	109	list))
	110
	111	(test-equal "fold2, 2 lists"
	112	(list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
	113	(reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
	114	(call-with-values
	115	(lambda ()
	116	(fold2 (lambda (k v r1 r2)
	117	(values (alist-cons k v r1)
	118	(alist-cons k (- v) r2)))
	119	'() '()
	120	'(a b c d)
	121	'(0 1 2 3)))
	122	list))
	123
bbd00d20 DT	124	(test-equal "split, element is in list"
	125	'((foo) (baz))
	126	(call-with-values
	127	(lambda ()
	128	(split '(foo bar baz) 'bar))
	129	list))
	130
	131	(test-equal "split, element is not in list"
	132	'((foo bar baz) ())
	133	(call-with-values
	134	(lambda ()
	135	(split '(foo bar baz) 'quux))
	136	list))
	137
5e110382 LC	138	(test-equal "strip-keyword-arguments"
	139	'(a #:b b #:c c)
	140	(strip-keyword-arguments '(#:foo #:bar #:baz)
	141	'(a #:foo 42 #:b b #:baz 3
	142	#:c c #:bar 4)))
	143
6071122b LC	144	(test-equal "ensure-keyword-arguments"
	145	'((#:foo 2)
	146	(#:foo 2 #:bar 3)
	147	(#:foo 42 #:bar 3))
	148	(list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
	149	(ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
	150	(ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
	151
516e3b6f EB	152	(let* ((tree (alist->vhash
	153	'((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
	154	hashq))
	155	(add-one (lambda (_ r) (1+ r)))
	156	(tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
	157	(test-equal "fold-tree, single root"
	158	5 (fold-tree add-one 0 tree-lookup '(0)))
	159	(test-equal "fold-tree, two roots"
	160	7 (fold-tree add-one 0 tree-lookup '(0 1)))
	161	(test-equal "fold-tree, sum"
	162	16 (fold-tree + 0 tree-lookup '(0)))
	163	(test-equal "fold-tree, internal"
	164	18 (fold-tree + 0 tree-lookup '(3 4)))
	165	(test-equal "fold-tree, cons"
	166	'(1 3 4 5 6)
	167	(sort (fold-tree cons '() tree-lookup '(1)) <))
	168	(test-equal "fold-tree, overlapping paths"
	169	'(1 3 4 5 6)
	170	(sort (fold-tree cons '() tree-lookup '(1 4)) <))
	171	(test-equal "fold-tree, cons, two roots"
	172	'(0 2 3 4 5 6)
	173	(sort (fold-tree cons '() tree-lookup '(0 4)) <))
	174	(test-equal "fold-tree-leaves, single root"
	175	2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
	176	(test-equal "fold-tree-leaves, single root, sum"
	177	11 (fold-tree-leaves + 0 tree-lookup '(1)))
	178	(test-equal "fold-tree-leaves, two roots"
	179	3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
	180	(test-equal "fold-tree-leaves, two roots, sum"
	181	13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
	182
e0fbbc88	183	(test-assert "filtered-port, file"
101d9f3f	184	(let* ((file (search-path %load-path "guix.scm"))
b6952cad	185	(input (open-file file "r0b")))
101d9f3f LC	186	(let*-values (((compressed pids1)
	187	(filtered-port `(,%gzip "-c" "--fast") input))
	188	((decompressed pids2)
	189	(filtered-port `(,%gzip "-d") compressed)))
	190	(and (every (compose zero? cdr waitpid)
	191	(append pids1 pids2))
	192	(equal? (get-bytevector-all decompressed)
	193	(call-with-input-file file get-bytevector-all))))))
e0fbbc88 LC	194
	195	(test-assert "filtered-port, non-file"
	196	(let ((data (call-with-input-file (search-path %load-path "guix.scm")
	197	get-bytevector-all)))
	198	(let*-values (((compressed pids1)
	199	(filtered-port `(,%gzip "-c" "--fast")
	200	(open-bytevector-input-port data)))
	201	((decompressed pids2)
	202	(filtered-port `(,%gzip "-d") compressed)))
	203	(and (pk (every (compose zero? cdr waitpid)
	204	(append pids1 pids2)))
	205	(equal? (get-bytevector-all decompressed) data)))))
	206
443eb4e9 LC	207	(test-assert "filtered-port, does not exist"
	208	(let* ((file (search-path %load-path "guix.scm"))
	209	(input (open-file file "r0b")))
	210	(let-values (((port pids)
	211	(filtered-port '("/does/not/exist") input)))
	212	(any (compose (negate zero?) cdr waitpid)
	213	pids))))
	214
7a8024a3 LC	215	(test-assert "compressed-port, decompressed-port, non-file"
	216	(let ((data (call-with-input-file (search-path %load-path "guix.scm")
	217	get-bytevector-all)))
	218	(let*-values (((compressed pids1)
	219	(compressed-port 'xz (open-bytevector-input-port data)))
	220	((decompressed pids2)
	221	(decompressed-port 'xz compressed)))
	222	(and (every (compose zero? cdr waitpid)
	223	(append pids1 pids2))
	224	(equal? (get-bytevector-all decompressed) data)))))
	225
80dea563	226	(false-if-exception (delete-file temp-file))
01ac19dc LC	227	(test-assert "compressed-output-port + decompressed-port"
01ac19dc LC	228	(let* ((file (search-path %load-path "guix/derivations.scm"))
30ce8012 LC	229	(data (call-with-input-file file get-bytevector-all))
	230	(port (open-file temp-file "w0b")))
	231	(call-with-compressed-output-port 'xz port
01ac19dc LC	232	(lambda (compressed)
01ac19dc LC	233	(put-bytevector compressed data)))
30ce8012	234	(close-port port)
01ac19dc LC	235
	236	(bytevector=? data
	237	(call-with-decompressed-port 'xz (open-file temp-file "r0b")
	238	get-bytevector-all))))
80dea563	239
827d5563	240	(false-if-exception (delete-file temp-file))
c7445833	241	(test-equal "fcntl-flock wait"
827d5563	242	42 ; the child's exit status
68ec0450	243	(let ((file (open-file temp-file "w0b")))
827d5563 LC	244	;; Acquire an exclusive lock.
827d5563 LC	245	(fcntl-flock file 'write-lock)
2cd5c038 LC	246	(match (primitive-fork)
	247	(0
	248	(dynamic-wind
	249	(const #t)
	250	(lambda ()
827d5563	251	;; Reopen FILE read-only so we can have a read lock.
68ec0450	252	(let ((file (open-file temp-file "r0b")))
827d5563 LC	253	;; Wait until we can acquire the lock.
	254	(fcntl-flock file 'read-lock)
	255	(primitive-exit (read file)))
2cd5c038 LC	256	(primitive-exit 1))
	257	(lambda ()
	258	(primitive-exit 2))))
	259	(pid
827d5563 LC	260	;; Write garbage and wait.
	261	(display "hello, world!" file)
	262	(force-output file)
	263	(sleep 1)
	264
	265	;; Write the real answer.
	266	(seek file 0 SEEK_SET)
	267	(truncate-file file 0)
	268	(write 42 file)
	269	(force-output file)
	270
	271	;; Unlock, which should let the child continue.
	272	(fcntl-flock file 'unlock)
	273
2cd5c038 LC	274	(match (waitpid pid)
	275	((_ . status)
	276	(let ((result (status:exit-val status)))
2cd5c038 LC	277	(close-port file)
	278	result)))))))
	279
c7445833 LC	280	(test-equal "fcntl-flock non-blocking"
	281	EAGAIN ; the child's exit status
	282	(match (pipe)
	283	((input . output)
	284	(match (primitive-fork)
	285	(0
	286	(dynamic-wind
	287	(const #t)
	288	(lambda ()
	289	(close-port output)
	290
	291	;; Wait for the green light.
	292	(read-char input)
	293
	294	;; Open FILE read-only so we can have a read lock.
68ec0450	295	(let ((file (open-file temp-file "w0")))
c7445833 LC	296	(catch 'flock-error
	297	(lambda ()
	298	;; This attempt should throw EAGAIN.
	299	(fcntl-flock file 'write-lock #:wait? #f))
	300	(lambda (key errno)
68ec0450	301	(primitive-exit (pk 'errno errno)))))
c7445833 LC	302	(primitive-exit -1))
	303	(lambda ()
	304	(primitive-exit -2))))
	305	(pid
	306	(close-port input)
68ec0450	307	(let ((file (open-file temp-file "w0")))
c7445833 LC	308	;; Acquire an exclusive lock.
	309	(fcntl-flock file 'write-lock)
	310
	311	;; Tell the child to continue.
	312	(write 'green-light output)
	313	(force-output output)
	314
	315	(match (waitpid pid)
	316	((_ . status)
	317	(let ((result (status:exit-val status)))
	318	(fcntl-flock file 'unlock)
	319	(close-port file)
	320	result)))))))))
	321
e3d74106 LC	322	;; This is actually in (guix store).
	323	(test-equal "store-path-package-name"
	324	"bash-4.2-p24"
	325	(store-path-package-name
b980f0f9 LC	326	(string-append (%store-prefix)
b980f0f9 LC	327	"/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
e3d74106	328
c8be6f0d FB	329	(test-equal "canonical-newline-port"
	330	"This is a journey\nInto the sound\nA journey ...\n"
	331	(let ((port (open-string-input-port
	332	"This is a journey\r\nInto the sound\r\nA journey ...\n")))
	333	(get-string-all (canonical-newline-port port))))
	334
e3deeebb LC	335	(test-end)
e3deeebb LC	336
827d5563 LC	337	(false-if-exception (delete-file temp-file))
827d5563 LC	338
e3deeebb LC	339	\f
e3deeebb LC	340	(exit (= (test-runner-fail-count (test-runner-current)) 0))