Commit | Line | Data |
---|---|---|
6f81b18a AW |
1 | ;; poll |
2 | ||
bc1bc9e3 | 3 | ;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. |
6f81b18a AW |
4 | ;;;; |
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. | |
9 | ;;;; | |
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. | |
14 | ;;;; | |
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 | |
18 | ;;;; | |
19 | ||
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 | |
25 | poll-set? | |
26 | poll-set-nfds | |
27 | poll-set-find-port | |
28 | poll-set-port | |
29 | poll-set-events | |
30 | set-poll-set-events! | |
31 | poll-set-revents | |
32 | set-poll-set-revents! | |
33 | poll-set-add! | |
34 | poll-set-remove! | |
35 | poll)) | |
36 | ||
37 | (eval-when (eval load compile) | |
38 | (load-extension (string-append "libguile-" (effective-version)) | |
39 | "scm_init_poll")) | |
40 | ||
6d346bb6 AW |
41 | (if (not (= %sizeof-struct-pollfd 8)) |
42 | (error "Unexpected struct pollfd size" %sizeof-struct-pollfd)) | |
43 | ||
6f81b18a AW |
44 | (if (defined? 'POLLIN) |
45 | (export POLLIN)) | |
46 | ||
47 | (if (defined? 'POLLPRI) | |
48 | (export POLLPRI)) | |
49 | ||
50 | (if (defined? 'POLLOUT) | |
51 | (export POLLOUT)) | |
52 | ||
53 | (if (defined? 'POLLRDHUP) | |
54 | (export POLLRDHUP)) | |
55 | ||
56 | (if (defined? 'POLLERR) | |
57 | (export POLLERR)) | |
58 | ||
59 | (if (defined? 'POLLHUP) | |
60 | (export POLLHUP)) | |
61 | ||
62 | (if (defined? 'POLLNVAL) | |
63 | (export POLLNVAL)) | |
64 | ||
65 | ||
66 | (define-record-type <poll-set> | |
67 | (make-poll-set pollfds nfds ports) | |
68 | poll-set? | |
69 | (pollfds pset-pollfds set-pset-pollfds!) | |
70 | (nfds poll-set-nfds set-pset-nfds!) | |
71 | (ports pset-ports set-pset-ports!) | |
72 | ) | |
73 | ||
0c65f52c AW |
74 | (define-syntax-rule (pollfd-offset n) |
75 | (* n 8)) | |
6f81b18a AW |
76 | |
77 | (define* (make-empty-poll-set #:optional (pre-allocated 4)) | |
78 | (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0) | |
79 | 0 | |
80 | (make-vector pre-allocated #f))) | |
81 | ||
82 | (define (pset-size set) | |
83 | (vector-length (pset-ports set))) | |
84 | ||
85 | (define (ensure-pset-size! set size) | |
86 | (let ((prev (pset-size set))) | |
87 | (if (< prev size) | |
88 | (let lp ((new prev)) | |
89 | (if (< new size) | |
90 | (lp (* new 2)) | |
91 | (let ((old-pollfds (pset-pollfds set)) | |
92 | (nfds (poll-set-nfds set)) | |
93 | (old-ports (pset-ports set)) | |
94 | (new-pollfds (make-bytevector (pollfd-offset new) 0)) | |
95 | (new-ports (make-vector new #f))) | |
96 | (bytevector-copy! old-pollfds 0 new-pollfds 0 | |
97 | (pollfd-offset nfds)) | |
98 | (vector-move-left! old-ports 0 nfds new-ports 0) | |
99 | (set-pset-pollfds! set new-pollfds) | |
100 | (set-pset-ports! set new-ports))))))) | |
101 | ||
102 | (define (poll-set-find-port set port) | |
103 | (let lp ((i 0)) | |
104 | (if (< i (poll-set-nfds set)) | |
105 | (if (equal? (vector-ref (pset-ports set) i) port) | |
106 | i | |
107 | (lp (1+ i))) | |
108 | #f))) | |
109 | ||
110 | (define (poll-set-port set idx) | |
111 | (if (< idx (poll-set-nfds set)) | |
112 | (vector-ref (pset-ports set) idx) | |
113 | (error "poll set index out of bounds" set idx))) | |
114 | ||
115 | (define (poll-set-events set idx) | |
116 | (if (< idx (poll-set-nfds set)) | |
117 | (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 4)) | |
118 | (error "poll set index out of bounds" set idx))) | |
119 | ||
120 | (define (set-poll-set-events! set idx events) | |
121 | (if (< idx (poll-set-nfds set)) | |
122 | (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 4) | |
123 | events) | |
124 | (error "poll set index out of bounds" set idx))) | |
125 | ||
126 | (define (poll-set-revents set idx) | |
127 | (if (< idx (poll-set-nfds set)) | |
128 | (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 6)) | |
129 | (error "poll set index out of bounds" set idx))) | |
130 | ||
131 | (define (set-poll-set-revents! set idx revents) | |
132 | (if (< idx (poll-set-nfds set)) | |
133 | (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 6) | |
134 | revents) | |
135 | (error "poll set index out of bounds" set idx))) | |
136 | ||
137 | (define (poll-set-add! set fd-or-port events) | |
138 | (let* ((idx (poll-set-nfds set)) | |
139 | (off (pollfd-offset idx)) | |
140 | (fd (if (integer? fd-or-port) | |
141 | fd-or-port | |
bc1bc9e3 | 142 | (fileno fd-or-port)))) |
6f81b18a AW |
143 | |
144 | (ensure-pset-size! set (1+ idx)) | |
145 | (bytevector-s32-native-set! (pset-pollfds set) off fd) | |
146 | (bytevector-u16-native-set! (pset-pollfds set) (+ off 4) events) | |
147 | (bytevector-u16-native-set! (pset-pollfds set) (+ off 6) 0) ; revents | |
148 | (vector-set! (pset-ports set) idx fd-or-port) | |
149 | (set-pset-nfds! set (1+ idx)))) | |
150 | ||
151 | (define (poll-set-remove! set idx) | |
152 | (if (not (< idx (poll-set-nfds set))) | |
153 | (error "poll set index out of bounds" set idx)) | |
154 | (let ((nfds (poll-set-nfds set)) | |
155 | (off (pollfd-offset idx)) | |
156 | (port (vector-ref (pset-ports set) idx))) | |
157 | (vector-move-left! (pset-ports set) (1+ idx) nfds | |
158 | (pset-ports set) idx) | |
159 | (vector-set! (pset-ports set) (1- nfds) #f) | |
160 | (bytevector-copy! (pset-pollfds set) (pollfd-offset (1+ idx)) | |
161 | (pset-pollfds set) off | |
162 | (- (pollfd-offset nfds) (pollfd-offset (1+ idx)))) | |
163 | ;; zero the struct pollfd all at once | |
164 | (bytevector-u64-native-set! (pset-pollfds set) (pollfd-offset (1- nfds)) 0) | |
165 | (set-pset-nfds! set (1- nfds)) | |
166 | port)) | |
167 | ||
168 | (define* (poll poll-set #:optional (timeout -1)) | |
169 | (primitive-poll (pset-pollfds poll-set) | |
170 | (poll-set-nfds poll-set) | |
e9634465 | 171 | (pset-ports poll-set) |
6f81b18a | 172 | timeout)) |