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