ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-06 23:16:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: processes: Skip tests if running with binfmt.

Browse source 
* tests/processes.scm (binfmt-misc?): New procedure,
(test-assert*): new procedure that skips the test if binfmt-misc? returns
This commit is contained in:
Mathieu Othacehe 2019-12-10 10:48:59 +01:00
parent db1adb4242
commit 0b5ad0e756
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 37 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
tests/processes.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -32,15 +33,48 @@ (define-module (test-processes)
#:use-module (ice-9 match)
#:use-module (ice-9 threads))
;; When using --system argument, binfmt-misc mechanism may be used. In that
;; case, (guix script processes) won't work because:
;;
;; * ARGV0 is qemu-user and not guix-daemon.
;; * Guix-daemon won't be able to stuff client PID in ARGV1 of forked
;; processes.
;;
;; See: https://lists.gnu.org/archive/html/bug-guix/2019-12/msg00017.html.
;;
;; If we detect that we are running with binfmt emulation, all the following
;; tests must be skipped.
(define (binfmt-misc?)
(let ((pid (getpid))
(cmdline (call-with-input-file "/proc/self/cmdline" get-string-all)))
(match (primitive-fork)
(0 (dynamic-wind
(const #t)
(lambda ()
(exit
(not (equal?
(call-with-input-file (format #f "/proc/~a/cmdline" pid)
get-string-all)
cmdline))))
(const #t)))
(x (zero? (cdr (waitpid x)))))))
(define-syntax-rule (test-assert* description exp)
(begin
(when (binfmt-misc?)
(test-skip 1))
(test-assert description exp)))
(test-begin "processes")
(test-assert "not a client"
(test-assert* "not a client"
(not (find (lambda (session)
(= (getpid)
(process-id (daemon-session-client session))))
(daemon-sessions))))
(test-assert "client"
(test-assert* "client"
(with-store store
(let* ((session (find (lambda (session)
(= (getpid)
@ -50,7 +84,7 @@ (define-module (test-processes)
(and (kill (process-id daemon) 0)
(string-suffix? "guix-daemon" (first (process-command daemon)))))))
(test-assert "client + lock"
(test-assert* "client + lock"
(with-store store
(call-with-temporary-directory
(lambda (directory)