io-multiplex/select.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 (defconstant +select-priority+ 3)
  28
  29 (define-multiplexer select-multiplexer +select-priority+
  30   (multiplexer) ())
  31
  32 (defun select-setup-masks (select-iface read-fds write-fds except-fds)
  33   (declare (type et:foreign-pointer
  34                  read-fds write-fds except-fds))
  35
  36   (et:fd-zero read-fds)
  37   (et:fd-zero write-fds)
  38   (et:fd-zero except-fds)
  39
  40   (let ((max-fd 0))
  41     (with-hash-table-iterator (next-item (fd-entries select-iface))
  42       (multiple-value-bind (item-p fd fd-entry) (next-item)
  43         (when item-p
  44           (when (> fd max-fd)
  45             (setf max-fd fd))
  46           (when (fd-entry-read-handlers fd-entry)
  47             (et:fd-set fd read-fds))
  48           (when (fd-entry-write-handlers fd-entry)
  49             (et:fd-set fd write-fds))
  50           (when (fd-entry-except-handlers fd-entry)
  51             (et:fd-set fd except-fds)))))
  52     max-fd))
  53
  54 (defun handle-select-fd-errors (select-iface)
  55   (let ((current-entries (fd-entries select-iface))
  56         invalid-fd-entries)
  57     (with-hash-table-iterator (next-item current-entries)
  58       (multiple-value-bind (item-p fd fd-entry) (next-item)
  59         (when (and item-p (not (fd-open-p fd)))
  60           (push fd-entry invalid-fd-entries))))
  61     (dolist (fd-entry invalid-fd-entries)
  62       (let ((fd (fd-entry-fd fd-entry))
  63             (error-handlers (fd-entry-error-handlers fd-entry)))
  64         (if error-handlers
  65             (dolist (error-handler error-handlers)
  66               (funcall (handler-function error-handler) fd :error))
  67             (remhash fd current-entries))))))
  68
  69 (defmethod serve-fd-events ((mux select-multiplexer)
  70                             &key timeout)
  71   (with-foreign-objects ((read-fds 'et:fd-set)
  72                          (write-fds 'et:fd-set)
  73                          (except-fds 'et:fd-set))
  74
  75     (let ((max-fd (select-setup-masks
  76                    mux
  77                    read-fds
  78                    write-fds
  79                    except-fds))
  80           (count 0))
  81
  82       ;; this means there are no valid fds to serve
  83       ;; but with no fds active select() blocks forever(at least on Linux)
  84       (when (zerop max-fd)
  85         (return-from serve-fd-events 0))
  86
  87       (with-accessors ((fd-entries fd-entries)) mux
  88         (tagbody
  89          :start
  90            (handler-case
  91                (with-foreign-object (to 'et:timeval)
  92                  (when timeout
  93                    (progn
  94                      (et:memset to 0 #.(foreign-type-size 'et:timeval))
  95                      (multiple-value-bind
  96                            (to-sec to-usec) (decode-timeout timeout)
  97                        (setf (foreign-slot-value to 'et:timeval 'et:tv-sec) to-sec)
  98                        (setf (foreign-slot-value to 'et:timeval 'et:tv-usec) to-usec))))
  99                  (et:select (1+ max-fd)
 100                             read-fds
 101                             write-fds
 102                             except-fds
 103                             (if timeout to (null-pointer))))
 104              (et:unix-error-intr (err)
 105                (declare (ignore err))
 106                (go :start))
 107              (et:unix-error-badf (err)
 108                (declare (ignore err))
 109                (handle-select-fd-errors mux))))
 110
 111         (with-hash-table-iterator (next-item fd-entries)
 112           (multiple-value-bind (item-p fd fd-entry) (next-item)
 113             (when item-p
 114               (if (fd-open-p fd)
 115                   (progn
 116                     (incf count)
 117                     (when (and (et:fd-isset fd except-fds)
 118                                (fd-entry-except-handlers fd-entry))
 119                       (dolist (except-handler (fd-entry-except-handlers fd-entry))
 120                         (funcall (handler-function except-handler) fd :except)))
 121                     (when (and (et:fd-isset fd read-fds)
 122                                (fd-entry-read-handlers fd-entry))
 123                       (dolist (read-handler (fd-entry-read-handlers fd-entry))
 124                         (funcall (handler-function read-handler) fd :read)))
 125                     (when (and (et:fd-isset fd write-fds)
 126                                (fd-entry-write-handlers fd-entry))
 127                       (dolist (write-handler (fd-entry-write-handlers fd-entry))
 128                         (funcall (handler-function write-handler) fd :write))))
 129                   ;; TODO: add better error handling
 130                   (error "Handler for bad fd is present: ~A " fd)))))
 131         (return-from serve-fd-events count)))))