1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ; Copyright (C) 2006,2007 by Stelian Ionescu ;
6 ; This program is free software; you can redistribute it and/or modify ;
7 ; it under the terms of the GNU General Public License as published by ;
8 ; the Free Software Foundation; either version 2 of the License, or ;
9 ; (at your option) any later version. ;
11 ; This program is distributed in the hope that it will be useful, ;
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of ;
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;
14 ; GNU General Public License for more details. ;
16 ; You should have received a copy of the GNU General Public License ;
17 ; along with this program; if not, write to the ;
18 ; Free Software Foundation, Inc., ;
19 ; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ;
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 (in-package :io.multiplex
)
24 (defconstant +select-priority
+ 3)
27 (define-multiplexer select-multiplexer
+select-priority
+ (multiplexer)
30 (read-fd-set :initform
(allocate-fd-set)
31 :reader read-fd-set-of
)
32 (write-fd-set :initform
(allocate-fd-set)
33 :reader write-fd-set-of
)
34 (except-fd-set :initform
(allocate-fd-set)
35 :reader except-fd-set-of
))
36 (:default-initargs
:fd-limit
(1- et
:fd-setsize
)))
39 (defun allocate-fd-set ()
40 (et:fd-zero
(foreign-alloc 'et
:fd-set
)))
43 (defmethod print-object ((mux select-multiplexer
) stream
)
44 (print-unreadable-object (mux stream
:type nil
:identity nil
)
45 (format stream
"select(2) multiplexer")))
48 (defmethod close-multiplexer progn
((mux select-multiplexer
))
49 (foreign-free (read-fd-set-of mux
))
50 (foreign-free (write-fd-set-of mux
))
51 (foreign-free (except-fd-set-of mux
))
52 (mapc #'(lambda (slot)
53 (slot-makunbound mux slot
))
54 '(max-fd read-fd-set write-fd-set except-fd-set
)))
57 (defun find-max-fd (fd-set end
)
58 (loop :for i
:downfrom end
:to
0
59 :do
(when (et:fd-isset i fd-set
)
60 (return-from find-max-fd i
)))
61 ;; this means no fd <= end is set
65 (defun recalc-fd-masks (mux fd read write
)
66 (with-accessors ((rs read-fd-set-of
) (ws write-fd-set-of
)
67 (es except-fd-set-of
) (max-fd max-fd-of
)) mux
78 (setf max-fd
(max (find-max-fd rs fd
)
83 (defmethod monitor-fd ((mux select-multiplexer
) fd-entry
)
84 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
85 (not (queue-empty-p (fd-entry-read-events fd-entry
)))
86 (not (queue-empty-p (fd-entry-write-events fd-entry
)))))
89 (defmethod update-fd ((mux select-multiplexer
) fd-entry
)
90 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
91 (not (queue-empty-p (fd-entry-read-events fd-entry
)))
92 (not (queue-empty-p (fd-entry-write-events fd-entry
)))))
95 (defmethod unmonitor-fd ((mux select-multiplexer
) fd-entry
)
96 (recalc-fd-masks mux
(fd-entry-fd fd-entry
) nil nil
))
99 (defmethod harvest-events ((mux select-multiplexer
) timeout
)
100 (with-accessors ((rs read-fd-set-of
) (ws write-fd-set-of
)
101 (es except-fd-set-of
) (max-fd max-fd-of
)) mux
102 ;; if there are no fds set and timeout is NULL
103 ;; select() blocks forever
104 (when (and (minusp max-fd
)
106 (warn "Non fds to monitor and no timeout set !")
107 (return-from harvest-events nil
))
109 (with-foreign-objects ((read-fds 'et
:fd-set
)
110 (write-fds 'et
:fd-set
)
111 (except-fds 'et
:fd-set
))
112 (et:copy-fd-set rs read-fds
)
113 (et:copy-fd-set ws write-fds
)
114 (et:copy-fd-set es except-fds
)
117 (with-foreign-object (tv 'et
:timeval
)
119 (timeout->timeval timeout tv
))
120 (et:select
(1+ max-fd
)
124 (if timeout tv
(null-pointer))))
125 (et:unix-error-badf
(err)
126 (declare (ignore err
))
127 (return-from harvest-events
128 (harvest-select-fd-errors rs ws max-fd
))))
130 (harvest-select-events max-fd read-fds write-fds except-fds
))))
133 (defun harvest-select-events (max-fd read-fds write-fds except-fds
)
134 (loop :for fd
:upto max-fd
135 :for event
:= () :then
()
136 :when
(or (et:fd-isset fd read-fds
)
137 (et:fd-isset fd except-fds
)) :do
(push :read event
)
138 :when
(et:fd-isset fd write-fds
) :do
(push :write event
)
139 :when event
:collect
(list fd event
)))
142 ;; FIXME: I don't know whether on all *nix systems select()
143 ;; returns EBADF only when a given FD present in some fd-set
144 ;; is closed(as the POSIX docs say) or if some other kinds of
145 ;; errors are reported too(as the Linux manpages seem to suggest)
146 (defun fd-error-p (fd)
147 (not (et:fd-open-p fd
)))
149 (defun harvest-select-fd-errors (read-fds write-fds max-fd
)
150 (loop :for fd
:upto max-fd
151 :when
(and (or (et:fd-isset fd read-fds
)
152 (et:fd-isset fd write-fds
))
154 :collect
(cons fd
:error
)))