1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; fd-wait.lisp --- Wait for events on single FDs.
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 ;;; FIXME: Until a way to autodetect platform features is implemented
28 (define-constant nix
::pollrdhup
0)
30 (define-condition poll-error
(error)
31 ((fd :initarg
:fd
:reader poll-error-fd
)
32 (identifier :initarg
:identifier
:initform
"Unknown error"
33 :reader poll-error-identifier
))
34 (:report
(lambda (condition stream
)
35 (format stream
"Error caught while polling file descriptor ~A: ~A"
36 (poll-error-fd condition
)
37 (poll-error-identifier condition
))))
39 "Signaled when an error occurs while polling for I/O readiness
40 of a file descriptor."))
42 (define-condition poll-timeout
(condition)
43 ((fd :initarg
:fd
:reader poll-timeout-fd
)
44 (event-type :initarg
:event-type
:reader poll-timeout-event-type
))
45 (:report
(lambda (condition stream
)
46 (format stream
"Timeout occurred while polling file descriptor ~A for event ~S"
47 (poll-timeout-fd condition
)
48 (poll-timeout-event-type condition
))))
50 "Signaled when a timeout occurs while polling for I/O readiness
51 of a file descriptor."))
53 (defun compute-poll-flags (type)
55 (:read
(logior nix
:pollin nix
:pollrdhup nix
:pollpri
))
56 (:write
(logior nix
:pollout nix
:pollhup
))
57 (:read-write
(logior nix
:pollin nix
:pollrdhup nix
:pollpri
58 nix
:pollout nix
:pollhup
))))
60 (defun process-poll-revents (revents fd
)
61 (let ((readp nil
) (writep nil
))
63 ((nix:pollin nix
:pollrdhup nix
:pollpri
)
65 ((nix:pollout nix
:pollhup
) (setf writep t
))
66 ((nix:pollerr
) (error 'poll-error
:fd fd
))
67 ((nix:pollnval
) (error 'poll-error
:fd fd
68 :identifier
"Invalid file descriptor")))
69 (values readp writep
)))
71 (defun wait-until-fd-ready (fd event-type
&optional timeout errorp
)
72 "Poll file descriptor `FD' for I/O readiness. `EVENT-TYPE' must be
73 :READ, :WRITE or :READ-WRITE which means \"either :READ or :WRITE\".
74 `TIMEOUT' must be either a non-negative integer measured in seconds,
75 or `NIL' meaning no timeout at all. If `ERRORP' is not NIL and a timeout
76 occurs, then a condition of type POLL-TIMEOUT is signaled.
77 Returns two boolean values indicating readbility and writability of FD."
78 (flet ((poll-error (unix-err)
79 (error 'poll-error
:fd fd
80 :identifier
(osicat-sys:system-error-identifier unix-err
))))
81 (with-foreign-object (pollfd 'nix
::pollfd
)
82 (nix:bzero pollfd nix
::size-of-pollfd
)
83 (with-foreign-slots ((nix::fd nix
::events nix
::revents
)
86 nix
::events
(compute-poll-flags event-type
))
88 (let ((ret (nix:repeat-upon-condition-decreasing-timeout
89 ((nix:eintr
) tmp-timeout timeout
)
90 (nix:poll pollfd
1 (timeout->milisec timeout
)))))
93 (error 'poll-timeout
:fd fd
:event-type event-type
)
94 (return-from wait-until-fd-ready
(values nil nil
)))))
95 (nix:posix-error
(err) (poll-error err
)))
96 (process-poll-revents nix
::revents fd
)))))
98 (defun fd-ready-p (fd &optional
(event-type :read
))
99 "Tests file-descriptor `FD' for I/O readiness. `EVENT-TYPE'
100 must be :READ, :WRITE or :READ-WRITE which means \"either :READ
102 (multiple-value-bind (readp writep
)
103 (wait-until-fd-ready fd event-type
0)
107 (:read-write
(or readp writep
)))))
109 (defun fd-readablep (fd)
110 (nth-value 0 (wait-until-fd-ready fd
:read
0)))
112 (defun fd-writablep (fd)
113 (nth-value 1 (wait-until-fd-ready fd
:write
0)))