1: ;; test gauche.selector
    2: ;; $Id: selector.scm,v 1.2 2005/07/11 03:33:14 shirok Exp $
    3: 
    4: 
    5: (unless (global-variable-bound? 'gauche 'sys-select)
    6:   ;; they don't work on the platform that doesn't have sys-select.
    7:   (exit 0))
    8: 
    9: (use gauche.test)
   10: 
   11: (test-start "selector")
   12: (use gauche.selector)
   13: (test-module 'gauche.selector)
   14: 
   15: (define *sel* #f)
   16: (define-values (*p0* *p1*) (sys-pipe))
   17: (define-values (*q0* *q1*) (sys-pipe))
   18: 
   19: (define *x* #f)
   20: (define *y* #f)
   21: 
   22: (define (set-x port flags)
   23:   (case flags
   24:     ((r) (set! *x* (read port)))
   25:     ((w) (write '(xxx) port) (flush port))))
   26: 
   27:   
   28: (define (set-y port flags)
   29:   (case flags
   30:     ((r) (set! *y* (read port)))
   31:     ((w) (write '(yyy) port) (flush port))))
   32: 
   33: (test* "make" #t
   34:        (begin (set! *sel* (make <selector>))
   35:               (is-a? *sel* <selector>)))
   36: 
   37: (test* "selector-add!" #f
   38:        (begin
   39:          (selector-add! *sel* *p0* set-x '(r))
   40:          *x*))
   41: 
   42: (test* "selector-select" '(foo)
   43:        (begin
   44:          (write '(foo) *p1*)
   45:          (flush *p1*)
   46:          (selector-select *sel*)
   47:          *x*))
   48: 
   49: (test* "selector-add!" #f
   50:        (begin
   51:          (selector-add! *sel* *q0* set-y '(r))
   52:          *y*))
   53: 
   54: (test* "selector-select" '(bar baz)
   55:        (begin
   56:          (write '(bar baz) *q1*)
   57:          (flush *q1*)
   58:          (selector-select *sel* '(1 0))
   59:          *y*))
   60: 
   61: (test* "selector-delete! (by port)" '(foo)
   62:        (begin
   63:          (selector-delete! *sel* *p0* #f #f)
   64:          (write '(zzz) *p1*)
   65:          (flush *p1*)
   66:          (selector-select *sel* 0)
   67:          *x*))
   68: 
   69: (test* "selector-delete! (by proc)" '(bar baz)
   70:        (begin
   71:          (selector-delete! *sel* #f set-y #f)
   72:          (write '(yyy) *q1*)
   73:          (flush *q1*)
   74:          (selector-select *sel* 0)
   75:          *y*))
   76: 
   77: (test* "selector-select (flags)" '(((zzz) (yyy))
   78:                                    ((xxx) (yyy)))
   79:        (begin
   80:          (selector-add! *sel* *p0* set-x '(r))
   81:          (selector-add! *sel* *q0* set-y '(r))
   82:          (selector-add! *sel* *p1* set-x '(w))
   83:          (selector-add! *sel* *q1* set-y '(w))
   84:          (selector-select *sel*)
   85:          (let ((a (list *x* *y*)))
   86:            (selector-select *sel*)
   87:            (selector-select *sel* 0)
   88:            (list a (list *x* *y*)))))
   89: 
   90: (test* "selector-delete! (flags)" '((xxx) (yyy))
   91:        (begin
   92:          (write '(aaa) *p1*) (flush *p1*)
   93:          (write '(bbb) *q1*) (flush *q1*)
   94:          (selector-delete! *sel* #f #f '(r))
   95:          (selector-select *sel* 0)
   96:          (list *x* *y*)))
   97: 
   98: (test-end)