1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;; Copyright (C) 2006, 2007 Stelian Ionescu
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
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.
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
22 (in-package :io.multiplex
)
24 (defconstant +poll-priority
+ 2)
26 (define-multiplexer poll-multiplexer
+poll-priority
+ (multiplexer)
27 ((fd-set :initform
(allocate-pollfd-set) :accessor fd-set-of
)
28 (fd-set-size :initform
5 :accessor fd-set-size-of
)
29 (fd-count :initform
0 :accessor fd-count-of
)))
31 (defun allocate-pollfd-set (&optional
(count 5))
32 (let ((fds (foreign-alloc 'et
:pollfd
:count count
)))
33 (et:bzero fds
(* et
:size-of-pollfd count
))
36 (defmethod print-object ((mux poll-multiplexer
) stream
)
37 (print-unreadable-object (mux stream
:type nil
:identity nil
)
38 (format stream
"poll(2) multiplexer")))
40 (defmethod close-multiplexer progn
((mux poll-multiplexer
))
41 (foreign-free (fd-set-of mux
))
42 (setf (fd-set-of mux
) nil
))
44 (defvar *pollfd-table
* (make-hash-table :test
#'eql
))
46 (defun calc-pollfd-flags (readp writep
)
48 (when readp
(setf flags
(logior et
:pollin et
::pollrdhup et
:pollpri
)))
49 (when writep
(setf flags
(logior flags et
:pollout et
:pollhup
)))
52 (defun set-pollfd-entry (fd-set index fd readp writep
)
53 (with-foreign-slots ((et:fd et
:events et
:revents
)
54 (mem-aref fd-set
'et
:pollfd index
)
58 et
:events
(calc-pollfd-flags readp writep
))))
60 (defun extend-pollfd-set (fd-set size
)
61 (let* ((new-size (+ size
5))
62 (new-fd-set (foreign-alloc 'et
:pollfd
:count new-size
)))
63 (et:memcpy new-fd-set fd-set
(* size et
:size-of-pollfd
))
65 (values new-fd-set new-size
)))
67 (defmethod monitor-fd ((mux poll-multiplexer
) fd-entry
)
68 (let ((fd (fd-entry-fd fd-entry
))
69 (readp (not (queue-empty-p (fd-entry-read-events fd-entry
))))
70 (writep (not (queue-empty-p (fd-entry-write-events fd-entry
)))))
71 (with-accessors ((fd-set fd-set-of
) (size fd-set-size-of
)
72 (count fd-count-of
)) mux
74 (setf (values fd-set size
) (extend-pollfd-set fd-set size
)))
75 (set-pollfd-entry fd-set count fd readp writep
)
76 (setf (gethash fd
*pollfd-table
*) count
)
79 (defmethod update-fd ((mux poll-multiplexer
) fd-entry
)
80 (let* ((fd (fd-entry-fd fd-entry
))
81 (pos (gethash fd
*pollfd-table
*))
82 (readp (not (queue-empty-p (fd-entry-read-events fd-entry
))))
83 (writep (not (queue-empty-p (fd-entry-write-events fd-entry
)))))
84 (with-accessors ((fd-set fd-set-of
)) mux
85 (set-pollfd-entry fd-set pos fd readp writep
))))
87 (defun shrink-pollfd-set (fd-set count size pos
)
88 (let* ((new-size (if (> 5 (- size count
)) (- size
5) size
))
89 (new-fd-set (foreign-alloc 'et
:pollfd
:count new-size
)))
91 (et:memcpy new-fd-set fd-set
(* pos et
:size-of-pollfd
)))
93 (et:memcpy new-fd-set fd-set
(* (- count pos
) et
:size-of-pollfd
)))
95 (values new-fd-set new-size
)))
97 (defmethod unmonitor-fd ((mux poll-multiplexer
) fd-entry
)
98 (let* ((fd (fd-entry-fd fd-entry
))
99 (pos (gethash fd
*pollfd-table
*)))
100 (with-accessors ((fd-set fd-set-of
) (size fd-set-size-of
)
101 (count fd-count-of
)) mux
102 (setf (values fd-set size
) (shrink-pollfd-set fd-set
(1- count
) size pos
))
103 (remhash fd
*pollfd-table
*)
106 (defmethod harvest-events ((mux poll-multiplexer
) timeout
)
107 (with-accessors ((fd-set fd-set-of
) (size fd-set-size-of
)
108 (count fd-count-of
)) mux
109 ;; if there are no fds set and timeout is NULL
110 ;; poll() blocks forever
111 (when (and (zerop count
)
113 (warn "Non fds to monitor and no timeout set !")
114 (return-from harvest-events nil
))
115 ;; FIXME: when does poll() return EBADF ?
116 (et:repeat-upon-condition-decreasing-timeout
117 ((et:eintr
) tmp-timeout timeout
)
118 (et:poll fd-set count
(timeout->milisec tmp-timeout
)))
119 (harvest-pollfd-events fd-set count
)))
121 (defun harvest-pollfd-events (fd-set count
)
122 (macrolet ((pollfd-slot (name index
)
123 `(foreign-slot-value (mem-aref fd-set
'et
:pollfd
,index
)
125 (loop :for i
:below count
127 :for fd
:= (pollfd-slot 'et
:fd i
)
128 :for revents
:= (pollfd-slot 'et
:revents i
)
129 :do
(flags-case revents
130 ((et:pollout et
:pollhup
) (push :write event
))
131 ((et:pollin et
::pollrdhup et
:pollpri
) (push :read event
))
132 ((et:pollerr et
:pollnval
) (push :error event
)))
133 :when event
:collect
(list fd event
))))