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 (defmacro with-event-base/for-each-mux ((base &rest initargs) &body body)
  30   `(let ((failed-list))
  31      (dolist (mux (mapcar #'cdr *available-multiplexers*) failed-list)
  32        (handler-case
  33            (with-event-base (,base :mux mux ,@initargs)
  34              ,@body)
  35          (error (err)
  36            (push (cons mux err) failed-list))))))
  37
  38 (deftest timeout.1
  39     (with-event-base/for-each-mux (base)
  40       (event-dispatch base :timeout 0))
  41   nil)
  42
  43 (deftest timeout.2
  44     (with-event-base/for-each-mux (base)
  45       (let ((cb nil))
  46         (add-timeout base (lambda (fd event)
  47                             (declare (ignore fd))
  48                             (setq cb event))
  49                      30)
  50         (event-dispatch base :timeout 0)
  51         (assert (null cb))))
  52   nil)
  53
  54 (deftest timeout.3
  55     (with-event-base/for-each-mux (base)
  56       (let ((cb nil))
  57         (add-timeout base (lambda (fd event)
  58                             (declare (ignore fd))
  59                             (setq cb event))
  60                      0)
  61         (event-dispatch base :one-shot t)
  62         (assert (eq cb :timeout))))
  63   nil)
  64
  65 ;;; regression test: timeouts' absolute times used used to be
  66 ;;; incremented with the relative time ad infinitum.
  67 (deftest timeout.4
  68     (with-event-base/for-each-mux (base)
  69       (let ((cb nil))
  70         (add-timeout base (lambda (fd event)
  71                             (declare (ignore fd))
  72                             (setq cb event))
  73                      1.5)
  74         (event-dispatch base :one-shot t :timeout 2)
  75         (assert (eq cb :timeout))))
  76   nil)
  77
  78 (defun timeout-cb (fd event)
  79   (declare (ignore fd event))
  80   (error "timeout"))
  81
  82 (defmacro waiting-for-event ((base fd event-type) &body body)
  83   (with-unique-names (fd-arg event-arg)
  84     (once-only (base)
  85       `(progn
  86          (add-fd ,base ,fd ,event-type
  87                  (lambda (,fd-arg ,event-arg)
  88                    (when (eq ,event-arg :error)
  89                      (error "error with ~A" ,fd-arg))
  90                    ,@body)
  91                  :one-shot t)
  92          (event-dispatch ,base :one-shot t)))))
  93
  94 ;;; FIXME: doesn't work with SELECT.
  95 ;;;        where ? it works here, on Linux. SIONESCU 2007.12.02
  96 (deftest event-base-with-open-sockets
  97     (with-event-base (base)
  98       (with-open-socket (passive :family :ipv4 :connect :passive
  99                                  :local-host +ipv4-unspecified+)
 100         (with-open-socket (active :family :ipv4
 101                                   :remote-port (local-port passive)
 102                                   :remote-host #(127 0 0 1))
 103           (add-timeout base #'timeout-cb 5)
 104           (let (peer)
 105             (waiting-for-event (base (fd-of passive) :read)
 106               (setq peer (accept-connection passive)))
 107             (assert (socket-open-p peer)))
 108           ;; TODO: send and receive some stuff
 109           ))
 110       nil)
 111   nil)