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 'nix
::pollfd
:count count
)))
33 (nix:bzero fds
(* nix
::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 nix
:pollin nix
:pollrdhup nix
:pollpri
)))
49 (when writep
(setf flags
(logior flags nix
:pollout nix
:pollhup
)))
52 (defun set-pollfd-entry (fd-set index fd readp writep
)
53 (with-foreign-slots ((nix::fd nix
::events nix
::revents
)
54 (mem-aref fd-set
'nix
::pollfd index
)
58 nix
::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 'nix
::pollfd
:count new-size
)))
63 (nix:memcpy new-fd-set fd-set
(* size nix
::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 (fd-entry-read-event fd-entry
))
70 (writep (fd-entry-write-event 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 event-type edge-change
)
80 (declare (ignore event-type edge-change
))
81 (let* ((fd (fd-entry-fd fd-entry
))
82 (pos (gethash fd
*pollfd-table
*))
83 (readp (fd-entry-read-event fd-entry
))
84 (writep (fd-entry-write-event fd-entry
)))
85 (with-accessors ((fd-set fd-set-of
)) mux
86 (set-pollfd-entry fd-set pos fd readp writep
))))
88 (defun shrink-pollfd-set (fd-set count size pos
)
89 (let* ((new-size (if (> 5 (- size count
)) (- size
5) size
))
90 (new-fd-set (foreign-alloc 'nix
::pollfd
:count new-size
)))
92 (nix:memcpy new-fd-set fd-set
(* pos nix
::size-of-pollfd
)))
94 (nix:memcpy new-fd-set fd-set
(* (- count pos
) nix
::size-of-pollfd
)))
96 (values new-fd-set new-size
)))
98 (defmethod unmonitor-fd ((mux poll-multiplexer
) fd-entry
)
99 (let* ((fd (fd-entry-fd fd-entry
))
100 (pos (gethash fd
*pollfd-table
*)))
101 (with-accessors ((fd-set fd-set-of
) (size fd-set-size-of
)
102 (count fd-count-of
)) mux
103 (setf (values fd-set size
) (shrink-pollfd-set fd-set
(1- count
) size pos
))
104 (remhash fd
*pollfd-table
*)
107 (defmethod harvest-events ((mux poll-multiplexer
) timeout
)
108 (with-accessors ((fd-set fd-set-of
) (size fd-set-size-of
)
109 (count fd-count-of
)) mux
110 ;; if there are no fds set and timeout is NULL
111 ;; poll() blocks forever
112 (when (and (zerop count
)
114 (warn "Non fds to monitor and no timeout set !")
115 (return-from harvest-events nil
))
116 ;; FIXME: when does poll() return EBADF ?
117 (nix:repeat-upon-condition-decreasing-timeout
118 ((nix:eintr
) tmp-timeout timeout
)
119 (nix:poll fd-set count
(timeout->milisec tmp-timeout
)))
120 (harvest-pollfd-events fd-set count
)))
122 (defun harvest-pollfd-events (fd-set count
)
123 (macrolet ((pollfd-slot (name index
)
124 `(foreign-slot-value (mem-aref fd-set
'nix
::pollfd
,index
)
125 'nix
::pollfd
,name
)))
126 (loop :for i
:below count
128 :for fd
:= (pollfd-slot 'nix
::fd i
)
129 :for revents
:= (pollfd-slot 'nix
::revents i
)
130 :do
(flags-case revents
131 ((nix:pollout nix
:pollhup
) (push :write event
))
132 ((nix:pollin nix
:pollrdhup nix
:pollpri
) (push :read event
))
133 ((nix:pollerr nix
:pollnval
) (push :error event
)))
134 :when event
:collect
(list fd event
))))