1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- select(2) multiplexer implementation.
6 (in-package :io.multiplex
)
8 (defconstant +select-priority
+ 3)
10 (define-multiplexer select-multiplexer
+select-priority
+ (multiplexer)
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- isys
:fd-setsize
)))
21 (defun allocate-fd-set ()
22 (isys:%sys-fd-zero
(foreign-alloc 'isys
:fd-set
)))
24 (defmethod print-object ((mux select-multiplexer
) stream
)
25 (print-unreadable-object (mux stream
:type nil
:identity nil
)
26 (format stream
"select(2) multiplexer")))
28 (defmethod close-multiplexer progn
((mux select-multiplexer
))
29 (with-slots ((rs read-fd-set
)
33 (unless (null-pointer-p rs
) (foreign-free rs
))
34 (unless (null-pointer-p ws
) (foreign-free ws
))
35 (unless (null-pointer-p es
) (foreign-free es
))
36 (setf rs nil ws nil es nil
)))
38 (defun find-max-fd (fd-set end
)
39 (loop :for i
:downfrom end
:to
0
40 :do
(when (isys:%sys-fd-isset i fd-set
) (return* i
)))
41 ;; this means no fd <= end is set
44 (defun recalc-fd-masks (mux fd read write
)
45 (with-accessors ((rs read-fd-set-of
)
51 (isys:%sys-fd-set fd rs
)
52 (isys:%sys-fd-set fd es
))
54 (isys:%sys-fd-clr fd rs
)
55 (isys:%sys-fd-clr fd es
)))
57 (isys:%sys-fd-set fd ws
)
58 (isys:%sys-fd-clr fd ws
))
59 (setf max-fd
(max (find-max-fd rs fd
)
63 (defmethod monitor-fd ((mux select-multiplexer
) fd-entry
)
64 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
65 (fd-entry-read-handler fd-entry
)
66 (fd-entry-write-handler fd-entry
)))
68 (defmethod update-fd ((mux select-multiplexer
) fd-entry event-type edge-change
)
69 (declare (ignore event-type edge-change
))
70 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
71 (fd-entry-read-handler fd-entry
)
72 (fd-entry-write-handler fd-entry
)))
74 (defmethod unmonitor-fd ((mux select-multiplexer
) fd-entry
)
75 (recalc-fd-masks mux
(fd-entry-fd fd-entry
) nil nil
))
77 (defmethod harvest-events ((mux select-multiplexer
) timeout
)
78 (with-accessors ((rs read-fd-set-of
)
83 ;; if there are no fds set and timeout is NULL
84 ;; select() blocks forever
85 (when (and (minusp max-fd
)
87 (warn "Non fds to monitor and no timeout set !")
89 (with-foreign-objects ((read-fds 'isys
:fd-set
)
90 (write-fds 'isys
:fd-set
)
91 (except-fds 'isys
:fd-set
))
92 (isys:%sys-copy-fd-set rs read-fds
)
93 (isys:%sys-copy-fd-set ws write-fds
)
94 (isys:%sys-copy-fd-set es except-fds
)
96 (with-foreign-object (tv 'isys
:timeval
)
97 (isys:repeat-upon-condition-decreasing-timeout
98 ((isys:eintr
) tmp-timeout timeout
)
100 (timeout->timeval tmp-timeout tv
))
101 (isys:%sys-select
(1+ max-fd
)
105 (if tmp-timeout tv
(null-pointer)))))
107 (return* (harvest-select-fd-errors rs ws max-fd
))))
108 (harvest-select-events max-fd read-fds write-fds except-fds
))))
110 (defun harvest-select-events (max-fd read-fds write-fds except-fds
)
111 (loop :for fd
:upto max-fd
112 :for event
:= () :then
()
113 :when
(or (isys:%sys-fd-isset fd read-fds
)
114 (isys:%sys-fd-isset fd except-fds
)) :do
(push :read event
)
115 :when
(isys:%sys-fd-isset fd write-fds
) :do
(push :write event
)
116 :when event
:collect
(list fd event
)))
118 ;;; FIXME: I don't know whether on all *nix systems select()
119 ;;; returns EBADF only when a given FD present in some fd-set
120 ;;; is closed(as the POSIX docs say) or if some other kinds of
121 ;;; errors are reported too(as the Linux manpages seem to suggest)
122 (defun fd-error-p (fd)
123 (not (isys:%sys-fd-open-p fd
)))
125 (defun harvest-select-fd-errors (read-fds write-fds max-fd
)
126 (loop :for fd
:upto max-fd
127 :when
(and (or (isys:%sys-fd-isset fd read-fds
)
128 (isys:%sys-fd-isset fd write-fds
))
130 :collect
(cons fd
:error
)))