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

Last change on this file since 33908 was 33908, checked in by kon, 2 years ago

mv serialize to adapter module

File size: 2.6 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                              ;a message can be any object
22                  (let ((msg (vector 'message `(recipient ,RCV-NAM) `(id ,n))))
23        (printf "Sending ~S to ~S~%" msg MB-NAM)
24        (remote-mailbox-send! rmb msg) )
25                        ; Semblance of computation
26                        (thread-sleep! 1) #;(repeat 10000) )
27                #;(close-output-port (serializer-output))
28                (begin (print "Send quit") (remote-mailbox-send! rmb 'quit)) ) )
29
30(define (receiver)
31
32  (define (server)
33    (let ((rmbs (make-remote-mailbox-server #:debug RCV-NAM)))
34      (values rmbs (remote-mailbox-server-start! rmbs)) ) )
35
36  (let-values (((rmbs thrd) (server)))
37    (print "* Receiving messages until 'quit")
38    (let loop ()
39      (let ((msg (mailbox-receive! (local-mailbox/server rmbs MB-NAM))))
40        (printf "Received ~S from ~S~%" msg MB-NAM)
41        (unless (eq? 'quit msg) (loop) )
42        #;(loop) ) )
43    #;(thread-terminate! thrd)
44    #;(handle-exceptions ex
45        (print "Performed \"hard\" termination of server thread")
46      (thread-join! thrd) )
47    (print "stopping...") (remote-mailbox-server-stop! rmbs) ) )
48
49#;
50(define (receiver)
51  (print "* Receiving messages until 'quit")
52  (let loop ()
53    (let ((msg (mailbox-receive! (local-mailbox MB-NAM RCV-NAM))))
54      (printf "Received ~S from ~S~%" msg MB-NAM)
55      (unless (eq? 'quit msg)
56        (loop) ) ) )
57  (thread-terminate! (local-mailbox-thread))
58  (handle-exceptions ex
59      (print "Performed \"hard\" termination of server thread")
60    (thread-join! (local-mailbox-thread)) ) )
61
62(define operation
63        (let ((args (command-line-arguments)))
64                (and
65                  (pair? args)
66      (string->symbol (car args))) ) )
67
68(if operation
69    (case operation
70      ((sender) (sender))
71      ((receiver) (receiver))
72      (else
73        (error 'remote-mailbox-test "Unrecognized operation: " operation) ) )
74    ;; The "server" MUST be started before the client!
75    (let ((cmd (first (argv))))
76      (print "Running Receiver: " cmd)
77      (process-run cmd `("receiver"))
78      (sleep 1) ;needed when this process is the sender
79      (print "Running Sender: " cmd)
80      #;(process-execute cmd `("sender"))
81      (sender) ) )
Note: See TracBrowser for help on using the repository browser.