io-multiplex/kqueue.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :io.multiplex)
  23
  24 (defconstant +kqueue-priority+ 1)
  25
  26
  27 (define-multiplexer kqueue-multiplexer +kqueue-priority+ (multiplexer)
  28   ())
  29
  30
  31 (defmethod print-object ((mux kqueue-multiplexer) stream)
  32   (print-unreadable-object (mux stream :type nil :identity nil)
  33     (format stream "kqueue(2) multiplexer")))
  34
  35
  36 (defvar *kqueue-max-events* 200)
  37
  38
  39 (defmethod initialize-instance :after ((mux kqueue-multiplexer) &key)
  40   (setf (slot-value mux 'fd) (et:kqueue)))
  41
  42
  43 (defun do-kqueue-event-request (kqueue-fd fd-entry filter request-type)
  44   (let ((fd (fd-entry-fd fd-entry)))
  45     (with-foreign-object (kev 'et:kevent)
  46       (et:memset kev 0 et:size-of-kevent)
  47       (et:ev-set kev fd filter request-type 0 0 (null-pointer))
  48       (et:kevent kqueue-fd
  49                  kev 1
  50                  (null-pointer) 0
  51                  (null-pointer)))))
  52
  53
  54 (defun calc-kqueue-monitor-filter (fd-entry)
  55   (if (queue-empty-p (fd-entry-read-events fd-entry))
  56       et:evfilt-write
  57       et:evfilt-read))
  58
  59
  60 (defmethod monitor-fd ((mux kqueue-multiplexer) fd-entry)
  61   (assert fd-entry)
  62   (handler-case
  63       (do-kqueue-event-request (fd-of mux) fd-entry
  64                                (calc-kqueue-monitor-filter fd-entry)
  65                                et:ev-add)
  66     (et:ebadf ()
  67       (warn "FD ~A is invalid, cannot monitor it." (fd-entry-fd fd-entry)))))
  68
  69
  70 (defun calc-kqueue-update-filter-and-flags (edge-change)
  71   (case edge-change
  72     (:read-add  (values et:evfilt-read et:ev-add))
  73     (:read-del  (values et:evfilt-read et:ev-delete))
  74     (:write-add (values et:evfilt-write et:ev-add))
  75     (:write-del (values et:evfilt-write et:ev-delete))))
  76
  77
  78 (defmethod update-fd ((mux kqueue-multiplexer) fd-entry)
  79   (assert fd-entry)
  80   (handler-case
  81       (multiple-value-bind (filter change)
  82           (calc-kqueue-update-filter-and-flags (fd-entry-edge-change fd-entry))
  83         (do-kqueue-event-request (fd-of mux) fd-entry filter change))
  84     (et:ebadf ()
  85       (warn "FD ~A is invalid, cannot update its status." (fd-entry-fd fd-entry)))
  86     (et:enoent ()
  87       (warn "FD ~A was not monitored, cannot update its status." (fd-entry-fd fd-entry)))))
  88
  89
  90 (defun calc-kqueue-unmonitor-filter (fd-entry)
  91   (if (queue-empty-p (fd-entry-read-events fd-entry))
  92       et:evfilt-read
  93       et:evfilt-write))
  94
  95
  96 (defmethod unmonitor-fd ((mux kqueue-multiplexer) fd-entry)
  97   (handler-case
  98       (do-kqueue-event-request (fd-of mux) fd-entry
  99                                (calc-kqueue-unmonitor-filter fd-entry)
 100                                et:ev-delete)
 101     (et:ebadf ()
 102       (warn "FD ~A is invalid, cannot unmonitor it." (fd-entry-fd fd-entry)))
 103     (et:enoent ()
 104       (warn "FD ~A was not monitored, cannot unmonitor it." (fd-entry-fd fd-entry)))))
 105
 106
 107 (defmethod harvest-events ((mux kqueue-multiplexer) timeout)
 108   (with-foreign-objects ((events 'et:kevent *kqueue-max-events*)
 109                          (ts 'et:timespec))
 110     (et:memset events 0 (* *kqueue-max-events* et:size-of-kevent))
 111     (let (ready-fds)
 112       (et:repeat-upon-condition-decreasing-timeout ((et:eintr)
 113                                                     tmp-timeout timeout)
 114         (when tmp-timeout
 115           (timeout->timespec tmp-timeout ts))
 116         (setf ready-fds
 117               (et:kevent (fd-of mux) (null-pointer) 0
 118                          events *kqueue-max-events*
 119                          (if tmp-timeout ts (null-pointer)))))
 120       (macrolet ((kevent-slot (slot-name)
 121                    `(foreign-slot-value (mem-aref events 'et:kevent i)
 122                                         'et:kevent ',slot-name)))
 123         (loop
 124            :for i :below ready-fds
 125            :for fd := (kevent-slot et:ident)
 126            :for flags := (kevent-slot et:flags)
 127            :for filter := (kevent-slot et:filter)
 128            :for data := (kevent-slot et:data)
 129            :for kqueue-event := (make-kqueue-event fd flags filter data)
 130            :when kqueue-event :collect kqueue-event)))))
 131
 132
 133 ;; TODO: do something with DATA
 134 (defun make-kqueue-event (fd flags filter data)
 135   (declare (ignore data))
 136   (let ((event ()))
 137     (case filter
 138       (#.et:evfilt-write (push :write event))
 139       (#.et:evfilt-read  (push :read event)))
 140     (flags-case flags
 141 ;; TODO: check what exactly EV_EOF means
 142 ;;       (et:ev-eof   (pushnew :read event))
 143       (et:ev-error (push :error event)))
 144     (when event
 145       (list fd event))))