src/multiplex/backend-select.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- select(2) multiplexer implementation.
   4 ;;;
   5
   6 (in-package :iolib.multiplex)
   7
   8 (defconstant +select-priority+ 3)
   9
  10 (define-multiplexer select-multiplexer +select-priority+ (multiplexer)
  11   ((max-fd :initform 0
  12            :accessor max-fd-of)
  13    (read-fd-set :initform (allocate-fd-set)
  14                 :reader read-fd-set-of)
  15    (write-fd-set :initform (allocate-fd-set)
  16                  :reader write-fd-set-of)
  17    (except-fd-set :initform (allocate-fd-set)
  18                   :reader except-fd-set-of))
  19   (:default-initargs :fd-limit (1- isys:fd-setsize)))
  20
  21 (defun allocate-fd-set ()
  22   (let ((fd-set (foreign-alloc 'isys:fd-set)))
  23     (isys:fd-zero fd-set)
  24     fd-set))
  25
  26 (defmethod print-object ((mux select-multiplexer) stream)
  27   (print-unreadable-object (mux stream :type nil :identity nil)
  28     (format stream "select(2) multiplexer")))
  29
  30 (defmethod close-multiplexer progn ((mux select-multiplexer))
  31   (with-slots ((rs read-fd-set)
  32                (ws write-fd-set)
  33                (es except-fd-set))
  34       mux
  35     (unless (null-pointer-p rs) (foreign-free rs))
  36     (unless (null-pointer-p ws) (foreign-free ws))
  37     (unless (null-pointer-p es) (foreign-free es))
  38     (setf rs nil ws nil es nil)))
  39
  40 (defun find-max-fd (fd-set end)
  41   (loop :for i :downfrom end :to 0
  42         :do (when (isys:fd-isset i fd-set) (return* i)))
  43   ;; this means no fd <= end is set
  44   -1)
  45
  46 (defun recalc-fd-masks (mux fd read write)
  47   (with-accessors ((rs read-fd-set-of)
  48                    (ws write-fd-set-of)
  49                    (es except-fd-set-of)
  50                    (max-fd max-fd-of))
  51       mux
  52     (cond (read
  53            (isys:fd-set fd rs)
  54            (isys:fd-set fd es))
  55           (t
  56            (isys:fd-clr fd rs)
  57            (isys:fd-clr fd es)))
  58     (if write
  59         (isys:fd-set fd ws)
  60         (isys:fd-clr fd ws))
  61     (let ((end (max max-fd fd)))
  62       (setf max-fd (max (find-max-fd rs end)
  63                         (find-max-fd ws end))))
  64     t))
  65
  66 (defmethod monitor-fd ((mux select-multiplexer) fd-entry)
  67   (recalc-fd-masks mux (fd-entry-fd fd-entry)
  68                    (fd-entry-read-handler fd-entry)
  69                    (fd-entry-write-handler fd-entry)))
  70
  71 (defmethod update-fd ((mux select-multiplexer) fd-entry event-type edge-change)
  72   (declare (ignore event-type edge-change))
  73   (recalc-fd-masks mux (fd-entry-fd fd-entry)
  74                    (fd-entry-read-handler fd-entry)
  75                    (fd-entry-write-handler fd-entry)))
  76
  77 (defmethod unmonitor-fd ((mux select-multiplexer) fd-entry)
  78   (recalc-fd-masks mux (fd-entry-fd fd-entry) nil nil))
  79
  80 (defmethod harvest-events ((mux select-multiplexer) timeout)
  81   (with-accessors ((rs read-fd-set-of)
  82                    (ws write-fd-set-of)
  83                    (es except-fd-set-of)
  84                    (max-fd max-fd-of))
  85       mux
  86     ;; if there are no fds set and timeout is NULL
  87     ;; select() blocks forever
  88     (when (and (minusp max-fd)
  89                (null timeout))
  90       (warn "Non fds to monitor and no timeout set !")
  91       (return* nil))
  92     (with-foreign-objects ((read-fds 'isys:fd-set)
  93                            (write-fds 'isys:fd-set)
  94                            (except-fds 'isys:fd-set))
  95       (isys:copy-fd-set rs read-fds)
  96       (isys:copy-fd-set ws write-fds)
  97       (isys:copy-fd-set es except-fds)
  98       (handler-case
  99           (with-foreign-object (ts 'isys:timespec)
 100             (isys:repeat-upon-condition-decreasing-timeout
 101                 ((isys:eintr) tmp-timeout timeout)
 102               (when tmp-timeout
 103                 (timeout->timespec tmp-timeout ts))
 104               (isys:select (1+ max-fd)
 105                            read-fds
 106                            write-fds
 107                            except-fds
 108                            (if tmp-timeout ts (null-pointer)))))
 109         (isys:ebadf ()
 110           (return* (harvest-select-fd-errors rs ws max-fd))))
 111       (harvest-select-events max-fd read-fds write-fds except-fds))))
 112
 113 (defun harvest-select-events (max-fd read-fds write-fds except-fds)
 114   (loop :for fd :upto max-fd
 115         :for event := () :then ()
 116         :when (or (isys:fd-isset fd read-fds)
 117                   (isys:fd-isset fd except-fds)) :do (push :read event)
 118         :when (isys:fd-isset fd write-fds) :do (push :write event)
 119         :when event :collect (list fd event)))
 120
 121 ;;; FIXME: I don't know whether on all *nix systems select()
 122 ;;; returns EBADF only when a given FD present in some fd-set
 123 ;;; is closed(as the POSIX docs say) or if some other kinds of
 124 ;;; errors are reported too(as the Linux manpages seem to suggest)
 125 (defun fd-error-p (fd)
 126   (not (isys:fd-open-p fd)))
 127
 128 (defun harvest-select-fd-errors (read-fds write-fds max-fd)
 129   (loop :for fd :upto max-fd
 130         :when (and (or (isys:fd-isset fd read-fds)
 131                        (isys:fd-isset fd write-fds))
 132                    (fd-error-p fd))
 133         :collect (list fd (list :error))))