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