sbcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
sbcl.lisp (37185B)
---
1 ;;;; -*- Mode: Common-Lisp -*-
2
3 ;;;; See LICENSE for licensing information.
4
5 (in-package :usocket)
6
7 #+sbcl
8 (progn
9 #-win32
10 (defun get-host-name ()
11 (sb-unix:unix-gethostname))
12
13 ;; we assume winsock has already been loaded, after all,
14 ;; we already loaded sb-bsd-sockets and sb-alien
15 #+win32
16 (defun get-host-name ()
17 (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))
18 (let ((result (sb-alien:alien-funcall
19 (sb-alien:extern-alien "gethostname"
20 (sb-alien:function sb-alien:int
21 (* sb-alien:char)
22 sb-alien:int))
23 (sb-alien:cast buf (* sb-alien:char))
24 256)))
25 (when (= result 0)
26 (sb-alien:cast buf sb-alien:c-string))))))
27
28 #+(and ecl (not ecl-bytecmp))
29 (progn
30 #-:wsock
31 (ffi:clines
32 "#include <errno.h>"
33 "#include <sys/socket.h>"
34 "#include <unistd.h>")
35 #+:wsock
36 (ffi:clines
37 "#ifndef FD_SETSIZE"
38 "#define FD_SETSIZE 1024"
39 "#endif"
40 "#include <winsock2.h>")
41
42 (ffi:clines
43 #+:msvc "#include <time.h>"
44 #-:msvc "#include <sys/time.h>"
45 "#include <ecl/ecl-inl.h>")
46 #|
47 #+:prefixed-api
48 (ffi:clines
49 "#define CONS(x, y) ecl_cons((x), (y))"
50 "#define MAKE_INTEGER(x) ecl_make_integer((x))")
51 #-:prefixed-api
52 (ffi:clines
53 "#define CONS(x, y) make_cons((x), (y))"
54 "#define MAKE_INTEGER(x) make_integer((x))")
55 |#
56
57 (defun cerrno ()
58 (ffi:c-inline () () :int
59 "errno" :one-liner t))
60
61 (defun fd-setsize ()
62 (ffi:c-inline () () :fixnum
63 "FD_SETSIZE" :one-liner t))
64
65 (defun fdset-alloc ()
66 (ffi:c-inline () () :pointer-void
67 "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
68
69 (defun fdset-zero (fdset)
70 (ffi:c-inline (fdset) (:pointer-void) :void
71 "FD_ZERO((fd_set*)#0)" :one-liner t))
72
73 (defun fdset-set (fdset fd)
74 (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
75 "FD_SET(#1,(fd_set*)#0)" :one-liner t))
76
77 (defun fdset-clr (fdset fd)
78 (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
79 "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
80
81 (defun fdset-fd-isset (fdset fd)
82 (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
83 "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
84
85 (declaim (inline cerrno
86 fd-setsize
87 fdset-alloc
88 fdset-zero
89 fdset-set
90 fdset-clr
91 fdset-fd-isset))
92
93 (defun get-host-name ()
94 (ffi:c-inline
95 () () :object
96 "{ char *buf = (char *) ecl_alloc_atomic(257);
97
98 if (gethostname(buf,256) == 0)
99 @(return) = make_simple_base_string(buf);
100 else
101 @(return) = Cnil;
102 }" :one-liner nil :side-effects nil))
103
104 (defun read-select (wl to-secs &optional (to-musecs 0))
105 (let* ((sockets (wait-list-waiters wl))
106 (rfds (wait-list-%wait wl))
107 (max-fd (reduce #'(lambda (x y)
108 (let ((sy (sb-bsd-sockets:socket-file-descriptor
109 (socket y))))
110 (if (< x sy) sy x)))
111 (cdr sockets)
112 :initial-value (sb-bsd-sockets:socket-file-descriptor
113 (socket (car sockets))))))
114 (fdset-zero rfds)
115 (dolist (sock sockets)
116 (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
117 (socket sock))))
118 (let ((count
119 (ffi:c-inline (to-secs to-musecs rfds max-fd)
120 (t :unsigned-int :pointer-void :int)
121 :int
122 "
123 int count;
124 struct timeval tv;
125 struct timeval tvs;
126 struct timeval tve;
127 unsigned long elapsed;
128 unsigned long remaining;
129 int retval = -1;
130
131 if (#0 != Cnil) {
132 tv.tv_sec = fixnnint(#0);
133 tv.tv_usec = #1;
134 }
135 remaining = ((tv.tv_sec*1000000) + tv.tv_usec);
136
137 do {
138 (void)gettimeofday(&tvs, NULL); // start time
139
140 retval = select(#3 + 1, (fd_set*)#2, NULL, NULL,
141 (#0 != Cnil) ? &tv : NULL);
142
143 if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) {
144 (void)gettimeofday(&tve, NULL); // end time
145 elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec);
146 remaining = remaining - elapsed;
147 if ( remaining < 0 ) { // already past timeout, just exit
148 retval = 0;
149 break;
150 }
151
152 tv.tv_sec = remaining / 1000000;
153 tv.tv_usec = remaining - (tv.tv_sec * 1000000);
154 }
155
156 } while ((retval < 0) && (errno == EINTR));
157
158 @(return) = retval;
159 " :one-liner nil)))
160 (cond
161 ((= 0 count)
162 (values nil nil))
163 ((< count 0)
164 ;; check for EAGAIN; these should not err
165 (values nil (cerrno)))
166 (t
167 (dolist (sock sockets)
168 (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
169 (socket sock)))
170 (setf (state sock) :READ))))))))
171 ) ; progn
172
173 (defun map-socket-error (sock-err)
174 (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
175
176 (defparameter +sbcl-condition-map+
177 '((interrupted-error . interrupted-condition)))
178
179 (defparameter +sbcl-error-map+
180 `((sb-bsd-sockets:address-in-use-error . address-in-use-error)
181 (sb-bsd-sockets::no-address-error . address-not-available-error)
182 (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error)
183 (sb-bsd-sockets:connection-refused-error . connection-refused-error)
184 (sb-bsd-sockets:invalid-argument-error . invalid-argument-error)
185 (sb-bsd-sockets:no-buffers-error . no-buffers-error)
186 (sb-bsd-sockets:operation-not-supported-error
187 . operation-not-supported-error)
188 (sb-bsd-sockets:operation-not-permitted-error
189 . operation-not-permitted-error)
190 (sb-bsd-sockets:protocol-not-supported-error
191 . protocol-not-supported-error)
192 #-(or ecl clasp)
193 (sb-bsd-sockets:unknown-protocol
194 . protocol-not-supported-error)
195 (sb-bsd-sockets:socket-type-not-supported-error
196 . socket-type-not-supported-error)
197 (sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
198 (sb-bsd-sockets:operation-timeout-error . timeout-error)
199 #-(or ecl clasp)
200 (sb-sys:io-timeout . timeout-error)
201 #+sbcl
202 (sb-ext:timeout . timeout-error)
203 (sb-bsd-sockets:socket-error . ,#'map-socket-error)
204
205 ;; Nameservice errors: mapped to unknown-error
206 #-(or ecl clasp)
207 (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
208 #-(or ecl clasp)
209 (sb-bsd-sockets:try-again-error . ns-try-again-condition)
210 #-(or ecl clasp)
211 (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
212
213 ;; this function servers as a general template for other backends
214 (defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
215 "Dispatch correct usocket condition."
216 (typecase condition
217 (serious-condition
218 (let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+)))
219 (usock-error (if (functionp usock-error)
220 (funcall usock-error condition)
221 usock-error)))
222 (declare (type symbol usock-error))
223 (if usock-error
224 (cond ((subtypep usock-error 'ns-error)
225 (error usock-error :socket socket :host-or-ip host-or-ip))
226 (t
227 (error usock-error :socket socket)))
228 (error 'unknown-error
229 :real-error condition
230 :socket socket))))
231 (condition
232 (let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+)))
233 (usock-cond (if (functionp usock-cond)
234 (funcall usock-cond condition)
235 usock-cond)))
236 (if usock-cond
237 (cond ((subtypep usock-cond 'ns-condition)
238 (signal usock-cond :socket socket :host-or-ip host-or-ip))
239 (t
240 (signal usock-cond :socket socket)))
241 (signal 'unknown-condition
242 :real-condition condition
243 :socket socket))))))
244
245 ;;; "The socket stream ends up with a bogus name as it is created before
246 ;;; the socket is connected, making things harder to debug than they need
247 ;;; to be." -- Nikodemus Siivola <nikodemus@random-state.net>
248
249 (defvar *dummy-stream*
250 (let ((stream (make-broadcast-stream)))
251 (close stream)
252 stream))
253
254 ;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch
255 ;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS
256 ;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than
257 ;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus@random-state.net>
258
259 #+(and sbcl (not win32))
260 (defmacro %with-timeout ((seconds timeout-form) &body body)
261 "Runs BODY as an implicit PROGN with timeout of SECONDS. If
262 timeout occurs before BODY has finished, BODY is unwound and
263 TIMEOUT-FORM is executed with its values returned instead.
264
265 Note that BODY is unwound asynchronously when a timeout occurs,
266 so unless all code executed during it -- including anything
267 down the call chain -- is asynch unwind safe, bad things will
268 happen. Use with care."
269 (let ((exec (gensym)) (unwind (gensym)) (timer (gensym))
270 (timeout (gensym)) (block (gensym)))
271 `(block ,block
272 (tagbody
273 (flet ((,unwind ()
274 (go ,timeout))
275 (,exec ()
276 ,@body))
277 (declare (dynamic-extent #',exec #',unwind))
278 (let ((,timer (sb-ext:make-timer #',unwind)))
279 (declare (dynamic-extent ,timer))
280 (sb-sys:without-interrupts
281 (unwind-protect
282 (progn
283 (sb-ext:schedule-timer ,timer ,seconds)
284 (return-from ,block
285 (sb-sys:with-local-interrupts
286 (,exec))))
287 (sb-ext:unschedule-timer ,timer)))))
288 ,timeout
289 (return-from ,block ,timeout-form)))))
290
291 (defun get-hosts-by-name (name)
292 (with-mapped-conditions (nil name)
293 (multiple-value-bind (host4 host6)
294 (sb-bsd-sockets:get-host-by-name name)
295 (let ((addr4 (when host4
296 (sb-bsd-sockets::host-ent-addresses host4)))
297 (addr6 (when host6
298 (sb-bsd-sockets::host-ent-addresses host6))))
299 (append addr4 addr6)))))
300
301 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
302 timeout deadline (nodelay t nodelay-specified)
303 local-host local-port
304 &aux
305 (sockopt-tcp-nodelay-p
306 (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
307 (when deadline (unsupported 'deadline 'socket-connect))
308 #+(or ecl clasp)
309 (when timeout (unsupported 'timeout 'socket-connect))
310 (when (and nodelay-specified
311 ;; 20080802: ECL added this function to its sockets
312 ;; package today. There's no guarantee the functions
313 ;; we need are available, but we can make sure not to
314 ;; call them if they aren't
315 (not (eq nodelay :if-supported))
316 (not sockopt-tcp-nodelay-p))
317 (unsupported 'nodelay 'socket-connect))
318 (when (eq nodelay :if-supported)
319 (setf nodelay t))
320
321 (let* ((remote (when host
322 (car (get-hosts-by-name (host-to-hostname host)))))
323 (local (when local-host
324 (car (get-hosts-by-name (host-to-hostname local-host)))))
325 (ipv6 (or (and remote (= 16 (length remote)))
326 (and local (= 16 (length local)))))
327 (socket (make-instance #+sbcl (if ipv6
328 'sb-bsd-sockets::inet6-socket
329 'sb-bsd-sockets:inet-socket)
330 #+(or ecl clasp) 'sb-bsd-sockets:inet-socket
331 :type protocol
332 :protocol (case protocol
333 (:stream :tcp)
334 (:datagram :udp))))
335 usocket
336 ok)
337
338 (unwind-protect
339 (progn
340 (ecase protocol
341 (:stream
342 ;; If make a real socket stream before the socket is
343 ;; connected, it gets a misleading name so supply a
344 ;; dummy value to start with.
345 (setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))
346 ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
347 ;; to pass compilation on ECL without it.
348 (when (and nodelay-specified sockopt-tcp-nodelay-p)
349 (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
350 (when (or local-host local-port)
351 (sb-bsd-sockets:socket-bind socket
352 (if ipv6
353 (or local (ipv6-host-to-vector "::0"))
354 (or local (host-to-vector-quad *wildcard-host*)))
355 (or local-port *auto-port*)))
356
357 (with-mapped-conditions (usocket host)
358 #+(and sbcl (not win32))
359 (labels ((connect ()
360 (sb-bsd-sockets:socket-connect socket remote port)))
361 (if timeout
362 (%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
363 (connect)))
364 #+(or ecl clasp (and sbcl win32))
365 (sb-bsd-sockets:socket-connect socket remote port)
366 ;; Now that we're connected make the stream.
367 (setf (socket-stream usocket)
368 (sb-bsd-sockets:socket-make-stream socket
369 :input t :output t :buffering :full
370 :element-type element-type
371 ;; Robert Brown <robert.brown@gmail.com> said on Aug 4, 2011:
372 ;; ... This means that SBCL streams created by usocket have a true
373 ;; serve-events property. When writing large amounts of data to several
374 ;; streams, the kernel will eventually stop accepting data from SBCL.
375 ;; When this happens, SBCL either waits for I/O to be possible on
376 ;; the file descriptor it's writing to or queues the data to be flushed later.
377 ;; Because usocket streams specify serve-events as true, SBCL
378 ;; always queues. Instead, it should wait for I/O to be available and
379 ;; write the remaining data to the socket. That's what serve-events
380 ;; equal to NIL gets you.
381 ;;
382 ;; Nikodemus Siivola <nikodemus@random-state.net> said on Aug 8, 2011:
383 ;; It's set to T for purely historical reasons, and will soon change to
384 ;; NIL in SBCL. (The docstring has warned of T being a temporary default
385 ;; for as long as the :SERVE-EVENTS keyword argument has existed.)
386 :serve-events nil))))
387 (:datagram
388 (when (or local-host local-port)
389 (sb-bsd-sockets:socket-bind socket
390 (if ipv6
391 (or local (ipv6-host-to-vector "::0"))
392 (or local (host-to-vector-quad *wildcard-host*)))
393 (or local-port *auto-port*)))
394 (setf usocket (make-datagram-socket socket))
395 (when (and host port)
396 (with-mapped-conditions (usocket)
397 (sb-bsd-sockets:socket-connect socket remote port)
398 (setf (connected-p usocket) t)))))
399 (setf ok t))
400 ;; Clean up in case of an error.
401 (unless ok
402 (sb-bsd-sockets:socket-close socket :abort t)))
403 usocket))
404
405 (defun socket-listen (host port
406 &key reuseaddress
407 (reuse-address nil reuse-address-supplied-p)
408 (backlog 5)
409 (element-type 'character))
410 (let* (#+sbcl
411 (local (when host
412 (car (get-hosts-by-name (host-to-hostname host)))))
413 #+sbcl
414 (ipv6 (and local (= 16 (length local))))
415 (reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
416 (ip #+sbcl (if (and local (not (eq host *wildcard-host*)))
417 local
418 (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))
419 #+(or ecl clasp) (host-to-vector-quad host))
420 (sock (make-instance #+sbcl (if ipv6
421 'sb-bsd-sockets::inet6-socket
422 'sb-bsd-sockets:inet-socket)
423 #+(or ecl clasp) 'sb-bsd-sockets:inet-socket
424 :type :stream
425 :protocol :tcp)))
426 (handler-case
427 (with-mapped-conditions (nil host)
428 (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress)
429 (sb-bsd-sockets:socket-bind sock ip port)
430 (sb-bsd-sockets:socket-listen sock backlog)
431 (make-stream-server-socket sock :element-type element-type))
432 (t (c)
433 ;; Make sure we don't leak filedescriptors
434 (sb-bsd-sockets:socket-close sock)
435 (error c)))))
436
437 ;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,
438 ;;; instead of raising a condition. It's always possible for
439 ;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket
440 ;;; was detected to be ready: connection might be reset, for example.
441 ;;;
442 ;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to
443 ;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton@sw4me.com>
444
445 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
446 (with-mapped-conditions (usocket)
447 (let ((socket (sb-bsd-sockets:socket-accept (socket usocket))))
448 (when socket
449 (prog1
450 (make-stream-socket
451 :socket socket
452 :stream (sb-bsd-sockets:socket-make-stream
453 socket
454 :input t :output t :buffering :full
455 :element-type (or element-type
456 (element-type usocket))))
457
458 ;; next time wait for event again if we had EAGAIN/EINTR
459 ;; or else we'd enter a tight loop of failed accepts
460 #+win32
461 (setf (%ready-p usocket) nil))))))
462
463 ;; Sockets and their associated streams are modelled as
464 ;; different objects. Be sure to close the stream (which
465 ;; closes the socket too) when closing a stream-socket.
466 (defmethod socket-close ((usocket usocket))
467 (with-mapped-conditions (usocket)
468 (sb-bsd-sockets:socket-close (socket usocket))))
469
470 (defmethod socket-close ((usocket stream-usocket))
471 (with-mapped-conditions (usocket)
472 (close (socket-stream usocket))))
473
474 #+sbcl
475 (defmethod socket-shutdown ((usocket stream-usocket) direction)
476 (with-mapped-conditions (usocket)
477 (sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction)))
478
479 #+ecl
480 (defmethod socket-shutdown ((usocket stream-usocket) direction)
481 (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
482 (direction-flag (ecase direction
483 (:input 0)
484 (:output 1))))
485 (unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int
486 "shutdown(#0, #1)" :one-liner t))
487 (error (map-errno-error (cerrno))))))
488
489 #+clasp
490 (defmethod socket-shutdown ((usocket stream-usocket) direction)
491 (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
492 (direction-flag (ecase direction
493 (:input 0)
494 (:output 1))))
495 (unless (zerop (sockets-internal:shutdown sock-fd direction-flag))
496 (error (map-errno-error (cerrno))))))
497
498 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
499 (let ((remote (when host
500 (car (get-hosts-by-name (host-to-hostname host))))))
501 (with-mapped-conditions (usocket host)
502 (let* ((s (socket usocket))
503 (dest (if (and host port) (list remote port) nil))
504 (real-buffer (if (zerop offset)
505 buffer
506 (subseq buffer offset (+ offset size)))))
507 (sb-bsd-sockets:socket-send s real-buffer size :address dest)))))
508
509 (defmethod socket-receive ((usocket datagram-usocket) buffer length
510 &key (element-type '(unsigned-byte 8)))
511 #+sbcl
512 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
513 (integer 0) ; size
514 (simple-array (unsigned-byte 8) (*)) ; host
515 (unsigned-byte 16))) ; port
516 (with-mapped-conditions (usocket)
517 (let ((s (socket usocket)))
518 (sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
519
520 (defmethod get-local-name ((usocket usocket))
521 (sb-bsd-sockets:socket-name (socket usocket)))
522
523 (defmethod get-peer-name ((usocket stream-usocket))
524 (sb-bsd-sockets:socket-peername (socket usocket)))
525
526 (defmethod get-local-address ((usocket usocket))
527 (nth-value 0 (get-local-name usocket)))
528
529 (defmethod get-peer-address ((usocket stream-usocket))
530 (nth-value 0 (get-peer-name usocket)))
531
532 (defmethod get-local-port ((usocket usocket))
533 (nth-value 1 (get-local-name usocket)))
534
535 (defmethod get-peer-port ((usocket stream-usocket))
536 (nth-value 1 (get-peer-name usocket)))
537
538 (defun get-host-by-address (address)
539 (with-mapped-conditions (nil address)
540 (sb-bsd-sockets::host-ent-name
541 (sb-bsd-sockets:get-host-by-address address))))
542
543 #+(and sbcl (not win32))
544 (progn
545 (defun %setup-wait-list (wait-list)
546 (declare (ignore wait-list)))
547
548 (defun %add-waiter (wait-list waiter)
549 (push (socket waiter) (wait-list-%wait wait-list)))
550
551 (defun %remove-waiter (wait-list waiter)
552 (setf (wait-list-%wait wait-list)
553 (remove (socket waiter) (wait-list-%wait wait-list))))
554
555 (defun wait-for-input-internal (sockets &key timeout)
556 (with-mapped-conditions ()
557 (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
558 (sb-unix:fd-zero rfds)
559 (dolist (socket (wait-list-%wait sockets))
560 (sb-unix:fd-set
561 (sb-bsd-sockets:socket-file-descriptor socket)
562 rfds))
563 (multiple-value-bind
564 (secs musecs)
565 (split-timeout (or timeout 1))
566 (let* ((wait-list (wait-list-%wait sockets))
567 count err)
568 (if (null wait-list)
569 (setq count 0) ;; no need to call
570 (multiple-value-setq (count err)
571 (sb-unix:unix-fast-select
572 ;; "invalid number of arguments: 0" if wait-list is null.
573 (1+ (reduce #'max wait-list
574 :key #'sb-bsd-sockets:socket-file-descriptor))
575 (sb-alien:addr rfds) nil nil
576 (when timeout secs) (when timeout musecs))))
577 (if (null count) ; something wrong in #'sb-unix:unix-fast-select
578 (unless (= err sb-unix:eintr)
579 (error (map-errno-error err)))
580 (when (< 0 count) ; do nothing if count = 0
581 ;; process the result...
582 (dolist (x (wait-list-waiters sockets))
583 (when (sb-unix:fd-isset
584 (sb-bsd-sockets:socket-file-descriptor
585 (socket x))
586 rfds)
587 (setf (state x) :READ))))))))))
588 ) ; progn
589
590 ;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
591 ;;; Based on LispWorks version written by Erik Huelsmann.
592
593 #+win32 ; shared by ECL and SBCL
594 (eval-when (:compile-toplevel :load-toplevel :execute)
595 (defconstant +wsa-wait-failed+ #xffffffff)
596 (defconstant +wsa-infinite+ #xffffffff)
597 (defconstant +wsa-wait-event-0+ 0)
598 (defconstant +wsa-wait-timeout+ 258))
599
600 #+win32 ; shared by ECL and SBCL
601 (progn
602 (defconstant fd-read 1)
603 (defconstant fd-read-bit 0)
604 (defconstant fd-write 2)
605 (defconstant fd-write-bit 1)
606 (defconstant fd-oob 4)
607 (defconstant fd-oob-bit 2)
608 (defconstant fd-accept 8)
609 (defconstant fd-accept-bit 3)
610 (defconstant fd-connect 16)
611 (defconstant fd-connect-bit 4)
612 (defconstant fd-close 32)
613 (defconstant fd-close-bit 5)
614 (defconstant fd-qos 64)
615 (defconstant fd-qos-bit 6)
616 (defconstant fd-group-qos 128)
617 (defconstant fd-group-qos-bit 7)
618 (defconstant fd-routing-interface 256)
619 (defconstant fd-routing-interface-bit 8)
620 (defconstant fd-address-list-change 512)
621 (defconstant fd-address-list-change-bit 9)
622 (defconstant fd-max-events 10)
623 (defconstant fionread 1074030207)
624
625 ;; Note: for ECL, socket-handle will return raw Windows Handle,
626 ;; while SBCL returns OSF Handle instead.
627 (defun socket-handle (usocket)
628 (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
629
630 (defun socket-ready-p (socket)
631 (if (typep socket 'stream-usocket)
632 (plusp (bytes-available-for-read socket))
633 (%ready-p socket)))
634
635 (defun waiting-required (sockets)
636 (notany #'socket-ready-p sockets))
637
638 (defun raise-usock-err (errno &optional socket)
639 (error 'unknown-error
640 :socket socket
641 :real-error errno))
642
643 (defun wait-for-input-internal (wait-list &key timeout)
644 (when (waiting-required (wait-list-waiters wait-list))
645 (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)
646 nil
647 (if timeout
648 (truncate (* 1000 timeout))
649 +wsa-infinite+)
650 nil)))
651 (ecase rv
652 ((#.+wsa-wait-event-0+)
653 (update-ready-and-state-slots wait-list))
654 ((#.+wsa-wait-timeout+)) ; do nothing here
655 ((#.+wsa-wait-failed+)
656 (maybe-wsa-error rv))))))
657
658 (defun %add-waiter (wait-list waiter)
659 (let ((events (etypecase waiter
660 (stream-server-usocket (logior fd-connect fd-accept fd-close))
661 (stream-usocket (logior fd-read))
662 (datagram-usocket (logior fd-read)))))
663 (maybe-wsa-error
664 (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events)
665 waiter)))
666
667 (defun %remove-waiter (wait-list waiter)
668 (maybe-wsa-error
669 (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)
670 waiter))
671 ) ; progn
672
673 #+(and sbcl win32)
674 (progn
675 ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET
676 ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It
677 ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,
678 ;; which is always machine word-sized (exactly as intptr_t;
679 ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not
680 ;; enough -- potentially)."
681 ;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
682 (sb-alien:define-alien-type ws-socket sb-alien:signed)
683
684 (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
685 (sb-alien:define-alien-type ws-event sb-alien::hinstance)
686
687 (sb-alien:define-alien-type nil
688 (sb-alien:struct wsa-network-events
689 (network-events sb-alien:long)
690 (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events
691
692 (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
693 ws-event) ; return type only
694
695 (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
696 (boolean #.sb-vm::n-machine-word-bits)
697 (event-object ws-event))
698
699 ;; not used
700 (sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event)
701 (boolean #.sb-vm::n-machine-word-bits)
702 (event-object ws-event))
703
704 (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
705 sb-alien:int
706 (socket ws-socket)
707 (event-object ws-event)
708 (network-events (* (sb-alien:struct wsa-network-events))))
709
710 (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
711 sb-alien:int
712 (socket ws-socket)
713 (event-object ws-event)
714 (network-events sb-alien:long))
715
716 (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)
717 ws-dword
718 (number-of-events ws-dword)
719 (events (* ws-event))
720 (wait-all-p (boolean #.sb-vm::n-machine-word-bits))
721 (timeout ws-dword)
722 (alertable-p (boolean #.sb-vm::n-machine-word-bits)))
723
724 (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)
725 sb-alien:int
726 (socket ws-socket)
727 (cmd sb-alien:long)
728 (argp (* sb-alien:unsigned-long)))
729
730 (defun maybe-wsa-error (rv &optional socket)
731 (unless (zerop rv)
732 (raise-usock-err (sockint::wsa-get-last-error) socket)))
733
734 (defun os-socket-handle (usocket)
735 (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
736
737 (defun bytes-available-for-read (socket)
738 (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
739 (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
740 socket)
741 (prog1 int-ptr
742 (when (plusp int-ptr)
743 (setf (state socket) :read)))))
744
745 (defun map-network-events (func network-events)
746 (let ((event-map (sb-alien:slot network-events 'network-events))
747 (error-array (sb-alien:slot network-events 'error-code)))
748 (unless (zerop event-map)
749 (dotimes (i fd-max-events)
750 (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
751 (funcall func (sb-alien:deref error-array i)))))))
752
753 (defun update-ready-and-state-slots (wait-list)
754 (loop with sockets = (wait-list-waiters wait-list)
755 for socket in sockets do
756 (if (%ready-p socket)
757 (progn
758 (setf (state socket) :READ))
759 (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events)))
760 (let ((rv (wsa-enum-network-events (os-socket-handle socket)
761 (os-wait-list-%wait wait-list)
762 (sb-alien:addr network-events))))
763 (if (zerop rv)
764 (map-network-events
765 #'(lambda (err-code)
766 (if (zerop err-code)
767 (progn
768 (setf (state socket) :READ)
769 (when (stream-server-usocket-p socket)
770 (setf (%ready-p socket) t)))
771 (raise-usock-err err-code socket)))
772 network-events)
773 (maybe-wsa-error rv socket)))))))
774
775 (defun os-wait-list-%wait (wait-list)
776 (sb-alien:deref (wait-list-%wait wait-list)))
777
778 (defun (setf os-wait-list-%wait) (value wait-list)
779 (setf (sb-alien:deref (wait-list-%wait wait-list)) value))
780
781 ;; "Event handles are leaking in current SBCL backend implementation,
782 ;; because of SBCL-unfriendly usage of finalizers.
783 ;;
784 ;; "SBCL never calls a finalizer that closes over a finalized object: a
785 ;; reference from that closure prevents its collection forever. That's
786 ;; the case with USOCKET in %SETUP-WAIT-LIST.
787 ;;
788 ;; "I use the following redefinition of %SETUP-WAIT-LIST:
789 ;;
790 ;; "Of course it may be rewritten with more clarity, but you can see the
791 ;; core idea: I'm closing over those components of WAIT-LIST that I need
792 ;; for finalization, not the wait-list itself. With the original
793 ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted
794 ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."
795 ;;
796 ;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
797
798 (defun %setup-wait-list (wait-list)
799 (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
800 (setf (os-wait-list-%wait wait-list) (wsa-event-create))
801 (sb-ext:finalize wait-list
802 (let ((event-handle (os-wait-list-%wait wait-list))
803 (alien (wait-list-%wait wait-list)))
804 #'(lambda ()
805 (wsa-event-close event-handle)
806 (unless (null alien)
807 (sb-alien:free-alien alien))))))
808
809 ) ; progn
810
811 #+(and (or ecl clasp) (not win32))
812 (progn
813 (defun wait-for-input-internal (wl &key timeout)
814 (with-mapped-conditions ()
815 (multiple-value-bind (secs usecs)
816 (split-timeout (or timeout 1))
817 (multiple-value-bind (result-fds err)
818 (read-select wl (when timeout secs) usecs)
819 (declare (ignore result-fds))
820 (unless (null err)
821 (error (map-errno-error err)))))))
822
823 (defun %setup-wait-list (wl)
824 (setf (wait-list-%wait wl)
825 (fdset-alloc)))
826
827 (defun %add-waiter (wl w)
828 (declare (ignore wl w)))
829
830 (defun %remove-waiter (wl w)
831 (declare (ignore wl w)))
832 ) ; progn
833
834 #+(and (or ecl clasp) win32 (not ecl-bytecmp))
835 (progn
836 (defun maybe-wsa-error (rv &optional syscall)
837 (unless (zerop rv)
838 (sb-bsd-sockets::socket-error syscall)))
839
840 (defun %setup-wait-list (wl)
841 (setf (wait-list-%wait wl)
842 (ffi:c-inline () () :int
843 "WSAEVENT event;
844 event = WSACreateEvent();
845 @(return) = event;")))
846
847 (defun %add-waiter (wait-list waiter)
848 (let ((events (etypecase waiter
849 (stream-server-usocket (logior fd-connect fd-accept fd-close))
850 (stream-usocket (logior fd-read))
851 (datagram-usocket (logior fd-read)))))
852 (maybe-wsa-error
853 (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)
854 (:fixnum :fixnum :fixnum) :fixnum
855 "int result;
856 result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);
857 @(return) = result;")
858 '%add-waiter)))
859
860 (defun %remove-waiter (wait-list waiter)
861 (maybe-wsa-error
862 (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))
863 (:fixnum :fixnum) :fixnum
864 "int result;
865 result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);
866 @(return) = result;")
867 '%remove-waiter))
868
869 ;; TODO: how to handle error (result) in this call?
870 (declaim (inline %bytes-available-for-read))
871 (defun %bytes-available-for-read (socket)
872 (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum
873 "u_long nbytes;
874 int result;
875 nbytes = 0L;
876 result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);
877 @(return) = nbytes;"))
878
879 (defun bytes-available-for-read (socket)
880 (let ((nbytes (%bytes-available-for-read socket)))
881 (when (plusp nbytes)
882 (setf (state socket) :read))
883 nbytes))
884
885 (defun update-ready-and-state-slots (wait-list)
886 (loop with sockets = (wait-list-waiters wait-list)
887 for socket in sockets do
888 (if (%ready-p socket)
889 (setf (state socket) :READ)
890 (let ((events (etypecase socket
891 (stream-server-usocket (logior fd-connect fd-accept fd-close))
892 (stream-usocket (logior fd-read))
893 (datagram-usocket (logior fd-read)))))
894 ;; TODO: check the iErrorCode array
895 (multiple-value-bind (valid-p ready-p)
896 (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum)
897 (values :bool :bool)
898 ;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list)
899 "WSANETWORKEVENTS network_events;
900 int i, result;
901 result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);
902 if (!result) {
903 @(return 0) = Ct;
904 @(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;
905 } else {
906 @(return 0) = Cnil;
907 @(return 1) = Cnil;
908 }")
909 (if valid-p
910 (when ready-p
911 (setf (state socket) :READ)
912 (when (stream-server-usocket-p socket)
913 (setf (%ready-p socket) t)))
914 (sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))))
915
916 (defun wait-for-input-internal (wait-list &key timeout)
917 (when (waiting-required (wait-list-waiters wait-list))
918 (let ((rv (ffi:c-inline ((wait-list-%wait wait-list)
919 (if timeout
920 (truncate (* 1000 timeout))
921 +wsa-infinite+))
922 (:fixnum :fixnum) :fixnum
923 "DWORD result;
924 WSAEVENT events[1];
925 events[0] = (WSAEVENT)#0;
926 result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);
927 @(return) = result;")))
928 (ecase rv
929 ((#.+wsa-wait-event-0+)
930 (update-ready-and-state-slots (wait-list-waiters wait-list)))
931 ((#.+wsa-wait-timeout+)) ; do nothing here
932 ((#.+wsa-wait-failed+)
933 (sb-bsd-sockets::socket-error 'wait-for-input-internal))))))
934
935 ) ; progn