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- fd-setsize
)))
21 (defun allocate-fd-set ()
22 (fd-zero (foreign-alloc '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 (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
) (ws write-fd-set-of
)
46 (es except-fd-set-of
) (max-fd max-fd-of
)) mux
56 (setf max-fd
(max (find-max-fd rs fd
)
60 (defmethod monitor-fd ((mux select-multiplexer
) fd-entry
)
61 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
62 (fd-entry-read-handler fd-entry
)
63 (fd-entry-write-handler fd-entry
)))
65 (defmethod update-fd ((mux select-multiplexer
) fd-entry event-type edge-change
)
66 (declare (ignore event-type edge-change
))
67 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
68 (fd-entry-read-handler fd-entry
)
69 (fd-entry-write-handler fd-entry
)))
71 (defmethod unmonitor-fd ((mux select-multiplexer
) fd-entry
)
72 (recalc-fd-masks mux
(fd-entry-fd fd-entry
) nil nil
))
74 (defmethod harvest-events ((mux select-multiplexer
) timeout
)
75 (with-accessors ((rs read-fd-set-of
) (ws write-fd-set-of
)
76 (es except-fd-set-of
) (max-fd max-fd-of
)) mux
77 ;; if there are no fds set and timeout is NULL
78 ;; select() blocks forever
79 (when (and (minusp max-fd
)
81 (warn "Non fds to monitor and no timeout set !")
83 (with-foreign-objects ((read-fds 'fd-set
)
86 (copy-fd-set rs read-fds
)
87 (copy-fd-set ws write-fds
)
88 (copy-fd-set es except-fds
)
90 (with-foreign-object (tv 'timeval
)
91 (nix:repeat-upon-condition-decreasing-timeout
92 ((nix:eintr
) tmp-timeout timeout
)
94 (timeout->timeval tmp-timeout tv
))
99 (if tmp-timeout tv
(null-pointer)))))
101 (return* (harvest-select-fd-errors rs ws max-fd
))))
102 (harvest-select-events max-fd read-fds write-fds except-fds
))))
104 (defun harvest-select-events (max-fd read-fds write-fds except-fds
)
105 (loop :for fd
:upto max-fd
106 :for event
:= () :then
()
107 :when
(or (fd-isset fd read-fds
)
108 (fd-isset fd except-fds
)) :do
(push :read event
)
109 :when
(fd-isset fd write-fds
) :do
(push :write event
)
110 :when event
:collect
(list fd event
)))
112 ;;; FIXME: I don't know whether on all *nix systems select()
113 ;;; returns EBADF only when a given FD present in some fd-set
114 ;;; is closed(as the POSIX docs say) or if some other kinds of
115 ;;; errors are reported too(as the Linux manpages seem to suggest)
116 (defun fd-error-p (fd)
117 (not (nix:fd-open-p fd
)))
119 (defun harvest-select-fd-errors (read-fds write-fds max-fd
)
120 (loop :for fd
:upto max-fd
121 :when
(and (or (fd-isset fd read-fds
)
122 (fd-isset fd write-fds
))
124 :collect
(cons fd
:error
)))