tclisp.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tclisp.lisp (26636B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 (eval-when (:compile-toplevel :load-toplevel :execute)
6 #-ffi
7 (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.")
8 #-(or ffi rawsock)
9 (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support."))
10
11 ;; utility routine for looking up the current host name
12 #+ffi
13 (ffi:def-call-out get-host-name-internal
14 (:name "gethostname")
15 (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256))
16 :OUT :ALLOCA)
17 (len ffi:int))
18 #+win32 (:library "WS2_32")
19 #-win32 (:library :default)
20 (:language #-win32 :stdc
21 #+win32 :stdc-stdcall)
22 (:return-type ffi:int))
23
24 (defun get-host-name ()
25 #+ffi
26 (multiple-value-bind (retcode name)
27 (get-host-name-internal 256)
28 (when (= retcode 0)
29 name))
30 #-ffi
31 "localhost")
32
33 (defun get-host-by-address (address)
34 (with-mapped-conditions ()
35 (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address))))
36 (posix:hostent-name hostent))))
37
38 (defun get-hosts-by-name (name)
39 (with-mapped-conditions ()
40 (let ((hostent (posix:resolve-host-ipaddr name)))
41 (mapcar #'host-to-vector-quad
42 (posix:hostent-addr-list hostent)))))
43
44 ;; Format: ((UNIX Windows) . CONDITION)
45 (defparameter +clisp-error-map+
46 #-win32
47 `((:EADDRINUSE . address-in-use-error)
48 (:EADDRNOTAVAIL . address-not-available-error)
49 (:EBADF . bad-file-descriptor-error)
50 (:ECONNREFUSED . connection-refused-error)
51 (:ECONNRESET . connection-reset-error)
52 (:ECONNABORTED . connection-aborted-error)
53 (:EINVAL . invalid-argument-error)
54 (:ENOBUFS . no-buffers-error)
55 (:ENOMEM . out-of-memory-error)
56 (:ENOTSUP . operation-not-supported-error)
57 (:EPERM . operation-not-permitted-error)
58 (:EPROTONOSUPPORT . protocol-not-supported-error)
59 (:ESOCKTNOSUPPORT . socket-type-not-supported-error)
60 (:ENETUNREACH . network-unreachable-error)
61 (:ENETDOWN . network-down-error)
62 (:ENETRESET . network-reset-error)
63 (:ESHUTDOWN . already-shutdown-error)
64 (:ETIMEDOUT . timeout-error)
65 (:EHOSTDOWN . host-down-error)
66 (:EHOSTUNREACH . host-unreachable-error)
67 ;; when blocked reading, and we close our socket due to a timeout.
68 ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values.
69 (:EAGAIN . timeout-error)
70 (:EWOULDBLOCK . timeout-error)) ;linux
71 #+win32
72 `((:WSAEADDRINUSE . address-in-use-error)
73 (:WSAEADDRNOTAVAIL . address-not-available-error)
74 (:WSAEBADF . bad-file-descriptor-error)
75 (:WSAECONNREFUSED . connection-refused-error)
76 (:WSAECONNRESET . connection-reset-error)
77 (:WSAECONNABORTED . connection-aborted-error)
78 (:WSAEINVAL . invalid-argument-error)
79 (:WSAENOBUFS . no-buffers-error)
80 (:WSAENOMEM . out-of-memory-error)
81 (:WSAENOTSUP . operation-not-supported-error)
82 (:WSAEPERM . operation-not-permitted-error)
83 (:WSAEPROTONOSUPPORT . protocol-not-supported-error)
84 (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error)
85 (:WSAENETUNREACH . network-unreachable-error)
86 (:WSAENETDOWN . network-down-error)
87 (:WSAENETRESET . network-reset-error)
88 (:WSAESHUTDOWN . already-shutdown-error)
89 (:WSAETIMEDOUT . timeout-error)
90 (:WSAEHOSTDOWN . host-down-error)
91 (:WSAEHOSTUNREACH . host-unreachable-error)))
92
93 (defun parse-errno (condition)
94 "Returns a number or keyword if it can parse what is within parens, else NIL"
95 (let ((s (princ-to-string condition)))
96 (let ((pos1 (position #\( s))
97 (pos2 (position #\) s)))
98 ;mac: number, linux: keyword
99 (ignore-errors
100 (if (digit-char-p (char s (1+ pos1)))
101 (parse-integer s :start (1+ pos1) :end pos2)
102 (let ((*package* (find-package "KEYWORD")))
103 (car (read-from-string s t nil :start pos1 :end (1+ pos2)))))))))
104
105 (defun handle-condition (condition &optional (socket nil))
106 "Dispatch a usocket condition instead of a CLISP specific one, if we can."
107 (let ((errno
108 (cond
109 ;clisp 2.49+
110 ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT"))
111 (parse-errno condition))
112 ;clisp 2.49
113 ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM"))
114 (car (simple-condition-format-arguments condition))))))
115 (when errno
116 (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno))))
117 (let ((usocket-error (cdr (assoc error-keyword +clisp-error-map+))))
118 (when usocket-error
119 (if (subtypep usocket-error 'error)
120 (error usocket-error :socket socket)
121 (signal usocket-error :socket socket))))))))
122
123 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
124 timeout deadline (nodelay t nodelay-specified)
125 local-host local-port)
126 (declare (ignorable timeout local-host local-port))
127 (when deadline (unsupported 'deadline 'socket-connect))
128 (when (and nodelay-specified
129 (not (eq nodelay :if-supported)))
130 (unsupported 'nodelay 'socket-connect))
131 (case protocol
132 (:stream
133 (let ((socket)
134 (hostname (host-to-hostname host)))
135 (with-mapped-conditions (socket)
136 (setf socket
137 (if timeout
138 (socket:socket-connect port hostname
139 :element-type element-type
140 :buffered t
141 :timeout timeout)
142 (socket:socket-connect port hostname
143 :element-type element-type
144 :buffered t))))
145 (make-stream-socket :socket socket
146 :stream socket))) ;; the socket is a stream too
147 (:datagram
148 #+(or rawsock ffi)
149 (socket-create-datagram (or local-port *auto-port*)
150 :local-host (or local-host *wildcard-host*)
151 :remote-host (and host (host-to-vector-quad host))
152 :remote-port port)
153 #-(or rawsock ffi)
154 (unsupported '(protocol :datagram) 'socket-connect))))
155
156 (defun socket-listen (host port
157 &key reuseaddress
158 (reuse-address nil reuse-address-supplied-p)
159 (backlog 5)
160 (element-type 'character))
161 ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to
162 ;; to explicitly turn it on; unfortunately, there's no way to turn it off...
163 (declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
164 (let ((sock (apply #'socket:socket-server
165 (append (list port
166 :backlog backlog)
167 (when (ip/= host *wildcard-host*)
168 (list :interface host))))))
169 (with-mapped-conditions ()
170 (make-stream-server-socket sock :element-type element-type))))
171
172 (defmethod socket-accept ((socket stream-server-usocket) &key element-type)
173 (let ((stream
174 (with-mapped-conditions (socket)
175 (socket:socket-accept (socket socket)
176 :element-type (or element-type
177 (element-type socket))))))
178 (make-stream-socket :socket stream
179 :stream stream)))
180
181 ;; Only one close method required:
182 ;; sockets and their associated streams
183 ;; are the same object
184 (defmethod socket-close ((usocket usocket))
185 "Close socket."
186 (when (wait-list usocket)
187 (remove-waiter (wait-list usocket) usocket))
188 (with-mapped-conditions (usocket)
189 (close (socket usocket))))
190
191 (defmethod socket-close ((usocket stream-server-usocket))
192 (when (wait-list usocket)
193 (remove-waiter (wait-list usocket) usocket))
194 (socket:socket-server-close (socket usocket)))
195
196 (defmethod socket-shutdown ((usocket stream-usocket) direction)
197 (with-mapped-conditions (usocket)
198 (socket:socket-stream-shutdown (socket usocket) direction)))
199
200 (defmethod get-local-name ((usocket stream-usocket))
201 (multiple-value-bind
202 (address port)
203 (socket:socket-stream-local (socket usocket) t)
204 (values (dotted-quad-to-vector-quad address) port)))
205
206 (defmethod get-local-name ((usocket stream-server-usocket))
207 (values (get-local-address usocket)
208 (get-local-port usocket)))
209
210 (defmethod get-peer-name ((usocket stream-usocket))
211 (multiple-value-bind
212 (address port)
213 (socket:socket-stream-peer (socket usocket) t)
214 (values (dotted-quad-to-vector-quad address) port)))
215
216 (defmethod get-local-address ((usocket usocket))
217 (nth-value 0 (get-local-name usocket)))
218
219 (defmethod get-local-address ((usocket stream-server-usocket))
220 (dotted-quad-to-vector-quad
221 (socket:socket-server-host (socket usocket))))
222
223 (defmethod get-peer-address ((usocket usocket))
224 (nth-value 0 (get-peer-name usocket)))
225
226 (defmethod get-local-port ((usocket usocket))
227 (nth-value 1 (get-local-name usocket)))
228
229 (defmethod get-local-port ((usocket stream-server-usocket))
230 (socket:socket-server-port (socket usocket)))
231
232 (defmethod get-peer-port ((usocket usocket))
233 (nth-value 1 (get-peer-name usocket)))
234
235 (defun %setup-wait-list (wait-list)
236 (declare (ignore wait-list)))
237
238 (defun %add-waiter (wait-list waiter)
239 ;; clisp's #'socket-status takes a list whose elts look either like,
240 ;; (socket-stream direction . x) or like,
241 ;; (socket-server . x)
242 ;; and it replaces the x's.
243 (push (cons (socket waiter)
244 (cond ((stream-usocket-p waiter) (cons NIL NIL))
245 (t NIL)))
246 (wait-list-%wait wait-list)))
247
248 (defun %remove-waiter (wait-list waiter)
249 (setf (wait-list-%wait wait-list)
250 (remove (socket waiter) (wait-list-%wait wait-list) :key #'car)))
251
252 (defmethod wait-for-input-internal (wait-list &key timeout)
253 (with-mapped-conditions ()
254 (multiple-value-bind
255 (secs musecs)
256 (split-timeout (or timeout 1))
257 (dolist (x (wait-list-%wait wait-list))
258 (when (consp (cdr x)) ;it's a socket-stream not socket-server
259 (setf (cadr x) :INPUT)))
260 (let* ((request-list (wait-list-%wait wait-list))
261 (status-list (if timeout
262 (socket:socket-status request-list secs musecs)
263 (socket:socket-status request-list)))
264 (sockets (wait-list-waiters wait-list)))
265 (do* ((x (pop sockets) (pop sockets))
266 (y (cdr (last (pop status-list))) (cdr (last (pop status-list)))))
267 ((null x))
268 (when (member y '(T :INPUT :EOF))
269 (setf (state x) :READ)))
270 wait-list))))
271
272 ;;;
273 ;;; UDP/Datagram sockets (RAWSOCK version)
274 ;;;
275
276 #+rawsock
277 (progn
278 (defun make-sockaddr_in ()
279 (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))
280
281 (declaim (inline fill-sockaddr_in))
282 (defun fill-sockaddr_in (sockaddr_in ip port)
283 (port-to-octet-buffer port sockaddr_in)
284 (ip-to-octet-buffer ip sockaddr_in :start 2)
285 sockaddr_in)
286
287 (defun socket-create-datagram (local-port
288 &key (local-host *wildcard-host*)
289 remote-host
290 remote-port)
291 (let ((sock (rawsock:socket :inet :dgram 0))
292 (lsock_addr (fill-sockaddr_in (make-sockaddr_in)
293 local-host local-port))
294 (rsock_addr (when remote-host
295 (fill-sockaddr_in (make-sockaddr_in)
296 remote-host (or remote-port
297 local-port)))))
298 (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr))
299 (when rsock_addr
300 (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr)))
301 (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
302
303 (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
304 "Returns the buffer, the number of octets copied into the buffer (received)
305 and the address of the sender as values."
306 (let* ((sock (socket socket))
307 (sockaddr (rawsock:make-sockaddr :inet))
308 (real-length (or length +max-datagram-packet-size+))
309 (real-buffer (or buffer
310 (make-array real-length
311 :element-type '(unsigned-byte 8)))))
312 (let ((rv (rawsock:recvfrom sock real-buffer sockaddr
313 :start 0 :end real-length))
314 (host 0) (port 0))
315 (unless (connected-p socket)
316 (let ((data (rawsock:sockaddr-data sockaddr)))
317 (setq host (ip-from-octet-buffer data :start 4)
318 port (port-from-octet-buffer data :start 2))))
319 (values (if buffer real-buffer (subseq real-buffer 0 rv))
320 rv
321 host
322 port))))
323
324 (defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0))
325 "Returns the number of octets sent."
326 (let* ((sock (socket socket))
327 (sockaddr (when (and host port)
328 (rawsock:make-sockaddr :inet
329 (fill-sockaddr_in
330 (make-sockaddr_in)
331 (host-byte-order host)
332 port))))
333 (real-size (min size +max-datagram-packet-size+))
334 (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*)))
335 buffer
336 (make-array real-size
337 :element-type '(unsigned-byte 8)
338 :initial-contents (subseq buffer 0 real-size))))
339 (rv (if (and host port)
340 (rawsock:sendto sock real-buffer sockaddr
341 :start offset
342 :end (+ offset real-size))
343 (rawsock:send sock real-buffer
344 :start offset
345 :end (+ offset real-size)))))
346 rv))
347
348 (defmethod socket-close ((usocket datagram-usocket))
349 (when (wait-list usocket)
350 (remove-waiter (wait-list usocket) usocket))
351 (rawsock:sock-close (socket usocket)))
352
353 (declaim (inline get-socket-name))
354 (defun get-socket-name (socket function)
355 (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in))))
356 (funcall function socket sockaddr)
357 (let ((data (rawsock:sockaddr-data sockaddr)))
358 (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2))
359 (port-from-octet-buffer data :start 0)))))
360
361 (defmethod get-local-name ((usocket datagram-usocket))
362 (get-socket-name (socket usocket) 'rawsock:getsockname))
363
364 (defmethod get-peer-name ((usocket datagram-usocket))
365 (get-socket-name (socket usocket) 'rawsock:getpeername))
366
367 ) ; progn
368
369 ;;;
370 ;;; UDP/Datagram sockets (FFI version)
371 ;;;
372
373 #+(and ffi (not rawsock))
374 (progn
375 ;; C primitive types
376 (ffi:def-c-type socklen_t ffi:uint32)
377
378 ;; C structures
379 (ffi:def-c-struct sockaddr
380 #+macos (sa_len ffi:uint8)
381 (sa_family #-macos ffi:ushort
382 #+macos ffi:uint8)
383 (sa_data (ffi:c-array ffi:char 14)))
384
385 (ffi:def-c-struct sockaddr_in
386 #+macos (sin_len ffi:uint8)
387 (sin_family #-macos ffi:short
388 #+macos ffi:uint8)
389 (sin_port #-macos ffi:ushort
390 #+macos ffi:uint16)
391 (sin_addr ffi:uint32)
392 (sin_zero (ffi:c-array ffi:char 8)))
393
394 (ffi:def-c-struct timeval
395 (tv_sec ffi:long)
396 (tv_usec ffi:long))
397
398 ;; foreign functions
399 (ffi:def-call-out %sendto (:name "sendto")
400 (:arguments (socket ffi:int)
401 (buffer ffi:c-pointer)
402 (length ffi:int)
403 (flags ffi:int)
404 (address (ffi:c-ptr sockaddr))
405 (address-len ffi:int))
406 #+win32 (:library "WS2_32")
407 #-win32 (:library :default)
408 (:language #-win32 :stdc
409 #+win32 :stdc-stdcall)
410 (:return-type ffi:int))
411
412 (ffi:def-call-out %send (:name "send")
413 (:arguments (socket ffi:int)
414 (buffer ffi:c-pointer)
415 (length ffi:int)
416 (flags ffi:int))
417 #+win32 (:library "WS2_32")
418 #-win32 (:library :default)
419 (:language #-win32 :stdc
420 #+win32 :stdc-stdcall)
421 (:return-type ffi:int))
422
423 (ffi:def-call-out %recvfrom (:name "recvfrom")
424 (:arguments (socket ffi:int)
425 (buffer ffi:c-pointer)
426 (length ffi:int)
427 (flags ffi:int)
428 (address (ffi:c-ptr sockaddr) :in-out)
429 (address-len (ffi:c-ptr ffi:int) :in-out))
430 #+win32 (:library "WS2_32")
431 #-win32 (:library :default)
432 (:language #-win32 :stdc
433 #+win32 :stdc-stdcall)
434 (:return-type ffi:int))
435
436 (ffi:def-call-out %socket (:name "socket")
437 (:arguments (family ffi:int)
438 (type ffi:int)
439 (protocol ffi:int))
440 #+win32 (:library "WS2_32")
441 #-win32 (:library :default)
442 (:language #-win32 :stdc
443 #+win32 :stdc-stdcall)
444 (:return-type ffi:int))
445
446 (ffi:def-call-out %connect (:name "connect")
447 (:arguments (socket ffi:int)
448 (address (ffi:c-ptr sockaddr) :in)
449 (address_len socklen_t))
450 #+win32 (:library "WS2_32")
451 #-win32 (:library :default)
452 (:language #-win32 :stdc
453 #+win32 :stdc-stdcall)
454 (:return-type ffi:int))
455
456 (ffi:def-call-out %bind (:name "bind")
457 (:arguments (socket ffi:int)
458 (address (ffi:c-ptr sockaddr) :in)
459 (address_len socklen_t))
460 #+win32 (:library "WS2_32")
461 #-win32 (:library :default)
462 (:language #-win32 :stdc
463 #+win32 :stdc-stdcall)
464 (:return-type ffi:int))
465
466 (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket")
467 (:arguments (socket ffi:int))
468 #+win32 (:library "WS2_32")
469 #-win32 (:library :default)
470 (:language #-win32 :stdc
471 #+win32 :stdc-stdcall)
472 (:return-type ffi:int))
473
474 (ffi:def-call-out %getsockopt (:name "getsockopt")
475 (:arguments (sockfd ffi:int)
476 (level ffi:int)
477 (optname ffi:int)
478 (optval ffi:c-pointer)
479 (optlen (ffi:c-ptr socklen_t) :out))
480 #+win32 (:library "WS2_32")
481 #-win32 (:library :default)
482 (:language #-win32 :stdc
483 #+win32 :stdc-stdcall)
484 (:return-type ffi:int))
485
486 (ffi:def-call-out %setsockopt (:name "setsockopt")
487 (:arguments (sockfd ffi:int)
488 (level ffi:int)
489 (optname ffi:int)
490 (optval ffi:c-pointer)
491 (optlen socklen_t))
492 #+win32 (:library "WS2_32")
493 #-win32 (:library :default)
494 (:language #-win32 :stdc
495 #+win32 :stdc-stdcall)
496 (:return-type ffi:int))
497
498 (ffi:def-call-out %htonl (:name "htonl")
499 (:arguments (hostlong ffi:uint32))
500 #+win32 (:library "WS2_32")
501 #-win32 (:library :default)
502 (:language #-win32 :stdc
503 #+win32 :stdc-stdcall)
504 (:return-type ffi:uint32))
505
506 (ffi:def-call-out %htons (:name "htons")
507 (:arguments (hostshort ffi:uint16))
508 #+win32 (:library "WS2_32")
509 #-win32 (:library :default)
510 (:language #-win32 :stdc
511 #+win32 :stdc-stdcall)
512 (:return-type ffi:uint16))
513
514 (ffi:def-call-out %ntohl (:name "ntohl")
515 (:arguments (netlong ffi:uint32))
516 #+win32 (:library "WS2_32")
517 #-win32 (:library :default)
518 (:language #-win32 :stdc
519 #+win32 :stdc-stdcall)
520 (:return-type ffi:uint32))
521
522 (ffi:def-call-out %ntohs (:name "ntohs")
523 (:arguments (netshort ffi:uint16))
524 #+win32 (:library "WS2_32")
525 #-win32 (:library :default)
526 (:language #-win32 :stdc
527 #+win32 :stdc-stdcall)
528 (:return-type ffi:uint16))
529
530 (ffi:def-call-out %getsockname (:name "getsockname")
531 (:arguments (sockfd ffi:int)
532 (localaddr (ffi:c-ptr sockaddr) :in-out)
533 (addrlen (ffi:c-ptr socklen_t) :in-out))
534 #+win32 (:library "WS2_32")
535 #-win32 (:library :default)
536 (:language #-win32 :stdc
537 #+win32 :stdc-stdcall)
538 (:return-type ffi:int))
539
540 (ffi:def-call-out %getpeername (:name "getpeername")
541 (:arguments (sockfd ffi:int)
542 (peeraddr (ffi:c-ptr sockaddr) :in-out)
543 (addrlen (ffi:c-ptr socklen_t) :in-out))
544 #+win32 (:library "WS2_32")
545 #-win32 (:library :default)
546 (:language #-win32 :stdc
547 #+win32 :stdc-stdcall)
548 (:return-type ffi:int))
549
550 ;; socket constants
551 (defconstant +socket-af-inet+ 2)
552 (defconstant +socket-sock-dgram+ 2)
553 (defconstant +socket-ip-proto-udp+ 17)
554
555 (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout")
556
557 (defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in))
558
559 (declaim (inline fill-sockaddr_in))
560 (defun fill-sockaddr_in (sockaddr host port)
561 (let ((hbo (host-to-hbo host)))
562 (ffi:with-c-place (place sockaddr)
563 #+macos
564 (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*)
565 (setf (ffi:slot place 'sin_family) +socket-af-inet+
566 (ffi:slot place 'sin_port) (%htons port)
567 (ffi:slot place 'sin_addr) (%htonl hbo)))
568 sockaddr))
569
570 (defun socket-create-datagram (local-port
571 &key (local-host *wildcard-host*)
572 remote-host
573 remote-port)
574 (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+))
575 (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
576 local-host local-port))
577 (rsock_addr (when remote-host
578 (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
579 remote-host (or remote-port local-port)))))
580 (unless (plusp sock)
581 (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno)))
582 (unwind-protect
583 (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
584 *length-of-sockaddr_in*)))
585 (unless (zerop rv)
586 (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno)))
587 (when rsock_addr
588 (let ((rv (%connect sock
589 (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
590 *length-of-sockaddr_in*)))
591 (unless (zerop rv)
592 (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno))))))
593 (ffi:foreign-free lsock_addr)
594 (when remote-host
595 (ffi:foreign-free rsock_addr)))
596 (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
597
598 (defun finalize-datagram-usocket (object)
599 (when (datagram-usocket-p object)
600 (socket-close object)))
601
602 (defmethod initialize-instance :after ((usocket datagram-usocket) &key)
603 (setf (slot-value usocket 'recv-buffer)
604 (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+))
605 ;; finalize the object
606 (ext:finalize usocket 'finalize-datagram-usocket))
607
608 (defmethod socket-close ((usocket datagram-usocket))
609 (when (wait-list usocket)
610 (remove-waiter (wait-list usocket) usocket))
611 (with-slots (recv-buffer socket) usocket
612 (ffi:foreign-free recv-buffer)
613 (zerop (%close socket))))
614
615 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
616 (let ((remote-address (ffi:allocate-shallow 'sockaddr_in))
617 (remote-address-length (ffi:allocate-shallow 'ffi:int))
618 nbytes (host 0) (port 0))
619 (setf (ffi:foreign-value remote-address-length)
620 *length-of-sockaddr_in*)
621 (unwind-protect
622 (multiple-value-bind (n address address-length)
623 (%recvfrom (socket usocket)
624 (ffi:foreign-address (slot-value usocket 'recv-buffer))
625 +max-datagram-packet-size+
626 0 ; flags
627 (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
628 (ffi:foreign-value remote-address-length))
629 (when (minusp n)
630 (error "SOCKET-RECEIVE ERROR: ~A" (os:errno)))
631 (setq nbytes n)
632 (when (= address-length *length-of-sockaddr_in*)
633 (let ((data (sockaddr-sa_data address)))
634 (setq host (ip-from-octet-buffer data :start 2)
635 port (port-from-octet-buffer data))))
636 (cond ((plusp n)
637 (let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer))))
638 (if buffer ; replace exist buffer of create new return buffer
639 (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+))
640 (end-2 (min n +max-datagram-packet-size+)))
641 (replace buffer return-buffer :end1 end-1 :end2 end-2))
642 (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))))
643 ((zerop n))))
644 (ffi:foreign-free remote-address)
645 (ffi:foreign-free remote-address-length))
646 (values buffer nbytes host port)))
647
648 ;; implementation note: different from socket-receive, we know how many bytes we want to send everytime,
649 ;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those
650 ;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time.
651 ;;
652 ;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP.
653 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
654 (declare (type sequence buffer)
655 (type (integer 0 *) size offset))
656 (let ((remote-address
657 (when (and host port)
658 (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port)))
659 (send-buffer
660 (ffi:allocate-deep 'ffi:uint8
661 (if (zerop offset)
662 buffer
663 (subseq buffer offset (+ offset size)))
664 :count size :read-only t))
665 (real-size (min size +max-datagram-packet-size+))
666 (nbytes 0))
667 (unwind-protect
668 (let ((n (if remote-address
669 (%sendto (socket usocket)
670 (ffi:foreign-address send-buffer)
671 real-size
672 0 ; flags
673 (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
674 *length-of-sockaddr_in*)
675 (%send (socket usocket)
676 (ffi:foreign-address send-buffer)
677 real-size
678 0))))
679 (cond ((plusp n)
680 (setq nbytes n))
681 ((zerop n)
682 (setq nbytes n))
683 (t (error "SOCKET-SEND ERROR: ~A" (os:errno)))))
684 (ffi:foreign-free send-buffer)
685 (when remote-address
686 (ffi:foreign-free remote-address))
687 nbytes)))
688
689 (declaim (inline get-socket-name))
690 (defun get-socket-name (socket function)
691 (let ((address (ffi:allocate-shallow 'sockaddr_in))
692 (address-length (ffi:allocate-shallow 'ffi:int))
693 (host 0) (port 0))
694 (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*)
695 (unwind-protect
696 (multiple-value-bind (rv return-address return-address-length)
697 (funcall function socket
698 (ffi:cast (ffi:foreign-value address) 'sockaddr)
699 (ffi:foreign-value address-length))
700 (declare (ignore return-address-length))
701 (if (zerop rv)
702 (let ((data (sockaddr-sa_data return-address)))
703 (setq host (ip-from-octet-buffer data :start 2)
704 port (port-from-octet-buffer data)))
705 (error "GET-SOCKET-NAME ERROR: ~A" (os:errno))))
706 (ffi:foreign-free address)
707 (ffi:foreign-free address-length))
708 (values (hbo-to-vector-quad host) port)))
709
710 (defmethod get-local-name ((usocket datagram-usocket))
711 (get-socket-name (socket usocket) '%getsockname))
712
713 (defmethod get-peer-name ((usocket datagram-usocket))
714 (get-socket-name (socket usocket) '%getpeername))
715
716 ) ; progn