lispworks.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
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" :source)
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-ip))
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-or-ip))
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 nil))
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 address_len);
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 #+win32 :char #-win32 :void))
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 #+win32 :char #-win32 :void))
285 len))
286 zero-or-one 0))) ; on error, return 0
287
288 (defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname))
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 :fields '(:address))))
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 Troillard:
337
338 ;; Calling comm::ensure-sockets at load time looks like a bug in Lispworks-udp
339 ;; (it is too early and also unnecessary).
340
341 ;; The LispWorks comm package calls comm::ensure-sockets when it is needed, so I
342 ;; think open-udp-socket should probably do it too. Calling it more than once is
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* *socket_ip_proto_udp*)))
347 (if socket-fd
348 (progn
349 (when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
350 (if local-port
351 (fli:with-dynamic-foreign-objects ()
352 (multiple-value-bind (error local-address-family
353 client-addr client-addr-length)
354 (initialize-dynamic-sockaddr local-address local-port "udp")
355 (if (or error (not (eql address-family local-address-family)))
356 (progn
357 (comm::close-socket socket-fd)
358 (error "cannot resolve hostname ~S, service ~S: ~A"
359 local-address local-port (or error "address family mismatch")))
360 (if (comm::bind socket-fd client-addr client-addr-length)
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 read-timeout)
371 "Something like CONNECT-TO-TCP-SERVER"
372 (fli:with-dynamic-foreign-objects ()
373 (multiple-value-bind (error address-family server-addr server-addr-length)
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 'base-char)
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)) ; >= 4.4.5
419 #-(and lispworks4 (not lispworks4.4))
420 :timeout timeout
421 #-lispworks4 #-lispworks4
422 #-lispworks4 #-lispworks4
423 :local-address (when local-host (host-to-hostname local-host))
424 :local-port local-port
425 #-(or lispworks4 lispworks5.0) ; >= 5.1
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 and still fails, then it's a timeout
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) port
446 :local-address (and local-host (host-to-hostname local-host))
447 :local-port local-port
448 :read-timeout timeout))
449 (with-mapped-conditions (nil local-host)
450 (open-udp-socket :local-address (and local-host (host-to-hostname local-host))
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 than 4.1")
463 #+lispworks4.1
464 (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
465
466 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
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-service
472 port :address hostname :backlog backlog)
473 #+lispworks4.1 (comm::create-tcp-socket-for-service port))))
474 (sock (if (not (or (second socket-res-list) (third socket-res-list)))
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 operations, which
481 ;; should NOT be applied on socket FDs who have already been called on W-F-I,
482 ;; so we have to check the %READY-P slot to decide if this waiting is necessary,
483 ;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011
484
485 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
486 (let* ((socket (with-mapped-conditions (usocket)
487 #+win32
488 (if (%ready-p usocket)
489 (comm::accept-connection-to-socket (socket usocket))
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 port (offset 0)
571 &aux (socket-fd (socket usocket))
572 (message (slot-value usocket 'send-buffer))) ; TODO: multiple threads send together?
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 :byte))
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-addr-length)
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-packet-size+) 0
588 (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
589 client-addr-length)))
590 (comm::%send socket-fd ptr (min size +max-datagram-packet-size+) 0))))
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 timeout (max-buffer-size +max-datagram-packet-size+))
601 "Receive message from socket, read-timeout is a float number in seconds.
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 threads do this in parallel?
615 (read-timeout timeout)
616 old-timeout)
617 (declare (type integer socket-fd))
618 (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
619 (len :int
620 #-(or lispworks4 lispworks5.0) ; <= 5.0
621 :initial-element *length-of-sockaddr_in*))
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 '(:unsigned :byte))
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 '(:struct comm::sockaddr))
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_addr
648 :object-type '(:struct comm::sockaddr_in)
649 :type '(:struct comm::in_addr)
650 :copy-foreign-object nil)
651 'comm::s_addr
652 :object-type '(:struct comm::in_addr)))
653 (comm::ntohs (fli:foreign-slot-value client-addr
654 'comm::sin_port
655 :object-type '(:struct comm::sockaddr_in)
656 :type '(:unsigned :short)
657 :copy-foreign-object nil)))
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 '(:address))))
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 order
729 ;;; to achieve what we want (what we want is waiting without busy-looping)
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, please?
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 become active"
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 the Windows API
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" :source)
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 "WSAEnumNetworkEvents" :source)
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" :source)
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" :source)
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:: internal for that)
888 ;; 4. After listening, detect if there are errors
889 ;; (this step is different from Unix, where we can have only one error)
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-ptr)))
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" timeout))
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-events))
921 (error-array (fli:foreign-slot-pointer network-events 'error-code)))
922 (unless (zerop event-map)
923 (dotimes (i fd-max-events)
924 (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
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 fd-close))
966 (stream-usocket (logior fd-connect fd-read fd-oob fd-close))
967 (datagram-usocket (logior fd-read)))))
968 (maybe-wsa-error
969 (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
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-list) 0)
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 :void))
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 :void))
1000 len))
1001 (= 1 (fli:dereference value)))))