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

Last change on this file since 35329 was 35329, checked in by kon, 16 months ago

add types, deprecate '/' style identifiers, use moremacros define-warning-parameter, reflow

File size: 2.7 KB
Line 
1;;;; remote-mailbox-test.scm
2
3; should run multiple senders
4;
5; doesn't have good shutdown of socket
6;
7;X should have a better way to terminate the tcp-server loop
8; - close the port
9
10(use srfi-1 posix srfi-18)
11(use remote-mailbox-client remote-mailbox-server remote-mailbox-adapter mailbox miscmacros)
12
13(define-constant NUM-MSG 5)
14(define-constant RCV-NAM "Wong Foo")
15(define MB-NAM 'wong-foo)
16
17(define (sender)
18  (print "* Sending " NUM-MSG " messages")
19  (let ((rmb (remote-mailbox MB-NAM)))
20    (dotimes (n NUM-MSG)
21      (let (
22        ;a message can be any object
23        (msg (vector 'message `(recipient ,RCV-NAM) `(id ,n))) )
24        (printf "Sending ~S to ~S~%" msg MB-NAM)
25        (remote-mailbox-send! rmb msg) )
26      ;Semblance of computation
27      #;(repeat 10000)
28      (thread-sleep! 1) )
29    #;(close-output-port (serializer-output))
30    (begin
31      (print "Send quit")
32      (remote-mailbox-send! rmb 'quit)) ) )
33
34(define (receiver)
35  ;
36  (define (server)
37    (let ((rmbs (make-remote-mailbox-server #:debug RCV-NAM)))
38      (values rmbs (remote-mailbox-server-start! rmbs)) ) )
39  ;
40  (let-values (((rmbs thrd) (server)))
41    ;
42    (handle-exceptions
43      ;as
44      ex
45      ;with
46      (begin
47        (print "stopping test...")
48        (remote-mailbox-server-stop! rmbs) )
49      ;in
50      (print "* Receiving messages until 'quit")
51      (let receive-loop ()
52        (let ((msg (mailbox-receive! (local-mailbox-for-server rmbs MB-NAM))))
53          (printf "Received ~S from ~S~%" msg MB-NAM)
54          (unless (eq? 'quit msg)
55            (receive-loop) ) ) )
56      ;
57      (print "stopping test...")
58      (remote-mailbox-server-stop! rmbs)
59      (thread-join! thrd) ) ) )
60
61#;
62(define (receiver)
63  (print "* Receiving messages until 'quit")
64  (let loop ()
65    (let ((msg (mailbox-receive! (local-mailbox MB-NAM RCV-NAM))))
66      (printf "Received ~S from ~S~%" msg MB-NAM)
67      (unless (eq? 'quit msg)
68        (loop) ) ) )
69  (thread-terminate! (local-mailbox-thread))
70  (handle-exceptions ex
71      (print "Performed \"hard\" termination of server thread")
72    (thread-join! (local-mailbox-thread)) ) )
73
74(define operation
75  (let ((args (command-line-arguments)))
76    (and
77      (pair? args)
78      (string->symbol (car args))) ) )
79
80(if operation
81    (case operation
82      ((sender) (sender))
83      ((receiver) (receiver))
84      (else
85        (error 'remote-mailbox-test "Unrecognized operation: " operation) ) )
86    ;; The "server" MUST be started before the client!
87    (let ((cmd (first (argv))))
88      (print "Running Receiver: " cmd)
89      (process-run cmd `("receiver"))
90      (sleep 1) ;needed when this process is the sender
91      (print "Running Sender: " cmd)
92      #;(process-execute cmd `("sender"))
93      (sender) ) )
Note: See TracBrowser for help on using the repository browser.