source: project/release/4/remote-mailbox/trunk/tests/remote-mailbox-test.scm @ 16202

Last change on this file since 16202 was 16202, checked in by kon, 10 years ago

Msg print chgs in test

File size: 2.2 KB
Line 
1;;;; remote-mailbox-test.scm
2 
3; should run multiple senders
4;
5; should have a better way to terminate the tcp-server loop
6
7(use srfi-1 posix srfi-18)
8(use remote-mailbox-client remote-mailbox-server mailbox miscmacros)
9
10(define-constant NUM-MSG 5)
11(define-constant RCV-NAM "Wong Foo")
12(define MB-NAM 'wong-foo)
13
14(define (sender)
15  (print "* Sending " NUM-MSG " messages")
16        (let ((rmb (remote-mailbox MB-NAM)))
17                (dotimes (n NUM-MSG)
18                        (print "Sending message number " n " to " RCV-NAM)
19                        (remote-mailbox-send! rmb (list "to" RCV-NAM ":" n))
20                        ; Semblance of computation
21                        (thread-sleep! 1) #;(repeat 10000) )
22                (print "Send quit")
23                (remote-mailbox-send! rmb 'quit) ) )
24       
25(define (receiver)
26  (define (server)
27    (let ((rmbs (make-remote-mailbox-server #:debug RCV-NAM)))
28      (values rmbs (remote-mailbox-server-start! rmbs)) ) )
29  (let-values (((rmbs thrd) (server)))
30    (print "* Receiving messages until 'quit")
31    (let loop ()
32      (let ((msg (mailbox-receive! (local-mailbox/server rmbs MB-NAM))))
33        (print "Received " msg)
34        (unless (eq? 'quit msg)
35          (loop) ) ) )
36    (thread-terminate! thrd)
37    (handle-exceptions ex
38        (print "Performed \"hard\" termination of server thread")
39      (thread-join! thrd) ) ) )
40
41#;
42(define (receiver)
43  (print "* Receiving messages until 'quit")
44  (let loop ()
45    (let ((msg (mailbox-receive! (local-mailbox MB-NAM RCV-NAM))))
46      (print "Received " msg)
47      (unless (eq? 'quit msg)
48        (loop) ) ) )
49  (thread-terminate! (local-mailbox-thread))
50  (handle-exceptions ex
51      (print "Performed \"hard\" termination of server thread")
52    (thread-join! (local-mailbox-thread)) ) )
53
54(define operation
55        (let ((args (command-line-arguments)))
56                (and (pair? args)
57                     (string->symbol (car args))) ) )
58
59(if operation
60    (case operation
61      ((sender) (sender))
62      ((receiver) (receiver))
63      (else
64        (error 'remote-mailbox-test "Unrecognized operation: " operation) ) ) 
65    ;; The "server" MUST be started before the client!
66    (let ((cmd (first (argv))))
67      (print "Running Receiver: " cmd)
68      (process-run cmd `("receiver"))
69      (sleep 1) ;needed when this process is the sender
70      (print "Running Sender: " cmd)
71      #;(process-execute cmd `("sender"))
72      (sender) ) )
Note: See TracBrowser for help on using the repository browser.