io.multiplex/select.lisp

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