sbcl.lisp - clic - Clic is an command line interactive client for gopher writte… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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… | |
21 (* sb-al… | |
22 sb-alien… | |
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-des… | |
109 (socket y)))) | |
110 (if (< x sy) sy x))) | |
111 (cdr sockets) | |
112 :initial-value (sb-bsd-sockets:socket-file-de… | |
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_… | |
146 remaining = remaining - elapsed; | |
147 if ( remaining < 0 ) { // already … | |
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-desc… | |
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-erro… | |
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-erro… | |
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 ni… | |
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-… | |
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-… | |
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-… | |
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 <[email protected]> | |
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-INTERRUP… | |
256 ;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner th… | |
257 ;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus@random-stat… | |
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 '… | |
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-so… | |
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 *… | |
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) nodel… | |
350 (when (or local-host local-port) | |
351 (sb-bsd-sockets:socket-bind socket | |
352 (if ipv6 | |
353 (or local (ipv6-host-to-… | |
354 (or local (host-to-vecto… | |
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 … | |
361 (if timeout | |
362 (%with-timeout (timeout (error 'sb-ext:timeout)) (… | |
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 <[email protected]> said on… | |
372 ;; ... This means that SBCL streams created by u… | |
373 ;; serve-events property. When writing large am… | |
374 ;; streams, the kernel will eventually stop acce… | |
375 ;; When this happens, SBCL either waits for I/O … | |
376 ;; the file descriptor it's writing to or queues… | |
377 ;; Because usocket streams specify serve-events … | |
378 ;; always queues. Instead, it should wait for I… | |
379 ;; write the remaining data to the socket. That… | |
380 ;; equal to NIL gets you. | |
381 ;; | |
382 ;; Nikodemus Siivola <[email protected]… | |
383 ;; It's set to T for purely historical reasons, … | |
384 ;; NIL in SBCL. (The docstring has warned of T b… | |
385 ;; for as long as the :SERVE-EVENTS keyword argu… | |
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-… | |
392 (or local (host-to-vecto… | |
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 reusea… | |
416 (ip #+sbcl (if (and local (not (eq host *wildcard-host*))) | |
417 local | |
418 (hbo-to-vector-quad sb-bsd-sockets-internal::ina… | |
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-sock… | |
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… | |
444 | |
445 (defmethod socket-accept ((usocket stream-server-usocket) &key element-t… | |
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 directi… | |
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) :i… | |
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… | |
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 eleme… | |
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 nu… | |
573 (1+ (reduce #'max wait-list | |
574 :key #'sb-bsd-sockets:socket-file-descript… | |
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-s… | |
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 (bing… | |
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-li… | |
646 nil | |
647 (if timeout | |
648 (truncate (* 1000 time… | |
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 … | |
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 w… | |
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 wai… | |
670 waiter)) | |
671 ) ; progn | |
672 | |
673 #+(and sbcl win32) | |
674 (progn | |
675 ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCK… | |
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 n… | |
680 ;; enough -- potentially)." | |
681 ;; -- Anton Kovalenko <[email protected]>, 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-networ… | |
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-fo… | |
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) fionre… | |
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 fast… | |
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-netwo… | |
760 (let ((rv (wsa-enum-network-events (os-socket-handle socket) | |
761 (os-wait-list-%wait wait-li… | |
762 (sb-alien:addr network-even… | |
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 t… | |
791 ;; core idea: I'm closing over those components of WAIT-LIST that I ne… | |
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 <[email protected]>, 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 … | |
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)… | |
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-acc… | |
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 :fi… | |
897 (values :boo… | |
898 ;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-… | |
899 "WSANETWORKEVENTS network_events; | |
900 int i, result; | |
901 result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_e… | |
902 if (!result) { | |
903 @(return 0) = Ct; | |
904 @(return 1) = (#1 & network_events.lNetworkEvents)? C… | |
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-slot… | |
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,… | |
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 |