io-multiplex/common.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006 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 ;;; Class definitions
  29 ;;;
  30
  31 (defstruct (handler
  32              (:constructor make-handler (fd read-func write-func except-func))
  33              (:copier nil))
  34   (fd            0 :type et:select-file-descriptor)
  35   (read-func   nil :type (or function null))
  36   (write-func  nil :type (or function null))
  37   (except-func nil :type (or function null)))
  38
  39 (defclass multiplex-interface ()
  40   ((fd-handlers :initform (make-hash-table :test 'eql) :reader fd-handlers)
  41    (fd-set-size :initform 0)))
  42
  43 (defmethod initialize-instance :after ((interface multiplex-interface)
  44                                        &key size)
  45   (setf (slot-value interface 'fd-set-size) size))
  46
  47 (defgeneric fd-handler (multiplex-interface fd)
  48   (:method ((interface multiplex-interface) fd)
  49     (gethash fd (fd-handlers interface))))
  50
  51 (defgeneric monitor-fd (multiplex-interface handler)
  52   (:method-combination progn :most-specific-last))
  53
  54 (defgeneric modify-fd (multiplex-interface fd
  55                        &key read-handler write-handler except-handler)
  56   (:method-combination progn :most-specific-last))
  57
  58 (defgeneric add-fd-handlers (multiplex-interface fd
  59                              &key read-handler write-handler except-handler)
  60   (:method-combination progn :most-specific-last))
  61
  62 (defgeneric unmonitor-fd (multiplex-interface handler)
  63   (:method-combination progn :most-specific-first))
  64
  65 (defgeneric remove-fd-handlers (multiplex-interface fd
  66                                 &key read write except all)
  67   (:method-combination progn :most-specific-first))
  68
  69 (defgeneric serve-fd-events (multiplex-interface &key))
  70
  71 (defgeneric close-multiplex-interface (multiplex-interface fd)
  72   (:method ((interface multiplex-interface))
  73     t))
  74
  75 (eval-when (:compile-toplevel :load-toplevel :execute)
  76   (defvar *multiplex-available-interfaces* nil)
  77   (defvar *multiplex-best-interface* nil))
  78
  79 (defmacro define-iomux-interface (name priority)
  80   `(pushnew (cons ,priority ',name)
  81             *multiplex-available-interfaces*))
  82
  83 ;; small utility
  84 (defun fd-open-p (fd)
  85   (sb-alien:with-alien ((stat et:stat))
  86     (handler-case
  87         (progn (et:stat fd (sb-alien:addr stat)) t)
  88       (et:unix-error-badf (err)
  89         (declare (ignore err))
  90         nil))))
  91
  92 (defun finalize-object-closing-fd (object fd)
  93   (sb-ext:finalize object #'(lambda () (et:close fd))))
  94
  95
  96
  97 ;;;
  98 ;;; Base methods
  99 ;;;
 100
 101 (defmethod monitor-fd progn ((interface multiplex-interface) handler)
 102   (setf (gethash (handler-fd handler) (fd-handlers interface))
 103         handler)
 104   (values interface))
 105
 106 (defmethod modify-fd progn ((interface multiplex-interface) fd
 107                             &key read-handler write-handler except-handler)
 108   (let ((handler (fd-handler interface fd)))
 109     (setf (handler-read-func   handler) read-handler)
 110     (setf (handler-write-func  handler) write-handler)
 111     (setf (handler-except-func handler) except-handler))
 112   (values interface))
 113
 114 (defmethod add-fd-handlers progn ((interface multiplex-interface) fd
 115                                   &key read-handler write-handler except-handler)
 116   (assert (or read-handler write-handler except-handler))
 117
 118   (let ((current-handler (fd-handler interface fd)))
 119     (if current-handler
 120         (progn
 121           (modify-fd interface fd
 122                      :read-handler   (or read-handler
 123                                          (handler-read-func current-handler))
 124                      :write-handler  (or write-handler
 125                                          (handler-except-func current-handler))
 126                      :except-handler (or except-handler
 127                                          (handler-except-func current-handler))))
 128         (progn
 129           (setf current-handler (make-handler fd read-handler write-handler except-handler))
 130           (monitor-fd interface current-handler))))
 131   (values interface))
 132
 133 (defmethod unmonitor-fd progn ((interface multiplex-interface) handler)
 134   (remhash (handler-fd handler) (fd-handlers interface))
 135   (values interface))
 136
 137 (defmethod remove-fd-handlers progn ((interface multiplex-interface) fd
 138                                      &key read write except all)
 139   (unless all
 140     (assert (or read write except)))
 141
 142   (let ((current-handler (fd-handler interface fd)))
 143     (when current-handler
 144       (if all
 145           (unmonitor-fd interface current-handler)
 146           (progn
 147             (when read   (setf (handler-read-func   current-handler) nil))
 148             (when write  (setf (handler-write-func  current-handler) nil))
 149             (when except (setf (handler-except-func current-handler) nil))
 150             (if (or (handler-read-func   current-handler)
 151                     (handler-write-func  current-handler)
 152                     (handler-except-func current-handler))
 153                 (modify-fd interface fd
 154                            :read-handler   (handler-read-func current-handler)
 155                            :write-handler  (handler-except-func current-handler)
 156                            :except-handler (handler-except-func current-handler))
 157                 (unmonitor-fd interface current-handler))))))
 158   (values interface))
 159
 160 ;; if there are handlers installed save them and restore them at the end
 161 ;; (defmacro with-fd-handlers ((fd &key read-handler write-handler except-handler) &body body)
 162 ;;   (let ((tmp-handler (gensym)))
 163 ;;     `(let ((,tmp-handler (gethash ,fd fd-handlers)))
 164 ;;        (unwind-protect
 165 ;;             (progn
 166 ;;               (when ,tmp-handler
 167 ;;                 (remove-fd-handlers ,fd :all t))
 168 ;;               (add-fd-handlers ,fd :read-handler ,read-handler
 169 ;;                                    :write-handler ,write-handler
 170 ;;                                    :except-handler ,except-handler)
 171 ;;               ,@body)
 172 ;;          (if ,tmp-handler
 173 ;;              (setf (gethash ,fd fd-handlers) ,tmp-handler)
 174 ;;              (remove-fd-handlers ,fd :all t))))))