diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 16 | ||||
| -rw-r--r-- | tests/pack.scm | 2 | ||||
| -rw-r--r-- | tests/processes.scm | 86 |
3 files changed, 103 insertions, 1 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm index bc83a8de8c..d5bc5dbc71 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -680,6 +680,22 @@ #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) +(test-assert "gexp-modules deletes duplicates" ;<https://bugs.gnu.org/32966> + (let ((make-file (lambda () + ;; Use 'eval' to make sure we get an object that's not + ;; 'eq?' nor 'equal?' due to the closures it embeds. + (eval '(scheme-file "bar.scm" #~(define-module (bar))) + (current-module))))) + (define result + ((@@ (guix gexp) gexp-modules) + (with-imported-modules `(((bar) => ,(make-file)) + ((bar) => ,(make-file)) + (foo) (foo)) + #~+))) + + (match result + (((('bar) '=> (? scheme-file?)) ('foo)) #t)))) + (test-equal "gexp-modules and literal Scheme object" '() (gexp-modules #t)) diff --git a/tests/pack.scm b/tests/pack.scm index 7f867894c2..4eb5be92ff 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -55,7 +55,7 @@ ;; quite inexpensively; see <https://bugs.gnu.org/32184>. (with-external-store store - (unless store (tests-skip 1)) + (unless store (test-skip 1)) (test-assertm "self-contained-tarball" store (mlet* %store-monad ((profile (profile-derivation (packages->manifest diff --git a/tests/processes.scm b/tests/processes.scm new file mode 100644 index 0000000000..40454bcbc7 --- /dev/null +++ b/tests/processes.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.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-processes) + #:use-module (guix scripts processes) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (gnu packages bootstrap) + #:use-module (guix tests) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads)) + +(test-begin "processes") + +(test-assert "not a client" + (not (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions)))) + +(test-assert "client" + (with-store store + (let* ((session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (daemon (daemon-session-process session))) + (and (kill (process-id daemon) 0) + (string-suffix? "guix-daemon" (first (process-command daemon))))))) + +(test-assert "client + lock" + (with-store store + (call-with-temporary-directory + (lambda (directory) + (let* ((token1 (string-append directory "/token1")) + (token2 (string-append directory "/token2")) + (exp #~(begin #$(random-text) + (mkdir #$token1) + (let loop () + (unless (file-exists? #$token2) + (sleep 1) + (loop))) + (mkdir #$output))) + (guile (package-derivation store %bootstrap-guile)) + (drv (run-with-store store + (gexp->derivation "foo" exp + #:guile-for-build guile))) + (thread (call-with-new-thread + (lambda () + (build-derivations store (list drv))))) + (_ (let loop () + (unless (file-exists? token1) + (usleep 200) + (loop)))) + (session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (locks (daemon-session-locks-held (pk 'session session)))) + (call-with-output-file token2 (const #t)) + (equal? (list (string-append (derivation->output-path drv) ".lock")) + locks)))))) + +(test-end "processes") |