clisp.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
---
clisp.lisp (26836B)
---
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 (nil address)
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 (nil name)
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) (host-or-ip 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 ((usock-error (cdr (assoc error-keyword +clisp-error-map+))))
118 (when usock-error
119 (if (subtypep usock-error 'error)
120 (cond ((subtypep usock-error 'ns-error)
121 (error usock-error :socket socket :host-or-ip host-or-ip))
122 (t
123 (error usock-error :socket socket)))
124 (cond ((subtypep usock-error 'ns-condition)
125 (signal usock-error :socket socket :host-or-ip host-or-ip))
126 (t
127 (signal usock-error :socket socket))))))))))
128
129 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
130 timeout deadline (nodelay t nodelay-specified)
131 local-host local-port)
132 (declare (ignorable timeout local-host local-port))
133 (when deadline (unsupported 'deadline 'socket-connect))
134 (when (and nodelay-specified
135 (not (eq nodelay :if-supported)))
136 (unsupported 'nodelay 'socket-connect))
137 (case protocol
138 (:stream
139 (let ((socket)
140 (hostname (host-to-hostname host)))
141 (with-mapped-conditions (socket host)
142 (setf socket
143 (if timeout
144 (socket:socket-connect port hostname
145 :element-type element-type
146 :buffered t
147 :timeout timeout)
148 (socket:socket-connect port hostname
149 :element-type element-type
150 :buffered t))))
151 (make-stream-socket :socket socket
152 :stream socket))) ;; the socket is a stream too
153 (:datagram
154 #+(or rawsock ffi)
155 (with-mapped-conditions (nil (or host local-host))
156 (socket-create-datagram (or local-port *auto-port*)
157 :local-host (or local-host *wildcard-host*)
158 :remote-host (and host (host-to-vector-quad host))
159 :remote-port port))
160 #-(or rawsock ffi)
161 (unsupported '(protocol :datagram) 'socket-connect))))
162
163 (defun socket-listen (host port
164 &key reuseaddress
165 (reuse-address nil reuse-address-supplied-p)
166 (backlog 5)
167 (element-type 'character))
168 ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to
169 ;; to explicitly turn it on; unfortunately, there's no way to turn it off...
170 (declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
171 (let ((sock (apply #'socket:socket-server
172 (append (list port
173 :backlog backlog)
174 (when (ip/= host *wildcard-host*)
175 (list :interface host))))))
176 (with-mapped-conditions (nil host)
177 (make-stream-server-socket sock :element-type element-type))))
178
179 (defmethod socket-accept ((socket stream-server-usocket) &key element-type)
180 (let ((stream
181 (with-mapped-conditions (socket)
182 (socket:socket-accept (socket socket)
183 :element-type (or element-type
184 (element-type socket))))))
185 (make-stream-socket :socket stream
186 :stream stream)))
187
188 ;; Only one close method required:
189 ;; sockets and their associated streams
190 ;; are the same object
191 (defmethod socket-close ((usocket usocket))
192 "Close socket."
193 (with-mapped-conditions (usocket)
194 (close (socket usocket))))
195
196 (defmethod socket-close ((usocket stream-server-usocket))
197 (socket:socket-server-close (socket usocket)))
198
199 (defmethod socket-shutdown ((usocket stream-usocket) direction)
200 (with-mapped-conditions (usocket)
201 (socket:socket-stream-shutdown (socket usocket) direction)))
202
203 (defmethod get-local-name ((usocket stream-usocket))
204 (multiple-value-bind
205 (address port)
206 (socket:socket-stream-local (socket usocket) t)
207 (values (dotted-quad-to-vector-quad address) port)))
208
209 (defmethod get-local-name ((usocket stream-server-usocket))
210 (values (get-local-address usocket)
211 (get-local-port usocket)))
212
213 (defmethod get-peer-name ((usocket stream-usocket))
214 (multiple-value-bind
215 (address port)
216 (socket:socket-stream-peer (socket usocket) t)
217 (values (dotted-quad-to-vector-quad address) port)))
218
219 (defmethod get-local-address ((usocket usocket))
220 (nth-value 0 (get-local-name usocket)))
221
222 (defmethod get-local-address ((usocket stream-server-usocket))
223 (dotted-quad-to-vector-quad
224 (socket:socket-server-host (socket usocket))))
225
226 (defmethod get-peer-address ((usocket usocket))
227 (nth-value 0 (get-peer-name usocket)))
228
229 (defmethod get-local-port ((usocket usocket))
230 (nth-value 1 (get-local-name usocket)))
231
232 (defmethod get-local-port ((usocket stream-server-usocket))
233 (socket:socket-server-port (socket usocket)))
234
235 (defmethod get-peer-port ((usocket usocket))
236 (nth-value 1 (get-peer-name usocket)))
237
238 (defun %setup-wait-list (wait-list)
239 (declare (ignore wait-list)))
240
241 (defun %add-waiter (wait-list waiter)
242 ;; clisp's #'socket-status takes a list whose elts look either like,
243 ;; (socket-stream direction . x) or like,
244 ;; (socket-server . x)
245 ;; and it replaces the x's.
246 (push (cons (socket waiter)
247 (cond ((stream-usocket-p waiter) (cons NIL NIL))
248 (t NIL)))
249 (wait-list-%wait wait-list)))
250
251 (defun %remove-waiter (wait-list waiter)
252 (setf (wait-list-%wait wait-list)
253 (remove (socket waiter) (wait-list-%wait wait-list) :key #'car)))
254
255 (defmethod wait-for-input-internal (wait-list &key timeout)
256 (with-mapped-conditions ()
257 (multiple-value-bind
258 (secs musecs)
259 (split-timeout (or timeout 1))
260 (dolist (x (wait-list-%wait wait-list))
261 (when (consp (cdr x)) ;it's a socket-stream not socket-server
262 (setf (cadr x) :INPUT)))
263 (let* ((request-list (wait-list-%wait wait-list))
264 (status-list (if timeout
265 (socket:socket-status request-list secs musecs)
266 (socket:socket-status request-list)))
267 (sockets (wait-list-waiters wait-list)))
268 (do* ((x (pop sockets) (pop sockets))
269 (y (cdr (last (pop status-list))) (cdr (last (pop status-list)))))
270 ((null x))
271 (when (member y '(T :INPUT :EOF))
272 (setf (state x) :READ)))
273 wait-list))))
274
275 ;;;
276 ;;; UDP/Datagram sockets (RAWSOCK version)
277 ;;;
278
279 #+rawsock
280 (progn
281 (defun make-sockaddr_in ()
282 (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))
283
284 (declaim (inline fill-sockaddr_in))
285 (defun fill-sockaddr_in (sockaddr_in ip port)
286 (port-to-octet-buffer port sockaddr_in)
287 (ip-to-octet-buffer ip sockaddr_in :start 2)
288 sockaddr_in)
289
290 (defun socket-create-datagram (local-port
291 &key (local-host *wildcard-host*)
292 remote-host
293 remote-port)
294 (let ((sock (rawsock:socket :inet :dgram 0))
295 (lsock_addr (fill-sockaddr_in (make-sockaddr_in)
296 local-host local-port))
297 (rsock_addr (when remote-host
298 (fill-sockaddr_in (make-sockaddr_in)
299 remote-host (or remote-port
300 local-port)))))
301 (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr))
302 (when rsock_addr
303 (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr)))
304 (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
305
306 (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
307 "Returns the buffer, the number of octets copied into the buffer (received)
308 and the address of the sender as values."
309 (let* ((sock (socket socket))
310 (sockaddr (rawsock:make-sockaddr :inet))
311 (real-length (or length +max-datagram-packet-size+))
312 (real-buffer (or buffer
313 (make-array real-length
314 :element-type '(unsigned-byte 8)))))
315 (let ((rv (rawsock:recvfrom sock real-buffer sockaddr
316 :start 0 :end real-length))
317 (host 0) (port 0))
318 (unless (connected-p socket)
319 (let ((data (rawsock:sockaddr-data sockaddr)))
320 (setq host (ip-from-octet-buffer data :start 4)
321 port (port-from-octet-buffer data :start 2))))
322 (values (if buffer real-buffer (subseq real-buffer 0 rv))
323 rv
324 host
325 port))))
326
327 (defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0))
328 "Returns the number of octets sent."
329 (let* ((sock (socket socket))
330 (sockaddr (when (and host port)
331 (rawsock:make-sockaddr :inet
332 (fill-sockaddr_in
333 (make-sockaddr_in)
334 (host-byte-order host)
335 port))))
336 (real-size (min size +max-datagram-packet-size+))
337 (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*)))
338 buffer
339 (make-array real-size
340 :element-type '(unsigned-byte 8)
341 :initial-contents (subseq buffer 0 real-size))))
342 (rv (if (and host port)
343 (rawsock:sendto sock real-buffer sockaddr
344 :start offset
345 :end (+ offset real-size))
346 (rawsock:send sock real-buffer
347 :start offset
348 :end (+ offset real-size)))))
349 rv))
350
351 (defmethod socket-close ((usocket datagram-usocket))
352 (rawsock:sock-close (socket usocket)))
353
354 (declaim (inline get-socket-name))
355 (defun get-socket-name (socket function)
356 (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in))))
357 (funcall function socket sockaddr)
358 (let ((data (rawsock:sockaddr-data sockaddr)))
359 (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2))
360 (port-from-octet-buffer data :start 0)))))
361
362 (defmethod get-local-name ((usocket datagram-usocket))
363 (get-socket-name (socket usocket) 'rawsock:getsockname))
364
365 (defmethod get-peer-name ((usocket datagram-usocket))
366 (get-socket-name (socket usocket) 'rawsock:getpeername))
367
368 ) ; progn
369
370 ;;;
371 ;;; UDP/Datagram sockets (FFI version)
372 ;;;
373
374 #+(and ffi (not rawsock))
375 (progn
376 ;; C primitive types
377 (ffi:def-c-type socklen_t ffi:uint32)
378
379 ;; C structures
380 (ffi:def-c-struct sockaddr
381 #+macos (sa_len ffi:uint8)
382 (sa_family #-macos ffi:ushort
383 #+macos ffi:uint8)
384 (sa_data (ffi:c-array ffi:char 14)))
385
386 (ffi:def-c-struct sockaddr_in
387 #+macos (sin_len ffi:uint8)
388 (sin_family #-macos ffi:short
389 #+macos ffi:uint8)
390 (sin_port #-macos ffi:ushort
391 #+macos ffi:uint16)
392 (sin_addr ffi:uint32)
393 (sin_zero (ffi:c-array ffi:char 8)))
394
395 (ffi:def-c-struct timeval
396 (tv_sec ffi:long)
397 (tv_usec ffi:long))
398
399 ;; foreign functions
400 (ffi:def-call-out %sendto (:name "sendto")
401 (:arguments (socket ffi:int)
402 (buffer ffi:c-pointer)
403 (length ffi:int)
404 (flags ffi:int)
405 (address (ffi:c-ptr sockaddr))
406 (address-len ffi:int))
407 #+win32 (:library "WS2_32")
408 #-win32 (:library :default)
409 (:language #-win32 :stdc
410 #+win32 :stdc-stdcall)
411 (:return-type ffi:int))
412
413 (ffi:def-call-out %send (:name "send")
414 (:arguments (socket ffi:int)
415 (buffer ffi:c-pointer)
416 (length ffi:int)
417 (flags ffi:int))
418 #+win32 (:library "WS2_32")
419 #-win32 (:library :default)
420 (:language #-win32 :stdc
421 #+win32 :stdc-stdcall)
422 (:return-type ffi:int))
423
424 (ffi:def-call-out %recvfrom (:name "recvfrom")
425 (:arguments (socket ffi:int)
426 (buffer ffi:c-pointer)
427 (length ffi:int)
428 (flags ffi:int)
429 (address (ffi:c-ptr sockaddr) :in-out)
430 (address-len (ffi:c-ptr ffi:int) :in-out))
431 #+win32 (:library "WS2_32")
432 #-win32 (:library :default)
433 (:language #-win32 :stdc
434 #+win32 :stdc-stdcall)
435 (:return-type ffi:int))
436
437 (ffi:def-call-out %socket (:name "socket")
438 (:arguments (family ffi:int)
439 (type ffi:int)
440 (protocol ffi:int))
441 #+win32 (:library "WS2_32")
442 #-win32 (:library :default)
443 (:language #-win32 :stdc
444 #+win32 :stdc-stdcall)
445 (:return-type ffi:int))
446
447 (ffi:def-call-out %connect (:name "connect")
448 (:arguments (socket ffi:int)
449 (address (ffi:c-ptr sockaddr) :in)
450 (address_len socklen_t))
451 #+win32 (:library "WS2_32")
452 #-win32 (:library :default)
453 (:language #-win32 :stdc
454 #+win32 :stdc-stdcall)
455 (:return-type ffi:int))
456
457 (ffi:def-call-out %bind (:name "bind")
458 (:arguments (socket ffi:int)
459 (address (ffi:c-ptr sockaddr) :in)
460 (address_len socklen_t))
461 #+win32 (:library "WS2_32")
462 #-win32 (:library :default)
463 (:language #-win32 :stdc
464 #+win32 :stdc-stdcall)
465 (:return-type ffi:int))
466
467 (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket")
468 (:arguments (socket ffi:int))
469 #+win32 (:library "WS2_32")
470 #-win32 (:library :default)
471 (:language #-win32 :stdc
472 #+win32 :stdc-stdcall)
473 (:return-type ffi:int))
474
475 (ffi:def-call-out %getsockopt (:name "getsockopt")
476 (:arguments (sockfd ffi:int)
477 (level ffi:int)
478 (optname ffi:int)
479 (optval ffi:c-pointer)
480 (optlen (ffi:c-ptr socklen_t) :out))
481 #+win32 (:library "WS2_32")
482 #-win32 (:library :default)
483 (:language #-win32 :stdc
484 #+win32 :stdc-stdcall)
485 (:return-type ffi:int))
486
487 (ffi:def-call-out %setsockopt (:name "setsockopt")
488 (:arguments (sockfd ffi:int)
489 (level ffi:int)
490 (optname ffi:int)
491 (optval ffi:c-pointer)
492 (optlen socklen_t))
493 #+win32 (:library "WS2_32")
494 #-win32 (:library :default)
495 (:language #-win32 :stdc
496 #+win32 :stdc-stdcall)
497 (:return-type ffi:int))
498
499 (ffi:def-call-out %htonl (:name "htonl")
500 (:arguments (hostlong ffi:uint32))
501 #+win32 (:library "WS2_32")
502 #-win32 (:library :default)
503 (:language #-win32 :stdc
504 #+win32 :stdc-stdcall)
505 (:return-type ffi:uint32))
506
507 (ffi:def-call-out %htons (:name "htons")
508 (:arguments (hostshort ffi:uint16))
509 #+win32 (:library "WS2_32")
510 #-win32 (:library :default)
511 (:language #-win32 :stdc
512 #+win32 :stdc-stdcall)
513 (:return-type ffi:uint16))
514
515 (ffi:def-call-out %ntohl (:name "ntohl")
516 (:arguments (netlong ffi:uint32))
517 #+win32 (:library "WS2_32")
518 #-win32 (:library :default)
519 (:language #-win32 :stdc
520 #+win32 :stdc-stdcall)
521 (:return-type ffi:uint32))
522
523 (ffi:def-call-out %ntohs (:name "ntohs")
524 (:arguments (netshort ffi:uint16))
525 #+win32 (:library "WS2_32")
526 #-win32 (:library :default)
527 (:language #-win32 :stdc
528 #+win32 :stdc-stdcall)
529 (:return-type ffi:uint16))
530
531 (ffi:def-call-out %getsockname (:name "getsockname")
532 (:arguments (sockfd ffi:int)
533 (localaddr (ffi:c-ptr sockaddr) :in-out)
534 (addrlen (ffi:c-ptr socklen_t) :in-out))
535 #+win32 (:library "WS2_32")
536 #-win32 (:library :default)
537 (:language #-win32 :stdc
538 #+win32 :stdc-stdcall)
539 (:return-type ffi:int))
540
541 (ffi:def-call-out %getpeername (:name "getpeername")
542 (:arguments (sockfd ffi:int)
543 (peeraddr (ffi:c-ptr sockaddr) :in-out)
544 (addrlen (ffi:c-ptr socklen_t) :in-out))
545 #+win32 (:library "WS2_32")
546 #-win32 (:library :default)
547 (:language #-win32 :stdc
548 #+win32 :stdc-stdcall)
549 (:return-type ffi:int))
550
551 ;; socket constants
552 (defconstant +socket-af-inet+ 2)
553 (defconstant +socket-sock-dgram+ 2)
554 (defconstant +socket-ip-proto-udp+ 17)
555
556 (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout")
557
558 (defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in))
559
560 (declaim (inline fill-sockaddr_in))
561 (defun fill-sockaddr_in (sockaddr host port)
562 (let ((hbo (host-to-hbo host)))
563 (ffi:with-c-place (place sockaddr)
564 #+macos
565 (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*)
566 (setf (ffi:slot place 'sin_family) +socket-af-inet+
567 (ffi:slot place 'sin_port) (%htons port)
568 (ffi:slot place 'sin_addr) (%htonl hbo)))
569 sockaddr))
570
571 (defun socket-create-datagram (local-port
572 &key (local-host *wildcard-host*)
573 remote-host
574 remote-port)
575 (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+))
576 (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
577 local-host local-port))
578 (rsock_addr (when remote-host
579 (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
580 remote-host (or remote-port local-port)))))
581 (unless (plusp sock)
582 (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno)))
583 (unwind-protect
584 (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
585 *length-of-sockaddr_in*)))
586 (unless (zerop rv)
587 (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno)))
588 (when rsock_addr
589 (let ((rv (%connect sock
590 (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
591 *length-of-sockaddr_in*)))
592 (unless (zerop rv)
593 (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno))))))
594 (ffi:foreign-free lsock_addr)
595 (when remote-host
596 (ffi:foreign-free rsock_addr)))
597 (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
598
599 (defun finalize-datagram-usocket (object)
600 (when (datagram-usocket-p object)
601 (socket-close object)))
602
603 (defmethod initialize-instance :after ((usocket datagram-usocket) &key)
604 (setf (slot-value usocket 'recv-buffer)
605 (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+))
606 ;; finalize the object
607 (ext:finalize usocket 'finalize-datagram-usocket))
608
609 (defmethod socket-close ((usocket datagram-usocket))
610 (with-slots (recv-buffer socket) usocket
611 (ffi:foreign-free recv-buffer)
612 (zerop (%close socket))))
613
614 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
615 (let ((remote-address (ffi:allocate-shallow 'sockaddr_in))
616 (remote-address-length (ffi:allocate-shallow 'ffi:int))
617 nbytes (host 0) (port 0))
618 (setf (ffi:foreign-value remote-address-length)
619 *length-of-sockaddr_in*)
620 (unwind-protect
621 (multiple-value-bind (n address address-length)
622 (%recvfrom (socket usocket)
623 (ffi:foreign-address (slot-value usocket 'recv-buffer))
624 +max-datagram-packet-size+
625 0 ; flags
626 (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
627 (ffi:foreign-value remote-address-length))
628 (when (minusp n)
629 (error "SOCKET-RECEIVE ERROR: ~A" (os:errno)))
630 (setq nbytes n)
631 (when (= address-length *length-of-sockaddr_in*)
632 (let ((data (sockaddr-sa_data address)))
633 (setq host (ip-from-octet-buffer data :start 2)
634 port (port-from-octet-buffer data))))
635 (cond ((plusp n)
636 (let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer))))
637 (if buffer ; replace exist buffer of create new return buffer
638 (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+))
639 (end-2 (min n +max-datagram-packet-size+)))
640 (replace buffer return-buffer :end1 end-1 :end2 end-2))
641 (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))))
642 ((zerop n))))
643 (ffi:foreign-free remote-address)
644 (ffi:foreign-free remote-address-length))
645 (values buffer nbytes host port)))
646
647 ;; implementation note: different from socket-receive, we know how many bytes we want to send everytime,
648 ;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those
649 ;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time.
650 ;;
651 ;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP.
652 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
653 (declare (type sequence buffer)
654 (type (integer 0 *) size offset))
655 (let ((remote-address
656 (when (and host port)
657 (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port)))
658 (send-buffer
659 (ffi:allocate-deep 'ffi:uint8
660 (if (zerop offset)
661 buffer
662 (subseq buffer offset (+ offset size)))
663 :count size :read-only t))
664 (real-size (min size +max-datagram-packet-size+))
665 (nbytes 0))
666 (unwind-protect
667 (let ((n (if remote-address
668 (%sendto (socket usocket)
669 (ffi:foreign-address send-buffer)
670 real-size
671 0 ; flags
672 (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
673 *length-of-sockaddr_in*)
674 (%send (socket usocket)
675 (ffi:foreign-address send-buffer)
676 real-size
677 0))))
678 (cond ((plusp n)
679 (setq nbytes n))
680 ((zerop n)
681 (setq nbytes n))
682 (t (error "SOCKET-SEND ERROR: ~A" (os:errno)))))
683 (ffi:foreign-free send-buffer)
684 (when remote-address
685 (ffi:foreign-free remote-address))
686 nbytes)))
687
688 (declaim (inline get-socket-name))
689 (defun get-socket-name (socket function)
690 (let ((address (ffi:allocate-shallow 'sockaddr_in))
691 (address-length (ffi:allocate-shallow 'ffi:int))
692 (host 0) (port 0))
693 (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*)
694 (unwind-protect
695 (multiple-value-bind (rv return-address return-address-length)
696 (funcall function socket
697 (ffi:cast (ffi:foreign-value address) 'sockaddr)
698 (ffi:foreign-value address-length))
699 (declare (ignore return-address-length))
700 (if (zerop rv)
701 (let ((data (sockaddr-sa_data return-address)))
702 (setq host (ip-from-octet-buffer data :start 2)
703 port (port-from-octet-buffer data)))
704 (error "GET-SOCKET-NAME ERROR: ~A" (os:errno))))
705 (ffi:foreign-free address)
706 (ffi:foreign-free address-length))
707 (values (hbo-to-vector-quad host) port)))
708
709 (defmethod get-local-name ((usocket datagram-usocket))
710 (get-socket-name (socket usocket) '%getsockname))
711
712 (defmethod get-peer-name ((usocket datagram-usocket))
713 (get-socket-name (socket usocket) '%getpeername))
714
715 ) ; progn