io-multiplex/select.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 (defclass select-multiplex-interface (multiplex-interface) ())
  28
  29 (defconstant +select-priority+ 3)
  30
  31 (define-iomux-interface select-multiplex-interface +select-priority+)
  32
  33 (defun select-setup-masks (select-iface read-fds write-fds except-fds)
  34   (declare (type et:foreign-pointer
  35                  read-fds write-fds except-fds))
  36
  37   (et:fd-zero read-fds)
  38   (et:fd-zero write-fds)
  39   (et:fd-zero except-fds)
  40
  41   (let ((max-fd 0))
  42     (with-hash-table-iterator (next-item (fd-handlers select-iface))
  43       (multiple-value-bind (item-p fd handler) (next-item)
  44         (when item-p
  45           (when (> fd max-fd)
  46             (setf max-fd fd))
  47           (when (handler-read-func handler)
  48             (et:fd-set fd read-fds))
  49           (when (handler-write-func handler)
  50             (et:fd-set fd write-fds))
  51           (when (handler-except-func handler)
  52             (et:fd-set fd except-fds)))))
  53     max-fd))
  54
  55 (defmethod serve-fd-events ((interface select-multiplex-interface) &key)
  56   (with-foreign-objects ((read-fds 'et:fd-set)
  57                          (write-fds 'et:fd-set)
  58                          (except-fds 'et:fd-set))
  59
  60     (let ((max-fd (select-setup-masks
  61                    interface
  62                    read-fds
  63                    write-fds
  64                    except-fds)))
  65
  66       (with-slots (fd-handlers) interface
  67         (tagbody
  68          :start
  69            (handler-case
  70                (et:select (1+ max-fd)
  71                           read-fds
  72                           write-fds
  73                           except-fds
  74                           (null-pointer))
  75              (et:unix-error-intr (err)
  76                (declare (ignore err))
  77                (go :start))))
  78
  79         (with-hash-table-iterator (next-item fd-handlers)
  80           (multiple-value-bind (item-p fd handler) (next-item)
  81             (when item-p
  82               (if (fd-open-p fd)
  83                   (progn
  84                     (when (and (et:fd-isset fd except-fds)
  85                                (handler-except-func handler))
  86                       (funcall (handler-except-func handler) fd :except))
  87                     (when (and (et:fd-isset fd read-fds)
  88                                (handler-read-func handler))
  89                       (funcall (handler-read-func handler) fd :read))
  90                     (when (and (et:fd-isset fd write-fds)
  91                                (handler-write-func handler))
  92                       (funcall (handler-write-func handler) fd :write)))
  93                   ;; TODO: add better error handling
  94                   (error "Handler for bad fd is present: ~A " fd))))))))
  95   (values interface))