GopherProxy

	tclisp.lisp - clic - Clic is an command line interactive client for gopher writ…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	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 wor…
	8 #-(or ffi rawsock)
	9 (warn "This image doesn't contain either FFI or RAWSOCK package, no UD…
	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, el…
	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 c…
	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 err…
	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 '…
	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 t…
	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…
	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 …
	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-ty…
	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 mu…
	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-l…
	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 &ke…
	304 "Returns the buffer, the number of octets copied into the buffer (re…
	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 hos…
	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 …
	335 buffer
	336 (make-array real-size
	337 :element-type '(unsigned-byte 8)
	338 :initial-contents (subseq buffer 0…
	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 r…
	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…
	575 (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_…
	576 local-host local-port))
	577 (rsock_addr (when remote-host
	578 (fill-sockaddr_in (ffi:allocate-shallow 'sockadd…
	579 remote-host (or remote-port lo…
	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…
	584 length-of-sockaddr_in)))
	585 (unless (zerop rv)
	586 (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errn…
	587 (when rsock_addr
	588 (let ((rv (%connect sock
	589 (ffi:cast (ffi:foreign-value rsock_ad…
	590 length-of-sockaddr_in)))
	591 (unless (zerop rv)
	592 (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (…
	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-s…
	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 &k…
	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…
	625 +max-datagram-packet-size+
	626 0 ; flags
	627 (ffi:cast (ffi:foreign-value remote-address) '…
	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 …
	638 (if buffer ; replace exist buffer of create new re…
	639 (let ((end-1 (min (or length (length buffer)) …
	640 (end-2 (min n +max-datagram-packet-size+…
	641 (replace buffer return-buffer :end1 end-1 :e…
	642 (setq buffer (subseq return-buffer 0 (min n +m…
	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 man…
	649 ;; so, a send buffer will not needed, and if there is a buffer, it's h…
	650 ;; in LispWorks. So, we allocate new foreign buffer for holding data (…
	651 ;;
	652 ;; I don't know if anyone is watching my coding work, but I think this…
	653 (defmethod socket-send ((usocket datagram-usocket) buffer size &key ho…
	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 …
	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-add…
	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