io-multiplex/common.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006,2007 by Stelian Ionescu                            ;
   5 ;                                                                         ;
   6 ;   This program is free software; you can redistribute it and/or modify  ;
   7 ;   it under the terms of the GNU General Public License as published by  ;
   8 ;   the Free Software Foundation; either version 2 of the License, or     ;
   9 ;   (at your option) any later version.                                   ;
  10 ;                                                                         ;
  11 ;   This program is distributed in the hope that it will be useful,       ;
  12 ;   but WITHOUT ANY WARRANTY; without even the implied warranty of        ;
  13 ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         ;
  14 ;   GNU General Public License for more details.                          ;
  15 ;                                                                         ;
  16 ;   You should have received a copy of the GNU General Public License     ;
  17 ;   along with this program; if not, write to the                         ;
  18 ;   Free Software Foundation, Inc.,                                       ;
  19 ;   51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA              ;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 ;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2)))
  23 (declaim (optimize (speed 0) (safety 2) (space 0) (debug 2)))
  24
  25 (in-package :io.multiplex)
  26
  27 ;;;;
  28 ;;;; Type definitions
  29 ;;;;
  30
  31 (deftype event-type ()
  32   '(member :read :write :except :error))
  33
  34 ;;;
  35 ;;; FD Entry
  36 ;;;
  37 (defstruct (fd-entry
  38              (:constructor make-fd-entry (fd read-handlers write-handlers
  39                                           except-handlers error-handlers))
  40              (:copier nil))
  41   (fd 0 :type et:select-file-descriptor)
  42   (read-handlers   nil :type list)
  43   (write-handlers  nil :type list)
  44   (except-handlers nil :type list)
  45   (error-handlers  nil :type list))
  46
  47 (defun fd-entry-handler-list (fd-entry event-type)
  48   (check-type fd-entry fd-entry)
  49   (check-type event-type event-type)
  50   (case event-type
  51     (:read (fd-entry-read-handlers fd-entry))
  52     (:write (fd-entry-write-handlers fd-entry))
  53     (:except (fd-entry-except-handlers fd-entry))
  54     (:error (fd-entry-error-handlers fd-entry))))
  55
  56 (defun (setf fd-entry-handler-list) (handler-list fd-entry event-type)
  57   (check-type fd-entry fd-entry)
  58   (check-type event-type event-type)
  59   (case event-type
  60     (:read (setf (fd-entry-read-handlers fd-entry) handler-list))
  61     (:write (setf (fd-entry-write-handlers fd-entry) handler-list))
  62     (:except (setf (fd-entry-except-handlers fd-entry) handler-list))
  63     (:error (setf (fd-entry-error-handlers fd-entry) handler-list))))
  64
  65 (defun fd-entry-empty-p (fd-entry)
  66   (not (or (fd-entry-read-handlers fd-entry)
  67            (fd-entry-write-handlers fd-entry)
  68            (fd-entry-except-handlers fd-entry)
  69            (fd-entry-error-handlers fd-entry))))
  70
  71 ;;;
  72 ;;; Handler
  73 ;;;
  74 (defstruct (handler
  75              (:constructor make-handler (event-type function))
  76              (:copier nil))
  77   (event-type nil :type (or null event-type))
  78   (function   nil :type (or null function)))
  79
  80 ;;;
  81 ;;; Multiplexer
  82 ;;;
  83 (defclass multiplexer ()
  84   ((fd-entries :initform (make-hash-table :test 'eql) :reader fd-entries)
  85    (fd-set-size :initform 0)))
  86
  87 (defmethod initialize-instance :after ((mux multiplexer)
  88                                        &key size)
  89   (setf (slot-value mux 'fd-set-size) size))
  90
  91 (defgeneric fd-entry (mux fd)
  92   (:method ((mux multiplexer) fd)
  93     (gethash fd (fd-entries mux))))
  94
  95 (defgeneric monitor-fd (mux fd-entry)
  96   (:method-combination progn :most-specific-last))
  97
  98 (defgeneric update-fd (mux fd-entry)
  99   (:method-combination progn :most-specific-last)
 100   (:method progn ((mux multiplexer) fd-entry)
 101     t))
 102
 103 (defgeneric add-fd-handler (mux fd event-type function)
 104   (:method-combination progn :most-specific-last))
 105
 106 (defgeneric unmonitor-fd (mux fd)
 107   (:method-combination progn :most-specific-first))
 108
 109 (defgeneric remove-fd-handler (mux fd handler)
 110   (:method-combination progn :most-specific-first))
 111
 112 (defgeneric serve-fd-events (mux &key timeout))
 113
 114 (defgeneric close-multiplexer (mux)
 115   (:method ((mux multiplexer))
 116     t))
 117
 118 (eval-when (:compile-toplevel :load-toplevel :execute)
 119   (defvar *available-multiplexers* nil)
 120   (defvar *best-multiplexer* nil))
 121
 122 (defmacro define-multiplexer (name priority superclasses slots &rest options)
 123   `(progn
 124      (defclass ,name ,superclasses ,slots ,@options)
 125      (pushnew (cons ,priority ',name)
 126               *available-multiplexers*)))
 127
 128 (defun fd-open-p (fd)
 129   (with-foreign-object (stat 'et:stat)
 130     (handler-case
 131         (progn (et:stat fd stat) t)
 132       (et:unix-error-badf (err)
 133         (declare (ignore err))
 134         nil))))
 135
 136 (defun finalize-object-closing-fd (object fd)
 137   (finalize object #'(lambda () (et:close fd))))
 138
 139
 140
 141 ;;;;
 142 ;;;; Base methods
 143 ;;;;
 144
 145 (defmethod monitor-fd progn ((mux multiplexer) fd-entry)
 146   (let ((fd (fd-entry-fd fd-entry)))
 147     (setf (gethash fd (fd-entries mux)) fd-entry)
 148     (values fd)))
 149
 150 (defmethod add-fd-handler progn ((mux multiplexer)
 151                                  fd event-type function)
 152   (check-type event-type event-type)
 153
 154   (let ((current-entry (fd-entry mux fd))
 155         (handler (make-handler event-type function)))
 156     (if current-entry
 157         (push handler (fd-entry-handler-list current-entry event-type))
 158         (progn
 159           (setf current-entry (make-fd-entry fd nil nil nil nil))
 160           (push handler (fd-entry-handler-list current-entry event-type))
 161           (monitor-fd mux current-entry)))
 162     (values handler)))
 163
 164 (defmethod unmonitor-fd progn ((mux multiplexer) fd)
 165   (remhash fd (fd-entries mux))
 166   (values fd))
 167
 168 (defmethod remove-fd-handler progn ((mux multiplexer)
 169                                     fd handler)
 170   (check-type (handler-event-type handler) event-type)
 171
 172   (let ((event-type (handler-event-type handler))
 173         (current-entry (fd-entry mux fd)))
 174     (when current-entry
 175       (setf (fd-entry-handler-list current-entry event-type)
 176             (delete handler (fd-entry-handler-list current-entry event-type) :test 'eq))
 177       (when (fd-entry-empty-p current-entry)
 178         (unmonitor-fd mux fd))))
 179   (values mux))
 180
 181 ;; if there are handlers installed save them and restore them at the end
 182 (defmacro with-fd-handler ((mux fd event-type function)
 183                            &body body)
 184   (let ((handler (gensym "HANDLER-")))
 185     `(let (,handler)
 186        (unwind-protect
 187             (progn
 188               (setf ,handler (add-fd-handler ,mux ,fd ,event-type ,function))
 189               ,@body)
 190          (when ,handler
 191            (remove-fd-handler ,mux ,fd ,handler))))))
 192
 193
 194 ;;;;
 195 ;;;; Other utilities
 196 ;;;;
 197
 198 ;;; Break a real timeout into seconds and microseconds.
 199 (defun decode-timeout (timeout)
 200   (typecase timeout
 201     (integer (values timeout 0))
 202     (null (values 0 0))
 203     (real
 204      (multiple-value-bind (q r) (truncate (coerce timeout 'single-float))
 205        (declare (type unsigned-byte q) (single-float r))
 206        (values q (the (values unsigned-byte t) (truncate (* r 1f6))))))
 207     (t
 208      (error "Timeout is not a real number or NIL: ~S" timeout))))
 209
 210 (defun wait-until-fd-usable (mux fd event-type &optional timeout)
 211   (let (status)
 212     (flet ((callback (fd type)
 213              (cond ((member type '(:error :except))
 214                     (setf status :except))
 215                    ((eql type event-type)
 216                     (setf status :ok)))))
 217       (with-fd-handler (mux fd event-type #'callback)
 218         (loop
 219            (serve-fd-events mux :timeout timeout)
 220            (when status
 221              (return-from wait-until-fd-usable status)))))))