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

Last change on this file since 34718 was 34718, checked in by sjamaan, 18 months ago

release/5: Replace use by import in eggs

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