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

Last change on this file since 34486 was 34486, checked in by kon, 23 months ago

"fix" test

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