3rdparties/software/usocket-0.8.3/backend/clisp.lisp (26836 bytes)
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