1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; select.lisp --- select()-based multiplexer implementation.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
7 ;;; This code is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the version 2.1 of
9 ;;; the GNU Lesser General Public License as published by
10 ;;; the Free Software Foundation, as clarified by the
11 ;;; preamble found here:
12 ;;; http://opensource.franz.com/preamble.html
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU Lesser General
20 ;;; Public License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
22 ;;; Boston, MA 02110-1301, USA
24 (in-package :io.multiplex
)
26 (defconstant +select-priority
+ 3)
28 (define-multiplexer select-multiplexer
+select-priority
+ (multiplexer)
31 (read-fd-set :initform
(allocate-fd-set)
32 :reader read-fd-set-of
)
33 (write-fd-set :initform
(allocate-fd-set)
34 :reader write-fd-set-of
)
35 (except-fd-set :initform
(allocate-fd-set)
36 :reader except-fd-set-of
))
37 (:default-initargs
:fd-limit
(1- nix
::fd-setsize
)))
39 (defun allocate-fd-set ()
40 (nix:fd-zero
(foreign-alloc 'nix
::fd-set
)))
42 (defmethod print-object ((mux select-multiplexer
) stream
)
43 (print-unreadable-object (mux stream
:type nil
:identity nil
)
44 (format stream
"select(2) multiplexer")))
46 (defmethod close-multiplexer progn
((mux select-multiplexer
))
47 (foreign-free (read-fd-set-of mux
))
48 (foreign-free (write-fd-set-of mux
))
49 (foreign-free (except-fd-set-of mux
))
50 (dolist (slot '(max-fd read-fd-set write-fd-set except-fd-set
))
51 (setf (slot-value mux slot
) nil
)))
53 (defun find-max-fd (fd-set end
)
54 (loop :for i
:downfrom end
:to
0
55 :do
(when (nix:fd-isset i fd-set
)
56 (return-from find-max-fd i
)))
57 ;; this means no fd <= end is set
60 (defun recalc-fd-masks (mux fd read write
)
61 (with-accessors ((rs read-fd-set-of
) (ws write-fd-set-of
)
62 (es except-fd-set-of
) (max-fd max-fd-of
)) mux
72 (setf max-fd
(max (find-max-fd rs fd
)
76 (defmethod monitor-fd ((mux select-multiplexer
) fd-entry
)
77 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
78 (not (queue-empty-p (fd-entry-read-events fd-entry
)))
79 (not (queue-empty-p (fd-entry-write-events fd-entry
)))))
81 (defmethod update-fd ((mux select-multiplexer
) fd-entry
)
82 (recalc-fd-masks mux
(fd-entry-fd fd-entry
)
83 (not (queue-empty-p (fd-entry-read-events fd-entry
)))
84 (not (queue-empty-p (fd-entry-write-events fd-entry
)))))
86 (defmethod unmonitor-fd ((mux select-multiplexer
) fd-entry
)
87 (recalc-fd-masks mux
(fd-entry-fd fd-entry
) nil nil
))
89 (defmethod harvest-events ((mux select-multiplexer
) timeout
)
90 (with-accessors ((rs read-fd-set-of
) (ws write-fd-set-of
)
91 (es except-fd-set-of
) (max-fd max-fd-of
)) mux
92 ;; if there are no fds set and timeout is NULL
93 ;; select() blocks forever
94 (when (and (minusp max-fd
)
96 (warn "Non fds to monitor and no timeout set !")
97 (return-from harvest-events nil
))
98 (with-foreign-objects ((read-fds 'nix
::fd-set
)
99 (write-fds 'nix
::fd-set
)
100 (except-fds 'nix
::fd-set
))
101 (nix:copy-fd-set rs read-fds
)
102 (nix:copy-fd-set ws write-fds
)
103 (nix:copy-fd-set es except-fds
)
105 (with-foreign-object (tv 'nix
::timeval
)
106 (nix:repeat-upon-condition-decreasing-timeout
107 ((nix:eintr
) tmp-timeout timeout
)
109 (timeout->timeval tmp-timeout tv
))
110 (nix:select
(1+ max-fd
)
114 (if tmp-timeout tv
(null-pointer)))))
116 (return-from harvest-events
117 (harvest-select-fd-errors rs ws max-fd
))))
118 (harvest-select-events max-fd read-fds write-fds except-fds
))))
120 (defun harvest-select-events (max-fd read-fds write-fds except-fds
)
121 (loop for fd upto max-fd
122 for event
= () then
()
123 when
(or (nix:fd-isset fd read-fds
)
124 (nix:fd-isset fd except-fds
)) do
(push :read event
)
125 when
(nix:fd-isset fd write-fds
) do
(push :write event
)
126 when event collect
(list fd event
)))
128 ;;; FIXME: I don't know whether on all *nix systems select()
129 ;;; returns EBADF only when a given FD present in some fd-set
130 ;;; is closed(as the POSIX docs say) or if some other kinds of
131 ;;; errors are reported too(as the Linux manpages seem to suggest)
132 (defun fd-error-p (fd)
133 (not (nix:fd-open-p fd
)))
135 (defun harvest-select-fd-errors (read-fds write-fds max-fd
)
136 (loop for fd upto max-fd
137 when
(and (or (nix:fd-isset fd read-fds
)
138 (nix:fd-isset fd write-fds
))
140 collect
(cons fd
:error
)))