tests/events.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; events.lisp --- io.multiplexer test suite.
   4 ;;;
   5 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26
  27 (in-package :iolib-tests)
  28
  29 (in-suite* :io.multiplex :in :iolib)
  30
  31 (defmacro with-event-base/for-each-mux ((base &rest initargs) &body body)
  32   `(let ((failed-list))
  33      (dolist (mux (mapcar #'cdr *available-multiplexers*) failed-list)
  34        (handler-case
  35            (with-event-base (,base :mux mux ,@initargs)
  36              ,@body)
  37          (error (err)
  38            (push (cons mux err) failed-list))))))
  39
  40 (test timeout.1
  41   (is-false
  42    (with-event-base/for-each-mux (base)
  43      (event-dispatch base :timeout 0))))
  44
  45 (test timeout.2
  46   (is-false
  47    (with-event-base/for-each-mux (base)
  48      (let ((cb nil))
  49        (add-timer base (lambda () (setq cb :timeout)) 30)
  50        (event-dispatch base :timeout 0)
  51        (assert (null cb))))))
  52
  53 (test timeout.3
  54   (is-false
  55    (with-event-base/for-each-mux (base)
  56      (let ((cb nil))
  57        (add-timer base (lambda () (setq cb :timeout)) 0)
  58        (event-dispatch base :one-shot t)
  59        (assert (eq cb :timeout))))))
  60
  61 ;;; regression test: timeouts' absolute times used used to be
  62 ;;; incremented with the relative time ad infinitum.
  63 (test timeout.4
  64   (is-false
  65    (with-event-base/for-each-mux (base)
  66      (let ((cb nil))
  67        (add-timer base (lambda () (setq cb :timeout)) 1.5)
  68        (event-dispatch base :one-shot t :timeout 2)
  69        (assert (eq cb :timeout))))))
  70
  71 (defun timeout-cb (fd event)
  72   (declare (ignore fd event))
  73   (error "timeout"))
  74
  75 (defmacro waiting-for-event ((base fd event-type) &body body)
  76   (with-gensyms (fd-arg event-arg)
  77     (once-only (base)
  78       `(progn
  79          (add-fd ,base ,fd ,event-type
  80                  (lambda (,fd-arg ,event-arg)
  81                    (when (eq ,event-arg :error)
  82                      (error "error with ~A" ,fd-arg))
  83                    ,@body)
  84                  :one-shot t)
  85          (event-dispatch ,base :one-shot t)))))
  86
  87 ;;; FIXME: doesn't work with SELECT.
  88 ;;;        where ? it works here, on Linux. SIONESCU 2007.12.02
  89 (test event-base-with-open-sockets
  90   (is-false
  91    (with-event-base (base)
  92      (with-open-socket (passive :family :ipv4 :connect :passive
  93                                 :local-host +ipv4-unspecified+)
  94        (with-open-socket (active :family :ipv4
  95                                  :remote-port (local-port passive)
  96                                  :remote-host #(127 0 0 1))
  97          (add-timer base #'timeout-cb 5)
  98          (let (peer)
  99            (waiting-for-event (base (fd-of passive) :read)
 100                               (setq peer (accept-connection passive)))
 101            (assert (socket-open-p peer)))
 102          ;; TODO: send and receive some stuff
 103          ))
 104      nil)))