3 ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (ice-9 poll)
21 #:use-module (srfi srfi-9)
22 #:use-module (srfi srfi-9 gnu)
23 #:use-module (rnrs bytevectors)
24 #:export (make-empty-poll-set
37 (eval-when (eval load compile)
38 (load-extension (string-append "libguile-" (effective-version))
41 (if (defined? 'POLLIN)
44 (if (defined? 'POLLPRI)
47 (if (defined? 'POLLOUT)
50 (if (defined? 'POLLRDHUP)
53 (if (defined? 'POLLERR)
56 (if (defined? 'POLLHUP)
59 (if (defined? 'POLLNVAL)
63 (define-record-type <poll-set>
64 (make-poll-set pollfds nfds ports)
66 (pollfds pset-pollfds set-pset-pollfds!)
67 (nfds poll-set-nfds set-pset-nfds!)
68 (ports pset-ports set-pset-ports!)
71 (define-syntax-rule (pollfd-offset n)
74 (define* (make-empty-poll-set #:optional (pre-allocated 4))
75 (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)
77 (make-vector pre-allocated #f)))
79 (define (pset-size set)
80 (vector-length (pset-ports set)))
82 (define (ensure-pset-size! set size)
83 (let ((prev (pset-size set)))
88 (let ((old-pollfds (pset-pollfds set))
89 (nfds (poll-set-nfds set))
90 (old-ports (pset-ports set))
91 (new-pollfds (make-bytevector (pollfd-offset new) 0))
92 (new-ports (make-vector new #f)))
93 (bytevector-copy! old-pollfds 0 new-pollfds 0
95 (vector-move-left! old-ports 0 nfds new-ports 0)
96 (set-pset-pollfds! set new-pollfds)
97 (set-pset-ports! set new-ports)))))))
99 (define (poll-set-find-port set port)
101 (if (< i (poll-set-nfds set))
102 (if (equal? (vector-ref (pset-ports set) i) port)
107 (define (poll-set-port set idx)
108 (if (< idx (poll-set-nfds set))
109 (vector-ref (pset-ports set) idx)
110 (error "poll set index out of bounds" set idx)))
112 (define (poll-set-events set idx)
113 (if (< idx (poll-set-nfds set))
114 (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 4))
115 (error "poll set index out of bounds" set idx)))
117 (define (set-poll-set-events! set idx events)
118 (if (< idx (poll-set-nfds set))
119 (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 4)
121 (error "poll set index out of bounds" set idx)))
123 (define (poll-set-revents set idx)
124 (if (< idx (poll-set-nfds set))
125 (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 6))
126 (error "poll set index out of bounds" set idx)))
128 (define (set-poll-set-revents! set idx revents)
129 (if (< idx (poll-set-nfds set))
130 (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 6)
132 (error "poll set index out of bounds" set idx)))
134 (define (poll-set-add! set fd-or-port events)
135 (let* ((idx (poll-set-nfds set))
136 (off (pollfd-offset idx))
137 (fd (if (integer? fd-or-port)
139 (port->fdes fd-or-port))))
141 (if (port? fd-or-port)
142 ;; As we store the port in the fdset, there is no need to
143 ;; increment the revealed count to prevent the fd from being
144 ;; closed by a gc'd port.
145 (release-port-handle fd-or-port))
147 (ensure-pset-size! set (1+ idx))
148 (bytevector-s32-native-set! (pset-pollfds set) off fd)
149 (bytevector-u16-native-set! (pset-pollfds set) (+ off 4) events)
150 (bytevector-u16-native-set! (pset-pollfds set) (+ off 6) 0) ; revents
151 (vector-set! (pset-ports set) idx fd-or-port)
152 (set-pset-nfds! set (1+ idx))))
154 (define (poll-set-remove! set idx)
155 (if (not (< idx (poll-set-nfds set)))
156 (error "poll set index out of bounds" set idx))
157 (let ((nfds (poll-set-nfds set))
158 (off (pollfd-offset idx))
159 (port (vector-ref (pset-ports set) idx)))
160 (vector-move-left! (pset-ports set) (1+ idx) nfds
161 (pset-ports set) idx)
162 (vector-set! (pset-ports set) (1- nfds) #f)
163 (bytevector-copy! (pset-pollfds set) (pollfd-offset (1+ idx))
164 (pset-pollfds set) off
165 (- (pollfd-offset nfds) (pollfd-offset (1+ idx))))
166 ;; zero the struct pollfd all at once
167 (bytevector-u64-native-set! (pset-pollfds set) (pollfd-offset (1- nfds)) 0)
168 (set-pset-nfds! set (1- nfds))
171 (define* (poll poll-set #:optional (timeout -1))
172 (primitive-poll (pset-pollfds poll-set)
173 (poll-set-nfds poll-set)
174 (pset-ports poll-set)