io-multiplex/fd-entry.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; fd-entry.lisp --- FD event structure.
   4 ;;;
   5 ;;; Copyright (C) 2003 Zach Beane <xach@xach.com>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person obtaining
   8 ;;; a copy of this software and associated documentation files (the
   9 ;;; "Software"), to deal in the Software without restriction, including
  10 ;;; without limitation the rights to use, copy, modify, merge,publish,
  11 ;;; distribute, sublicense, and/or sell copies of the Software, and to
  12 ;;; permit persons to whom the Software is furnished to do so, subject to
  13 ;;; 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 HOLDERS BE
  22 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  23 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  24 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  25
  26 (in-package :io.multiplex)
  27
  28 ;;;; EVENT
  29
  30 (defstruct (event (:constructor make-event (fd type handler persistent-p
  31                                                abs-timeout timeout))
  32                   (:copier nil))
  33   ;; a file descriptor or nil in case of a timeout
  34   (fd nil :type (or null unsigned-byte))
  35   (type nil :type (or null event-type))
  36   (handler nil :type (or null function))
  37   ;; if an event is not persistent it is removed
  38   ;; after it occurs or if it times out
  39   (persistent-p nil :type boolean)
  40   (abs-timeout nil :type (or null timeout))
  41   (timeout nil :type (or null timeout)))
  42
  43 (defun event-recalc-abs-timeout (event now)
  44   (setf (event-abs-timeout event)
  45         (+ now (event-timeout event))))
  46
  47 ;;;; FD-ENTRY
  48
  49 (deftype fd-event ()
  50   '(member :read :write :error))
  51
  52 (deftype event-type ()
  53   '(or fd-event (member :timeout)))
  54
  55 (defstruct (fd-entry (:constructor make-fd-entry (fd))
  56                      (:copier nil))
  57   (fd 0 :type unsigned-byte)
  58   (edge-change nil :type symbol)
  59   (read-events  (make-queue) :type queue)
  60   (write-events (make-queue) :type queue)
  61   (error-events (make-queue) :type queue))
  62
  63 (defun fd-entry-event-list (fd-entry event-type)
  64   (check-type fd-entry fd-entry)
  65   (check-type event-type fd-event)
  66   (case event-type
  67     (:read (fd-entry-read-events fd-entry))
  68     (:write (fd-entry-write-events fd-entry))
  69     (:error (fd-entry-error-events fd-entry))))
  70
  71 (defun (setf fd-entry-event-list) (fd-entry event-list event-type)
  72   (check-type fd-entry fd-entry)
  73   (check-type event-type fd-event)
  74   (case event-type
  75     (:read (setf (fd-entry-read-events fd-entry) event-list))
  76     (:write (setf (fd-entry-write-events fd-entry) event-list))
  77     (:error (setf (fd-entry-error-events fd-entry) event-list))))
  78
  79 (defun fd-entry-empty-p (fd-entry)
  80   (and (queue-empty-p (fd-entry-read-events fd-entry))
  81        (queue-empty-p (fd-entry-write-events fd-entry))
  82        (queue-empty-p (fd-entry-error-events fd-entry))))
  83
  84 (defun fd-entry-add-event (fd-entry event)
  85   (queue-enqueue (fd-entry-event-list fd-entry (event-type event))
  86                  event))
  87
  88 (defun fd-entry-del-event (fd-entry event)
  89   (queue-delete (fd-entry-event-list fd-entry (event-type event))
  90                 event))
  91
  92 (defun fd-entry-all-events (fd-entry)
  93   (append (queue-head (fd-entry-read-events fd-entry))
  94           (queue-head (fd-entry-write-events fd-entry))
  95           (queue-head (fd-entry-error-events fd-entry))))
  96
  97 (defun fd-entry-one-shot-events (fd-entry event-type)
  98   (remove-if #'event-persistent-p
  99              (queue-head (fd-entry-event-list fd-entry event-type))))