lispworks.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
lispworks.lisp (40914B) | |
--- | |
1 ;;;; See LICENSE for licensing information. | |
2 | |
3 (in-package :usocket) | |
4 | |
5 (eval-when (:compile-toplevel :load-toplevel :execute) | |
6 (require "comm") | |
7 | |
8 #+lispworks3 | |
9 (error "LispWorks 3 is not supported")) | |
10 | |
11 ;;; --------------------------------------------------------------------… | |
12 ;;; Warn if multiprocessing is not running on Lispworks | |
13 | |
14 (defun check-for-multiprocessing-started (&optional errorp) | |
15 (unless mp:*current-process* | |
16 (funcall (if errorp 'error 'warn) | |
17 "You must start multiprocessing on Lispworks by calling~ | |
18 ~%~3t(~s)~ | |
19 ~%for ~s function properly." | |
20 'mp:initialize-multiprocessing | |
21 'wait-for-input))) | |
22 | |
23 (eval-when (:load-toplevel :execute) | |
24 (check-for-multiprocessing-started)) | |
25 | |
26 #+win32 | |
27 (eval-when (:load-toplevel :execute) | |
28 (fli:register-module "ws2_32")) | |
29 | |
30 (fli:define-foreign-function (get-host-name-internal "gethostname" :sour… | |
31 ((return-string (:reference-return (:ef-mb-string :limit 257))) | |
32 (namelen :int)) | |
33 :lambda-list (&aux (namelen 256) return-string) | |
34 :result-type :int | |
35 #+win32 :module | |
36 #+win32 "ws2_32") | |
37 | |
38 (defun get-host-name () | |
39 (multiple-value-bind (return-code name) | |
40 (get-host-name-internal) | |
41 (when (zerop return-code) | |
42 name))) | |
43 | |
44 #+win32 | |
45 (defun remap-maybe-for-win32 (z) | |
46 (mapcar #'(lambda (x) | |
47 (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) | |
48 (cdr x))) | |
49 z)) | |
50 | |
51 (defparameter +lispworks-error-map+ | |
52 #+win32 | |
53 (append (remap-maybe-for-win32 +unix-errno-condition-map+) | |
54 (remap-maybe-for-win32 +unix-errno-error-map+)) | |
55 #-win32 | |
56 (append +unix-errno-condition-map+ | |
57 +unix-errno-error-map+)) | |
58 | |
59 (defun raise-usock-err (errno socket &optional condition (host-or-ip nil… | |
60 (let ((usock-error | |
61 (cdr (assoc errno +lispworks-error-map+ :test #'member)))) | |
62 (if usock-error | |
63 (if (subtypep usock-error 'error) | |
64 (cond ((subtypep usock-error 'ns-error) | |
65 (error usock-error :socket socket :host-or-ip host-or… | |
66 (t | |
67 (error usock-error :socket socket))) | |
68 (cond ((subtypep usock-error 'ns-condition) | |
69 (signal usock-error :socket socket :host-or-ip host-o… | |
70 (t | |
71 (signal usock-error :socket socket)))) | |
72 (error 'unknown-error | |
73 :socket socket | |
74 :real-error condition | |
75 :errno errno)))) | |
76 | |
77 (defun handle-condition (condition &optional (socket nil) (host-or-ip ni… | |
78 "Dispatch correct usocket condition." | |
79 (typecase condition | |
80 (condition (let ((errno #-win32 (lw:errno-value) | |
81 #+win32 (wsa-get-last-error))) | |
82 (unless (zerop errno) | |
83 (raise-usock-err errno socket condition host-or-ip)))… | |
84 | |
85 (defconstant *socket_sock_dgram* 2 | |
86 "Connectionless, unreliable datagrams of fixed maximum length.") | |
87 | |
88 (defconstant *socket_ip_proto_udp* 17) | |
89 | |
90 (defconstant *sockopt_so_rcvtimeo* | |
91 #-linux #x1006 | |
92 #+linux 20 | |
93 "Socket receive timeout") | |
94 | |
95 (defconstant *sockopt_so_sndtimeo* | |
96 #-linux #x1007 | |
97 #+linux 21 | |
98 "Socket send timeout") | |
99 | |
100 (fli:define-c-struct timeval | |
101 (tv-sec :long) | |
102 (tv-usec :long)) | |
103 | |
104 ;;; ssize_t | |
105 ;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags, | |
106 ;;; struct sockaddr *restrict address, socklen_t *restrict addr… | |
107 (fli:define-foreign-function (%recvfrom "recvfrom" :source) | |
108 ((socket :int) | |
109 (buffer (:pointer (:unsigned :byte))) | |
110 (length :int) | |
111 (flags :int) | |
112 (address (:pointer (:struct comm::sockaddr))) | |
113 (address-len (:pointer :int))) | |
114 :result-type :int | |
115 #+win32 :module | |
116 #+win32 "ws2_32") | |
117 | |
118 ;;; ssize_t | |
119 ;;; sendto(int socket, const void *buffer, size_t length, int flags, | |
120 ;;; const struct sockaddr *dest_addr, socklen_t dest_len); | |
121 (fli:define-foreign-function (%sendto "sendto" :source) | |
122 ((socket :int) | |
123 (buffer (:pointer (:unsigned :byte))) | |
124 (length :int) | |
125 (flags :int) | |
126 (address (:pointer (:struct comm::sockaddr))) | |
127 (address-len :int)) | |
128 :result-type :int | |
129 #+win32 :module | |
130 #+win32 "ws2_32") | |
131 | |
132 #-win32 | |
133 (defun set-socket-receive-timeout (socket-fd seconds) | |
134 "Set socket option: RCVTIMEO, argument seconds can be a float number" | |
135 (declare (type integer socket-fd) | |
136 (type number seconds)) | |
137 (multiple-value-bind (sec usec) (truncate seconds) | |
138 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) | |
139 (fli:with-foreign-slots (tv-sec tv-usec) timeout | |
140 (setf tv-sec sec | |
141 tv-usec (truncate (* 1000000 usec))) | |
142 (if (zerop (comm::setsockopt socket-fd | |
143 comm::*sockopt_sol_socket* | |
144 *sockopt_so_rcvtimeo* | |
145 (fli:copy-pointer timeout | |
146 :type '(:pointer :void)) | |
147 (fli:size-of '(:struct timeval)))) | |
148 seconds))))) | |
149 | |
150 #-win32 | |
151 (defun set-socket-send-timeout (socket-fd seconds) | |
152 "Set socket option: SNDTIMEO, argument seconds can be a float number" | |
153 (declare (type integer socket-fd) | |
154 (type number seconds)) | |
155 (multiple-value-bind (sec usec) (truncate seconds) | |
156 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) | |
157 (fli:with-foreign-slots (tv-sec tv-usec) timeout | |
158 (setf tv-sec sec | |
159 tv-usec (truncate (* 1000000 usec))) | |
160 (if (zerop (comm::setsockopt socket-fd | |
161 comm::*sockopt_sol_socket* | |
162 *sockopt_so_sndtimeo* | |
163 (fli:copy-pointer timeout | |
164 :type '(:pointer :void)) | |
165 (fli:size-of '(:struct timeval)))) | |
166 seconds))))) | |
167 | |
168 #+win32 | |
169 (defun set-socket-receive-timeout (socket-fd seconds) | |
170 "Set socket option: RCVTIMEO, argument seconds can be a float number. | |
171 On win32, you must bind the socket before use this function." | |
172 (declare (type integer socket-fd) | |
173 (type number seconds)) | |
174 (fli:with-dynamic-foreign-objects ((timeout :int)) | |
175 (setf (fli:dereference timeout) | |
176 (truncate (* 1000 seconds))) | |
177 (if (zerop (comm::setsockopt socket-fd | |
178 comm::*sockopt_sol_socket* | |
179 *sockopt_so_rcvtimeo* | |
180 (fli:copy-pointer timeout | |
181 :type '(:pointer :char)) | |
182 (fli:size-of :int))) | |
183 seconds))) | |
184 | |
185 #+win32 | |
186 (defun set-socket-send-timeout (socket-fd seconds) | |
187 "Set socket option: SNDTIMEO, argument seconds can be a float number. | |
188 On win32, you must bind the socket before use this function." | |
189 (declare (type integer socket-fd) | |
190 (type number seconds)) | |
191 (fli:with-dynamic-foreign-objects ((timeout :int)) | |
192 (setf (fli:dereference timeout) | |
193 (truncate (* 1000 seconds))) | |
194 (if (zerop (comm::setsockopt socket-fd | |
195 comm::*sockopt_sol_socket* | |
196 *sockopt_so_sndtimeo* | |
197 (fli:copy-pointer timeout | |
198 :type '(:pointer :char)) | |
199 (fli:size-of :int))) | |
200 seconds))) | |
201 | |
202 #-win32 | |
203 (defun get-socket-receive-timeout (socket-fd) | |
204 "Get socket option: RCVTIMEO, return value is a float number" | |
205 (declare (type integer socket-fd)) | |
206 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) | |
207 (len :int)) | |
208 (comm::getsockopt socket-fd | |
209 comm::*sockopt_sol_socket* | |
210 *sockopt_so_rcvtimeo* | |
211 (fli:copy-pointer timeout | |
212 :type '(:pointer :void)) | |
213 len) | |
214 (fli:with-foreign-slots (tv-sec tv-usec) timeout | |
215 (float (+ tv-sec (/ tv-usec 1000000)))))) | |
216 | |
217 #-win32 | |
218 (defun get-socket-send-timeout (socket-fd) | |
219 "Get socket option: SNDTIMEO, return value is a float number" | |
220 (declare (type integer socket-fd)) | |
221 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) | |
222 (len :int)) | |
223 (comm::getsockopt socket-fd | |
224 comm::*sockopt_sol_socket* | |
225 *sockopt_so_sndtimeo* | |
226 (fli:copy-pointer timeout | |
227 :type '(:pointer :void)) | |
228 len) | |
229 (fli:with-foreign-slots (tv-sec tv-usec) timeout | |
230 (float (+ tv-sec (/ tv-usec 1000000)))))) | |
231 | |
232 #+win32 | |
233 (defun get-socket-receive-timeout (socket-fd) | |
234 "Get socket option: RCVTIMEO, return value is a float number" | |
235 (declare (type integer socket-fd)) | |
236 (fli:with-dynamic-foreign-objects ((timeout :int) | |
237 (len :int)) | |
238 (comm::getsockopt socket-fd | |
239 comm::*sockopt_sol_socket* | |
240 *sockopt_so_rcvtimeo* | |
241 (fli:copy-pointer timeout | |
242 :type '(:pointer :void)) | |
243 len) | |
244 (float (/ (fli:dereference timeout) 1000)))) | |
245 | |
246 #+win32 | |
247 (defun get-socket-send-timeout (socket-fd) | |
248 "Get socket option: SNDTIMEO, return value is a float number" | |
249 (declare (type integer socket-fd)) | |
250 (fli:with-dynamic-foreign-objects ((timeout :int) | |
251 (len :int)) | |
252 (comm::getsockopt socket-fd | |
253 comm::*sockopt_sol_socket* | |
254 *sockopt_so_sndtimeo* | |
255 (fli:copy-pointer timeout | |
256 :type '(:pointer :void)) | |
257 len) | |
258 (float (/ (fli:dereference timeout) 1000)))) | |
259 | |
260 #+(or lispworks4 lispworks5.0) | |
261 (defun set-socket-tcp-nodelay (socket-fd new-value) | |
262 "Set socket option: TCP_NODELAY, argument is a fixnum (0 or 1)" | |
263 (declare (type integer socket-fd) | |
264 (type (integer 0 1) new-value)) | |
265 (fli:with-dynamic-foreign-objects ((zero-or-one :int)) | |
266 (setf (fli:dereference zero-or-one) new-value) | |
267 (when (zerop (comm::setsockopt socket-fd | |
268 comm::*sockopt_sol_socket* | |
269 comm::*sockopt_tcp_nodelay* | |
270 (fli:copy-pointer zero-or-one | |
271 :type '(:pointer #+… | |
272 (fli:size-of :int))) | |
273 new-value))) | |
274 | |
275 (defun get-socket-tcp-nodelay (socket-fd) | |
276 "Get socket option: TCP_NODELAY, return value is a fixnum (0 or 1)" | |
277 (declare (type integer socket-fd)) | |
278 (fli:with-dynamic-foreign-objects ((zero-or-one :int) | |
279 (len :int)) | |
280 (if (zerop (comm::getsockopt socket-fd | |
281 comm::*sockopt_sol_socket* | |
282 comm::*sockopt_tcp_nodelay* | |
283 (fli:copy-pointer zero-or-one | |
284 :type '(:pointer #+wi… | |
285 len)) | |
286 zero-or-one 0))) ; on error, return 0 | |
287 | |
288 (defun initialize-dynamic-sockaddr (hostname service protocol &aux (orig… | |
289 (declare (ignorable original-hostname)) | |
290 #+(or lispworks4 lispworks5 lispworks6.0) | |
291 (let ((server-addr (fli:allocate-dynamic-foreign-object | |
292 :type '(:struct comm::sockaddr_in)))) | |
293 (values (comm::initialize-sockaddr_in | |
294 server-addr | |
295 comm::*socket_af_inet* | |
296 hostname | |
297 service protocol) | |
298 comm::*socket_af_inet* | |
299 server-addr | |
300 (fli:pointer-element-size server-addr))) | |
301 #-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1 | |
302 (progn | |
303 (when (stringp hostname) | |
304 (setq hostname (comm:string-ip-address hostname)) | |
305 (unless hostname | |
306 (let ((resolved-hostname (comm:get-host-entry original-hostname … | |
307 (unless resolved-hostname | |
308 (return-from initialize-dynamic-sockaddr :unknown-host)) | |
309 (setq hostname resolved-hostname)))) | |
310 (if (or (null hostname) | |
311 (integerp hostname) | |
312 (comm:ipv6-address-p hostname)) | |
313 (let ((server-addr (fli:allocate-dynamic-foreign-object | |
314 :type '(:struct comm::lw-sockaddr)))) | |
315 (multiple-value-bind (error family) | |
316 (comm::initialize-sockaddr_in | |
317 server-addr | |
318 hostname | |
319 service protocol) | |
320 (values error family | |
321 server-addr | |
322 (if (eql family comm::*socket_af_inet*) | |
323 (fli:size-of '(:struct comm::sockaddr_in)) | |
324 (fli:size-of '(:struct comm::sockaddr_in6)))))) | |
325 :bad-host))) | |
326 | |
327 (defun open-udp-socket (&key local-address local-port read-timeout | |
328 (address-family comm::*socket_af_inet*)) | |
329 "Open a unconnected UDP socket. | |
330 For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL), | |
331 for binding on random free unused port, set LOCAL-PORT to 0." | |
332 | |
333 ;; Note: move (ensure-sockets) here to make sure delivered applications | |
334 ;; correctly have networking support initialized. | |
335 ;; | |
336 ;; Following words was from Martin Simmons, forwarded by Camille Troil… | |
337 | |
338 ;; Calling comm::ensure-sockets at load time looks like a bug in Lispw… | |
339 ;; (it is too early and also unnecessary). | |
340 | |
341 ;; The LispWorks comm package calls comm::ensure-sockets when it is ne… | |
342 ;; think open-udp-socket should probably do it too. Calling it more t… | |
343 ;; safe and it will be very fast after the first time. | |
344 #+win32 (comm::ensure-sockets) | |
345 | |
346 (let ((socket-fd (comm::socket address-family *socket_sock_dgram* *soc… | |
347 (if socket-fd | |
348 (progn | |
349 (when read-timeout (set-socket-receive-timeout socket-fd read-… | |
350 (if local-port | |
351 (fli:with-dynamic-foreign-objects () | |
352 (multiple-value-bind (error local-address-family | |
353 client-addr client-addr-leng… | |
354 (initialize-dynamic-sockaddr local-address local-por… | |
355 (if (or error (not (eql address-family local-address-f… | |
356 (progn | |
357 (comm::close-socket socket-fd) | |
358 (error "cannot resolve hostname ~S, service ~S: … | |
359 local-address local-port (or error "addre… | |
360 (if (comm::bind socket-fd client-addr client-addr-le… | |
361 ;; success, return socket fd | |
362 socket-fd | |
363 (progn | |
364 (comm::close-socket socket-fd) | |
365 (error "cannot bind")))))) | |
366 socket-fd)) | |
367 (error "cannot create socket")))) | |
368 | |
369 (defun connect-to-udp-server (hostname service | |
370 &key local-address local-port rea… | |
371 "Something like CONNECT-TO-TCP-SERVER" | |
372 (fli:with-dynamic-foreign-objects () | |
373 (multiple-value-bind (error address-family server-addr server-addr-l… | |
374 (initialize-dynamic-sockaddr hostname service "udp") | |
375 (when error | |
376 (error "cannot resolve hostname ~S, service ~S: ~A" | |
377 hostname service error)) | |
378 (let ((socket-fd (open-udp-socket :local-address local-address | |
379 :local-port local-port | |
380 :read-timeout read-timeout | |
381 :address-family address-family))) | |
382 (if socket-fd | |
383 (if (comm::connect socket-fd server-addr server-addr-length) | |
384 ;; success, return socket fd | |
385 socket-fd | |
386 ;; fail, close socket and return nil | |
387 (progn | |
388 (comm::close-socket socket-fd) | |
389 (error "cannot connect"))) | |
390 (error "cannot create socket")))))) | |
391 | |
392 (defun socket-connect (host port &key (protocol :stream) (element-type '… | |
393 timeout deadline (nodelay t) | |
394 local-host local-port) | |
395 ;; What's the meaning of this keyword? | |
396 (when deadline | |
397 (unimplemented 'deadline 'socket-connect)) | |
398 | |
399 #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5 | |
400 (when timeout | |
401 (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5")) | |
402 | |
403 #+lispworks4 | |
404 (when local-host | |
405 (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0")) | |
406 #+lispworks4 | |
407 (when local-port | |
408 (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0")) | |
409 | |
410 (ecase protocol | |
411 (:stream | |
412 (let ((hostname (host-to-hostname host)) | |
413 (stream)) | |
414 (setq stream | |
415 (with-mapped-conditions (nil host) | |
416 (comm:open-tcp-stream hostname port | |
417 :element-type element-type | |
418 #-(and lispworks4 (not lispworks4.4… | |
419 #-(and lispworks4 (not lispworks4.4… | |
420 :timeout timeout | |
421 #-lispworks4 #-lispworks4 | |
422 #-lispworks4 #-lispworks4 | |
423 :local-address (when local-host (ho… | |
424 :local-port local-port | |
425 #-(or lispworks4 lispworks5.0) ; >=… | |
426 #-(or lispworks4 lispworks5.0) | |
427 :nodelay nodelay))) | |
428 | |
429 ;; Then handle `nodelay' separately for older versions <= 5.0 | |
430 #+(or lispworks4 lispworks5.0) | |
431 (when (and stream nodelay) | |
432 (set-socket-tcp-nodelay | |
433 (comm:socket-stream-socket stream) | |
434 (bool->int nodelay))) ; ":if-supported" maps to 1 too. | |
435 | |
436 (if stream | |
437 (make-stream-socket :socket (comm:socket-stream-socket stream) | |
438 :stream stream) | |
439 ;; if no other error catched by above with-mapped-conditions an… | |
440 (error 'timeout-error)))) | |
441 (:datagram | |
442 (let ((usocket (make-datagram-socket | |
443 (if (and host port) | |
444 (with-mapped-conditions (nil host) | |
445 (connect-to-udp-server (host-to-hostname host… | |
446 :local-address (and lo… | |
447 :local-port local-port | |
448 :read-timeout timeout)) | |
449 (with-mapped-conditions (nil local-host) | |
450 (open-udp-socket :local-address (and lo… | |
451 :local-port local-port | |
452 :read-timeout timeout)… | |
453 :connected-p (and host port t)))) | |
454 usocket)))) | |
455 | |
456 (defun socket-listen (host port | |
457 &key reuseaddress | |
458 (reuse-address nil reuse-address-supplied-p) | |
459 (backlog 5) | |
460 (element-type 'base-char)) | |
461 #+lispworks4.1 | |
462 (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer tha… | |
463 #+lispworks4.1 | |
464 (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer … | |
465 | |
466 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reusea… | |
467 (comm::*use_so_reuseaddr* reuseaddress) | |
468 (hostname (host-to-hostname host)) | |
469 (socket-res-list (with-mapped-conditions (nil host) | |
470 (multiple-value-list | |
471 #-lispworks4.1 (comm::create-tcp-socket-for… | |
472 port :address hostname :bac… | |
473 #+lispworks4.1 (comm::create-tcp-socket-for… | |
474 (sock (if (not (or (second socket-res-list) (third socket-res-l… | |
475 (first socket-res-list) | |
476 (when (eq (second socket-res-list) :bind) | |
477 (error 'address-in-use-error))))) | |
478 (make-stream-server-socket sock :element-type element-type))) | |
479 | |
480 ;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operatio… | |
481 ;; should NOT be applied on socket FDs who have already been called on W… | |
482 ;; so we have to check the %READY-P slot to decide if this waiting is ne… | |
483 ;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011 | |
484 | |
485 (defmethod socket-accept ((usocket stream-server-usocket) &key element-t… | |
486 (let* ((socket (with-mapped-conditions (usocket) | |
487 #+win32 | |
488 (if (%ready-p usocket) | |
489 (comm::accept-connection-to-socket (socket usocke… | |
490 (comm::get-fd-from-socket (socket usocket))) | |
491 #-win32 | |
492 (comm::get-fd-from-socket (socket usocket)))) | |
493 (stream (make-instance 'comm:socket-stream | |
494 :socket socket | |
495 :direction :io | |
496 :element-type (or element-type | |
497 (element-type usocket)… | |
498 #+win32 | |
499 (when socket | |
500 (setf (%ready-p usocket) nil)) | |
501 (make-stream-socket :socket socket :stream stream))) | |
502 | |
503 ;; Sockets and their streams are different objects | |
504 ;; close the stream in order to make sure buffers | |
505 ;; are correctly flushed and the socket closed. | |
506 (defmethod socket-close ((usocket stream-usocket)) | |
507 "Close socket." | |
508 (close (socket-stream usocket))) | |
509 | |
510 (defmethod socket-close ((usocket usocket)) | |
511 (with-mapped-conditions (usocket) | |
512 (comm::close-socket (socket usocket)))) | |
513 | |
514 (defmethod socket-close :after ((socket datagram-usocket)) | |
515 "Additional socket-close method for datagram-usocket" | |
516 (setf (%open-p socket) nil)) | |
517 | |
518 (defconstant +shutdown-read+ 0) | |
519 (defconstant +shutdown-write+ 1) | |
520 (defconstant +shutdown-read-write+ 2) | |
521 | |
522 ;;; int | |
523 ;;; shutdown(int socket, int what); | |
524 (fli:define-foreign-function (%shutdown "shutdown" :source) | |
525 ((socket :int) | |
526 (what :int)) | |
527 :result-type :int | |
528 #+win32 :module | |
529 #+win32 "ws2_32") | |
530 | |
531 (defmethod socket-shutdown ((usocket datagram-usocket) direction) | |
532 (unless (member direction '(:input :output :io)) | |
533 (error 'invalid-argument-error)) | |
534 (let ((what (case direction | |
535 (:input +shutdown-read+) | |
536 (:output +shutdown-write+) | |
537 (:io +shutdown-read-write+)))) | |
538 (with-mapped-conditions (usocket) | |
539 #-(or lispworks4 lispworks5 lispworks6) ; lispworks 7.0+ | |
540 (comm::shutdown (socket usocket) what) | |
541 #+(or lispworks4 lispworks5 lispworks6) | |
542 (= 0 (%shutdown (socket usocket) what))))) | |
543 | |
544 (defmethod socket-shutdown ((usocket stream-usocket) direction) | |
545 (unless (member direction '(:input :output :io)) | |
546 (error 'invalid-argument-error)) | |
547 (with-mapped-conditions (usocket) | |
548 #-(or lispworks4 lispworks5 lispworks6) | |
549 (comm:socket-stream-shutdown (socket usocket) direction) | |
550 #+(or lispworks4 lispworks5 lispworks6) | |
551 (let ((what (case direction | |
552 (:input +shutdown-read+) | |
553 (:output +shutdown-write+) | |
554 (:io +shutdown-read-write+)))) | |
555 (= 0 (%shutdown (comm:socket-stream-socket (socket usocket)) what)… | |
556 | |
557 (defmethod initialize-instance :after ((socket datagram-usocket) &key) | |
558 (setf (slot-value socket 'send-buffer) | |
559 (make-array +max-datagram-packet-size+ | |
560 :element-type '(unsigned-byte 8) | |
561 :allocation :static)) | |
562 (setf (slot-value socket 'recv-buffer) | |
563 (make-array +max-datagram-packet-size+ | |
564 :element-type '(unsigned-byte 8) | |
565 :allocation :static))) | |
566 | |
567 (defvar *length-of-sockaddr_in* | |
568 (fli:size-of '(:struct comm::sockaddr_in))) | |
569 | |
570 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
571 &aux (socket-fd (socket usocket)) | |
572 (message (slot-value usocket 'send-buffer))… | |
573 "Send message to a socket, using sendto()/send()" | |
574 (declare (type integer socket-fd) | |
575 (type sequence buffer)) | |
576 (when host (setq host (host-to-hostname host))) | |
577 (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :b… | |
578 (replace message buffer :start2 offset :end2 (+ offset size)) | |
579 (let ((n (if (and host port) | |
580 (fli:with-dynamic-foreign-objects () | |
581 (multiple-value-bind (error family client-addr client… | |
582 (initialize-dynamic-sockaddr host port "udp") | |
583 (declare (ignore family)) | |
584 (when error | |
585 (error "cannot resolve hostname ~S, port ~S: ~A" | |
586 host port error)) | |
587 (%sendto socket-fd ptr (min size +max-datagram-pack… | |
588 (fli:copy-pointer client-addr :type '(:str… | |
589 client-addr-length))) | |
590 (comm::%send socket-fd ptr (min size +max-datagram-packet… | |
591 (declare (type fixnum n)) | |
592 (if (plusp n) | |
593 n | |
594 (let ((errno #-win32 (lw:errno-value) | |
595 #+win32 (wsa-get-last-error))) | |
596 (if (zerop errno) | |
597 n | |
598 (raise-usock-err errno socket-fd host))))))) | |
599 | |
600 (defmethod socket-receive ((socket datagram-usocket) buffer length &key … | |
601 "Receive message from socket, read-timeout is a float number in second… | |
602 | |
603 This function will return 4 values: | |
604 1. receive buffer | |
605 2. number of receive bytes | |
606 3. remote address | |
607 4. remote port" | |
608 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer | |
609 (integer 0) ; size | |
610 (unsigned-byte 32) ; host | |
611 (unsigned-byte 16)) ; port | |
612 (type sequence buffer)) | |
613 (let ((socket-fd (socket socket)) | |
614 (message (slot-value socket 'recv-buffer)) ; TODO: how multiple … | |
615 (read-timeout timeout) | |
616 old-timeout) | |
617 (declare (type integer socket-fd)) | |
618 (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::socka… | |
619 (len :int | |
620 #-(or lispworks4 lispworks5.… | |
621 :initial-element *length-of-… | |
622 #+(or lispworks4 lispworks5.0) ; <= 5.0 | |
623 (setf (fli:dereference len) *length-of-sockaddr_in*) | |
624 (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigne… | |
625 ;; setup new read timeout | |
626 (when read-timeout | |
627 (setf old-timeout (get-socket-receive-timeout socket-fd)) | |
628 (set-socket-receive-timeout socket-fd read-timeout)) | |
629 (let ((n (%recvfrom socket-fd ptr max-buffer-size 0 | |
630 (fli:copy-pointer client-addr :type '(:struc… | |
631 len))) | |
632 (declare (type fixnum n)) | |
633 ;; restore old read timeout | |
634 (when (and read-timeout (/= old-timeout read-timeout)) | |
635 (set-socket-receive-timeout socket-fd old-timeout)) | |
636 ;; Frank James' patch: reset the %read-p for WAIT-FOR-INPUT | |
637 #+win32 (setf (%ready-p socket) nil) | |
638 (if (plusp n) | |
639 (values (if buffer | |
640 (replace buffer message | |
641 :end1 (min length max-buffer-size) | |
642 :end2 (min n max-buffer-size)) | |
643 (subseq message 0 (min n max-buffer-size))) | |
644 (min n max-buffer-size) | |
645 (comm::ntohl (fli:foreign-slot-value | |
646 (fli:foreign-slot-value client-addr | |
647 'comm::sin_a… | |
648 :object-type… | |
649 :type '(:str… | |
650 :copy-foreig… | |
651 'comm::s_addr | |
652 :object-type '(:struct comm::in_addr… | |
653 (comm::ntohs (fli:foreign-slot-value client-addr | |
654 'comm::sin_po… | |
655 :object-type … | |
656 :type '(:unsi… | |
657 :copy-foreign… | |
658 (let ((errno #-win32 (lw:errno-value) | |
659 #+win32 (wsa-get-last-error))) | |
660 (if (zerop errno) | |
661 (values nil n 0 0) | |
662 (raise-usock-err errno socket-fd))))))))) | |
663 | |
664 (defmethod get-local-name ((usocket usocket)) | |
665 (multiple-value-bind | |
666 (address port) | |
667 (comm:get-socket-address (socket usocket)) | |
668 (values (hbo-to-vector-quad address) port))) | |
669 | |
670 (defmethod get-peer-name ((usocket stream-usocket)) | |
671 (multiple-value-bind | |
672 (address port) | |
673 (comm:get-socket-peer-address (socket usocket)) | |
674 (values (hbo-to-vector-quad address) port))) | |
675 | |
676 (defmethod get-local-address ((usocket usocket)) | |
677 (nth-value 0 (get-local-name usocket))) | |
678 | |
679 (defmethod get-peer-address ((usocket stream-usocket)) | |
680 (nth-value 0 (get-peer-name usocket))) | |
681 | |
682 (defmethod get-local-port ((usocket usocket)) | |
683 (nth-value 1 (get-local-name usocket))) | |
684 | |
685 (defmethod get-peer-port ((usocket stream-usocket)) | |
686 (nth-value 1 (get-peer-name usocket))) | |
687 | |
688 #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1 | |
689 (defun ipv6-address-p (hostname) | |
690 (when (stringp hostname) | |
691 (setq hostname (comm:string-ip-address hostname)) | |
692 (unless hostname | |
693 (let ((resolved-hostname (comm:get-host-entry hostname :fields '(:… | |
694 (unless resolved-hostname | |
695 (return-from ipv6-address-p nil)) | |
696 (setq hostname resolved-hostname)))) | |
697 (comm:ipv6-address-p hostname)) | |
698 | |
699 (defun lw-hbo-to-vector-quad (hbo) | |
700 #+(or lispworks4 lispworks5 lispworks6.0) | |
701 (hbo-to-vector-quad hbo) | |
702 #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1 | |
703 (if (comm:ipv6-address-p hbo) | |
704 (ipv6-host-to-vector (comm:ipv6-address-string hbo)) | |
705 (hbo-to-vector-quad hbo))) | |
706 | |
707 (defun get-hosts-by-name (name) | |
708 (with-mapped-conditions (nil name) | |
709 (mapcar #'lw-hbo-to-vector-quad | |
710 (comm:get-host-entry name :fields '(:addresses))))) | |
711 | |
712 (defun get-host-by-address (address) | |
713 (with-mapped-conditions (nil address) | |
714 nil)) ;; TODO | |
715 | |
716 (defun os-socket-handle (usocket) | |
717 (socket usocket)) | |
718 | |
719 (defun usocket-listen (usocket) | |
720 (if (stream-usocket-p usocket) | |
721 (when (listen (socket-stream usocket)) | |
722 usocket) | |
723 (when (comm::socket-listen (socket usocket)) | |
724 usocket))) | |
725 | |
726 ;;; | |
727 ;;; Non Windows implementation | |
728 ;;; The Windows implementation needs to resort to the Windows API in o… | |
729 ;;; to achieve what we want (what we want is waiting without busy-loop… | |
730 ;;; | |
731 | |
732 #-win32 | |
733 (progn | |
734 | |
735 (defun %setup-wait-list (wait-list) | |
736 (declare (ignore wait-list))) | |
737 | |
738 (defun %add-waiter (wait-list waiter) | |
739 (declare (ignore wait-list waiter))) | |
740 | |
741 (defun %remove-waiter (wait-list waiter) | |
742 (declare (ignore wait-list waiter))) | |
743 | |
744 (defun wait-for-input-internal (wait-list &key timeout) | |
745 (with-mapped-conditions () | |
746 ;; unfortunately, it's impossible to share code between | |
747 ;; non-win32 and win32 platforms... | |
748 ;; Can we have a sane -pref. complete [UDP!?]- API next time, plea… | |
749 (dolist (x (wait-list-waiters wait-list)) | |
750 (mp:notice-fd (os-socket-handle x))) | |
751 (labels ((wait-function (socks) | |
752 (let (rv) | |
753 (dolist (x socks rv) | |
754 (when (usocket-listen x) | |
755 (setf (state x) :READ | |
756 rv t)))))) | |
757 (if timeout | |
758 (mp:process-wait-with-timeout "Waiting for a socket to becom… | |
759 (truncate timeout) | |
760 #'wait-function | |
761 (wait-list-waiters wait-list)) | |
762 (mp:process-wait "Waiting for a socket to become active" | |
763 #'wait-function | |
764 (wait-list-waiters wait-list)))) | |
765 (dolist (x (wait-list-waiters wait-list)) | |
766 (mp:unnotice-fd (os-socket-handle x))) | |
767 wait-list)) | |
768 | |
769 ) ; end of block | |
770 | |
771 | |
772 ;;; | |
773 ;;; The Windows side of the story | |
774 ;;; We want to wait without busy looping | |
775 ;;; This code only works in threads which don't have (hidden) | |
776 ;;; windows which need to receive messages. There are workarounds in … | |
777 ;;; but are those available to 'us'. | |
778 ;;; | |
779 | |
780 | |
781 #+win32 | |
782 (progn | |
783 | |
784 ;; LispWorks doesn't provide an interface to wait for a socket | |
785 ;; to become ready (under Win32, that is) meaning that we need | |
786 ;; to resort to system calls to achieve the same thing. | |
787 ;; Luckily, it provides us access to the raw socket handles (as we | |
788 ;; wrote the code above. | |
789 | |
790 (defconstant fd-read 1) | |
791 (defconstant fd-read-bit 0) | |
792 (defconstant fd-write 2) | |
793 (defconstant fd-write-bit 1) | |
794 (defconstant fd-oob 4) | |
795 (defconstant fd-oob-bit 2) | |
796 (defconstant fd-accept 8) | |
797 (defconstant fd-accept-bit 3) | |
798 (defconstant fd-connect 16) | |
799 (defconstant fd-connect-bit 4) | |
800 (defconstant fd-close 32) | |
801 (defconstant fd-close-bit 5) | |
802 (defconstant fd-qos 64) | |
803 (defconstant fd-qos-bit 6) | |
804 (defconstant fd-group-qos 128) | |
805 (defconstant fd-group-qos-bit 7) | |
806 (defconstant fd-routing-interface 256) | |
807 (defconstant fd-routing-interface-bit 8) | |
808 (defconstant fd-address-list-change 512) | |
809 (defconstant fd-address-list-change-bit 9) | |
810 | |
811 (defconstant fd-max-events 10) | |
812 | |
813 (defconstant fionread 1074030207) | |
814 | |
815 | |
816 ;; Note: | |
817 ;; | |
818 ;; If special finalization has to occur for a given | |
819 ;; system resource (handle), an associated object should | |
820 ;; be created. A special cleanup action should be added | |
821 ;; to the system and a special cleanup action should | |
822 ;; be flagged on all objects created for resources like it | |
823 ;; | |
824 ;; We have 2 functions to do so: | |
825 ;; * hcl:add-special-free-action (function-symbol) | |
826 ;; * hcl:flag-special-free-action (object) | |
827 ;; | |
828 ;; Note that the special free action will be called on all | |
829 ;; objects which have been flagged for special free, so be | |
830 ;; sure to check for the right argument type! | |
831 | |
832 (fli:define-foreign-type ws-socket () '(:unsigned :int)) | |
833 (fli:define-foreign-type win32-handle () '(:unsigned :int)) | |
834 (fli:define-c-struct wsa-network-events | |
835 (network-events :long) | |
836 (error-code (:c-array :int 10))) | |
837 | |
838 (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :sourc… | |
839 () | |
840 :lambda-list nil | |
841 :result-type :int | |
842 :module "ws2_32") | |
843 | |
844 (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source) | |
845 ((event-object win32-handle)) | |
846 :result-type :int | |
847 :module "ws2_32") | |
848 | |
849 ;; not used | |
850 (fli:define-foreign-function (wsa-reset-event "WSAResetEvent" :source) | |
851 ((event-object win32-handle)) | |
852 :result-type :int | |
853 :module "ws2_32") | |
854 | |
855 (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkE… | |
856 ((socket ws-socket) | |
857 (event-object win32-handle) | |
858 (network-events (:reference-return wsa-network-events))) | |
859 :result-type :int | |
860 :module "ws2_32") | |
861 | |
862 (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :sourc… | |
863 ((socket ws-socket) | |
864 (event-object win32-handle) | |
865 (network-events :long)) | |
866 :result-type :int | |
867 :module "ws2_32") | |
868 | |
869 (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :so… | |
870 () | |
871 :result-type :int | |
872 :module "ws2_32") | |
873 | |
874 (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source) | |
875 ((socket :long) (cmd :long) (argp (:ptr :long))) | |
876 :result-type :int | |
877 :module "ws2_32") | |
878 | |
879 | |
880 ;; The Windows system | |
881 | |
882 | |
883 ;; Now that we have access to the system calls, this is the plan: | |
884 | |
885 ;; 1. Receive a wait-list with associated sockets to wait for | |
886 ;; 2. Add all those sockets to an event handle | |
887 ;; 3. Listen for an event on that handle (we have a LispWorks system::… | |
888 ;; 4. After listening, detect if there are errors | |
889 ;; (this step is different from Unix, where we can have only one er… | |
890 ;; 5. If so, raise one of them | |
891 ;; 6. If not so, return the sockets which have input waiting for them | |
892 | |
893 | |
894 (defun maybe-wsa-error (rv &optional socket) | |
895 (unless (zerop rv) | |
896 (raise-usock-err (wsa-get-last-error) socket))) | |
897 | |
898 (defun bytes-available-for-read (socket) | |
899 (fli:with-dynamic-foreign-objects ((int-ptr :long)) | |
900 (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-… | |
901 (if (= 0 rv) | |
902 (fli:dereference int-ptr) | |
903 0)))) | |
904 | |
905 (defun socket-ready-p (socket) | |
906 (if (typep socket 'stream-usocket) | |
907 (< 0 (bytes-available-for-read socket)) | |
908 (%ready-p socket))) | |
909 | |
910 (defun waiting-required (sockets) | |
911 (notany #'socket-ready-p sockets)) | |
912 | |
913 (defun wait-for-input-internal (wait-list &key timeout) | |
914 (when (waiting-required (wait-list-waiters wait-list)) | |
915 (system:wait-for-single-object (wait-list-%wait wait-list) | |
916 "Waiting for socket activity" timeo… | |
917 (update-ready-and-state-slots wait-list)) | |
918 | |
919 (defun map-network-events (func network-events) | |
920 (let ((event-map (fli:foreign-slot-value network-events 'network-eve… | |
921 (error-array (fli:foreign-slot-pointer network-events 'error-c… | |
922 (unless (zerop event-map) | |
923 (dotimes (i fd-max-events) | |
924 (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be fast… | |
925 (funcall func (fli:foreign-aref error-array i))))))) | |
926 | |
927 (defun update-ready-and-state-slots (wait-list) | |
928 (loop with sockets = (wait-list-waiters wait-list) | |
929 for socket in sockets do | |
930 (if (or (and (stream-usocket-p socket) | |
931 (listen (socket-stream socket))) | |
932 (%ready-p socket)) | |
933 (setf (state socket) :READ) | |
934 (multiple-value-bind | |
935 (rv network-events) | |
936 (wsa-enum-network-events (os-socket-handle socket) | |
937 (wait-list-%wait wait-list) | |
938 t) | |
939 (if (zerop rv) | |
940 (map-network-events #'(lambda (err-code) | |
941 (if (zerop err-code) | |
942 (setf (%ready-p socket) t | |
943 (state socket) :READ) | |
944 (raise-usock-err err-code socket… | |
945 network-events) | |
946 (maybe-wsa-error rv socket)))))) | |
947 | |
948 ;; The wait-list part | |
949 | |
950 (defun free-wait-list (wl) | |
951 (when (wait-list-p wl) | |
952 (unless (null (wait-list-%wait wl)) | |
953 (wsa-event-close (wait-list-%wait wl)) | |
954 (setf (wait-list-%wait wl) nil)))) | |
955 | |
956 (eval-when (:load-toplevel :execute) | |
957 (hcl:add-special-free-action 'free-wait-list)) | |
958 | |
959 (defun %setup-wait-list (wait-list) | |
960 (hcl:flag-special-free-action wait-list) | |
961 (setf (wait-list-%wait wait-list) (wsa-event-create))) | |
962 | |
963 (defun %add-waiter (wait-list waiter) | |
964 (let ((events (etypecase waiter | |
965 (stream-server-usocket (logior fd-connect fd-accept … | |
966 (stream-usocket (logior fd-connect fd-read fd-oob fd… | |
967 (datagram-usocket (logior fd-read))))) | |
968 (maybe-wsa-error | |
969 (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait… | |
970 waiter))) | |
971 | |
972 (defun %remove-waiter (wait-list waiter) | |
973 (maybe-wsa-error | |
974 (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-l… | |
975 waiter)) | |
976 | |
977 ) ; end of WIN32-block | |
978 | |
979 (defun set-socket-reuse-address (socket-fd reuse-address-p) | |
980 (declare (type integer socket-fd) | |
981 (type boolean reuse-address-p)) | |
982 (fli:with-dynamic-foreign-objects ((value :int)) | |
983 (setf (fli:dereference value) (if reuse-address-p 1 0)) | |
984 (if (zerop (comm::setsockopt socket-fd | |
985 comm::*sockopt_sol_socket* | |
986 comm::*sockopt_so_reuseaddr* | |
987 (fli:copy-pointer value | |
988 :type '(:pointer :voi… | |
989 (fli:size-of :int))) | |
990 reuse-address-p))) | |
991 | |
992 (defun get-socket-reuse-address (socket-fd) | |
993 (declare (type integer socket-fd)) | |
994 (fli:with-dynamic-foreign-objects ((value :int) (len :int)) | |
995 (if (zerop (comm::getsockopt socket-fd | |
996 comm::*sockopt_sol_socket* | |
997 comm::*sockopt_so_reuseaddr* | |
998 (fli:copy-pointer value | |
999 :type '(:pointer :voi… | |
1000 len)) | |
1001 (= 1 (fli:dereference value))))) |