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