source: project/release/5/srfi-18/trunk/tests/signal-tests.scm @ 33353

Last change on this file since 33353 was 33353, checked in by evhan, 4 years ago

various import fixes in release/5/* after core library changes

File size: 2.7 KB
Line 
1;;;; signal-tests.scm
2
3
4#+mingw32
5(begin
6  (print "this test can not be run on Windows/mingw")
7  (exit))
8
9
10(use chicken.random posix srfi-18)
11
12(define all-go? (make-parameter #f))
13
14;; This is set before starting the child to avoid the race condition
15;; from #877.  The child itself overwrites these signal handlers
16;; before sending the "all go" signal (usr1) to the parent.
17(set-signal-handler! signal/usr1 (lambda (sig) (all-go? #t)))
18
19(define received1 0)
20(define received2 0)
21
22(define (tick c)
23  (write-char c)
24  (flush-output))
25
26(define (handler sig)
27  (select sig
28    ((signal/usr1)
29     (tick #\1)
30     (set! received1 (add1 received1)))
31    ((signal/usr2)
32     (tick #\2)
33     (set! received2 (add1 received2)))))
34
35(define (fini _)
36  (printf "~%child terminating, received: ~a USR1, ~a USR2~%"
37    received1 received2)
38  (thread-sleep! 0.5)
39  (process-signal (parent-process-id) signal/usr1)
40  (exit))
41
42(define (child)
43  (print "child started")
44  (thread-start!
45   (lambda ()
46     (do () (#f)
47       (thread-sleep! 0.5)
48       (tick #\_))))
49  (set-signal-handler! signal/usr1 handler)
50  (set-signal-handler! signal/usr2 handler)
51  (set-signal-handler! signal/term fini)
52  (process-signal (parent-process-id) signal/usr1)
53  (do () (#f)
54    (thread-sleep! 1)
55    (tick #\.)))
56
57(let ((pid (process-fork child))
58      (sent1 0)
59      (sent2 0))
60  (print "Sleeping until child wakes us up") ; signal *should* interrupt the sleep
61  (print "would have slept for " (sleep 5) " more seconds")
62  (cond ((all-go?)
63         (print "sending signals to " pid)
64         (do ((i 1000 (sub1 i)))
65             ((zero? i))
66           (thread-sleep! (/ (random 10) 1000))
67           (do ((j (random 4) (sub1 j)))
68               ((zero? j))
69             (case (random 2)
70               ((0)
71                (tick #\A)
72                (set! sent1 (add1 sent1))
73                (process-signal pid signal/usr1))
74               ((1)
75                (tick #\B)
76                (set! sent2 (add1 sent2))
77                (process-signal pid signal/usr2)))))
78         (printf "~%signals sent: ~a USR1, ~a USR2~%" sent1 sent2)
79         (print "terminating child process ...")
80         (all-go? #f)
81         (print "Sending signal and waiting for acknowledgement from child")
82         (process-signal pid signal/term)
83         (unless (all-go?) ; There's a bit of a race condition here, but that's okay
84           (print "Would've slept for " (sleep 5) " more seconds"))
85         (cond ((all-go?)
86                (print "Everything is ok!")
87                (exit 0))
88               (else
89                (print "ERROR! Did not receive acknowledgement of child shutdown within 5 seconds, or another process awoke us")
90                (print "Attempting to kill child forcefully via SIGKILL")
91                (process-signal pid signal/kill)
92                (exit 1))))
93        (else (print "ERROR! Did not receive a signal from child within 10 seconds, or another process awoke us")
94              (print "terminating child process ...")
95              (exit 1))))
Note: See TracBrowser for help on using the repository browser.