1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- select(2) multiplexer implementation.
6 (in-package :iolib.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: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: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
)
59 (let ((end (max max-fd fd
)))
60 (setf max-fd
(max (find-max-fd rs end
)
61 (find-max-fd ws end
))))
64 (defmethod monitor-fd ((mux select-multiplexer
) fd-entry
)
65 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
66 (fd-entry-read-handler fd-entry
)
67 (fd-entry-write-handler fd-entry
)))
69 (defmethod update-fd ((mux select-multiplexer
) fd-entry event-type edge-change
)
70 (declare (ignore event-type edge-change
))
71 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
72 (fd-entry-read-handler fd-entry
)
73 (fd-entry-write-handler fd-entry
)))
75 (defmethod unmonitor-fd ((mux select-multiplexer
) fd-entry
)
76 (recalc-fd-masks mux
(fd-entry-fd fd-entry
) nil nil
))
78 (defmethod harvest-events ((mux select-multiplexer
) timeout
)
79 (with-accessors ((rs read-fd-set-of
)
84 ;; if there are no fds set and timeout is NULL
85 ;; select() blocks forever
86 (when (and (minusp max-fd
)
88 (warn "Non fds to monitor and no timeout set !")
90 (with-foreign-objects ((read-fds 'isys
:fd-set
)
91 (write-fds 'isys
:fd-set
)
92 (except-fds 'isys
:fd-set
))
93 (isys:copy-fd-set rs read-fds
)
94 (isys:copy-fd-set ws write-fds
)
95 (isys:copy-fd-set es except-fds
)
97 (with-foreign-object (tv 'isys
:timeval
)
98 (isys:repeat-upon-condition-decreasing-timeout
99 ((isys:eintr
) tmp-timeout timeout
)
101 (timeout->timeval tmp-timeout tv
))
102 (isys:select
(1+ max-fd
)
106 (if tmp-timeout tv
(null-pointer)))))
108 (return* (harvest-select-fd-errors rs ws max-fd
))))
109 (harvest-select-events max-fd read-fds write-fds except-fds
))))
111 (defun harvest-select-events (max-fd read-fds write-fds except-fds
)
112 (loop :for fd
:upto max-fd
113 :for event
:= () :then
()
114 :when
(or (isys:fd-isset fd read-fds
)
115 (isys:fd-isset fd except-fds
)) :do
(push :read event
)
116 :when
(isys:fd-isset fd write-fds
) :do
(push :write event
)
117 :when event
:collect
(list fd event
)))
119 ;;; FIXME: I don't know whether on all *nix systems select()
120 ;;; returns EBADF only when a given FD present in some fd-set
121 ;;; is closed(as the POSIX docs say) or if some other kinds of
122 ;;; errors are reported too(as the Linux manpages seem to suggest)
123 (defun fd-error-p (fd)
124 (not (isys:fd-open-p fd
)))
126 (defun harvest-select-fd-errors (read-fds write-fds max-fd
)
127 (loop :for fd
:upto max-fd
128 :when
(and (or (isys:fd-isset fd read-fds
)
129 (isys:fd-isset fd write-fds
))
131 :collect
(list fd
(list :error
))))