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-2008, 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 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 pollin pollrdhup pollpri
))
56 (:write
(logior pollout pollhup
))
57 (:read-write
(logior pollin pollrdhup pollpri pollout pollhup
))))
59 (defun process-poll-revents (revents fd
)
60 (let ((readp nil
) (writep nil
))
62 ((pollin pollrdhup pollpri
)
64 ((pollout pollhup
) (setf writep t
))
65 ((pollerr) (error 'poll-error
:fd fd
))
66 ((pollnval) (error 'poll-error
:fd fd
67 :identifier
"Invalid file descriptor")))
68 (values readp writep
)))
70 (defun wait-until-fd-ready (file-descriptor event-type
&optional timeout errorp
)
71 "Poll file descriptor `FILE-DESCRIPTOR' for I/O readiness. `EVENT-TYPE' must be
72 :READ, :WRITE or :READ-WRITE which means \"either :READ or :WRITE\".
73 `TIMEOUT' must be either a non-negative integer measured in seconds,
74 or `NIL' meaning no timeout at all. If `ERRORP' is not NIL and a timeout
75 occurs, then a condition of type `POLL-TIMEOUT' is signaled.
76 Returns two boolean values indicating readability and writeability of `FILE-DESCRIPTOR'."
77 (flet ((poll-error (unix-err)
78 (error 'poll-error
:fd file-descriptor
79 :identifier
(osicat-sys:system-error-identifier unix-err
))))
80 (with-foreign-object (pollfd 'pollfd
)
81 (bzero pollfd size-of-pollfd
)
82 (with-foreign-slots ((fd events revents
) pollfd pollfd
)
83 (setf fd file-descriptor
84 events
(compute-poll-flags event-type
))
86 (let ((ret (nix:repeat-upon-condition-decreasing-timeout
87 ((nix:eintr
) tmp-timeout timeout
)
88 (poll pollfd
1 (timeout->milisec timeout
)))))
91 (error 'poll-timeout
:fd file-descriptor
:event-type event-type
)
92 (return-from wait-until-fd-ready
(values nil nil
)))))
93 (nix:posix-error
(err) (poll-error err
)))
94 (process-poll-revents revents file-descriptor
)))))
96 (defun fd-ready-p (fd &optional
(event-type :read
))
97 "Tests file-descriptor `FD' for I/O readiness. `EVENT-TYPE'
98 must be :READ, :WRITE or :READ-WRITE which means \"either :READ
100 (multiple-value-bind (readp writep
)
101 (wait-until-fd-ready fd event-type
0)
105 (:read-write
(or readp writep
)))))
107 (defun fd-readablep (fd)
108 (nth-value 0 (wait-until-fd-ready fd
:read
0)))
110 (defun fd-writablep (fd)
111 (nth-value 1 (wait-until-fd-ready fd
:write
0)))