GopherProxy

	tusocket.lisp - clic - Clic is an command line interactive client for gopher wr…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tusocket.lisp (26070B)
	---
	1 ;;;; See LICENSE for licensing information.
	2
	3 (in-package :usocket)
	4
	5 (defparameter wildcard-host #(0 0 0 0)
	6 "Hostname to pass when all interfaces in the current system are to
	7 be bound. If this variable is passed to socket-listen, IPv6 capable
	8 systems will also listen for IPv6 connections.")
	9
	10 (defparameter auto-port 0
	11 "Port number to pass when an auto-assigned port number is wanted.")
	12
	13 (defparameter version #.(asdf:component-version (asdf:find-system :uso…
	14 "usocket version string")
	15
	16 (defconstant +max-datagram-packet-size+ 65507
	17 "The theoretical maximum amount of data in a UDP datagram.
	18
	19 The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header …
	20
	21 IP_MAXPACKET = 65535, /* netinet/ip.h */
	22 sizeof(struct ip) = 20, /* netinet/ip.h */
	23 sizeof(struct udphdr) = 8, /* netinet/udp.h */
	24
	25 65535 - 20 - 8 = 65507
	26
	27 (But for UDP broadcast, the maximum message size is limited by the MTU s…
	28
	29 (defclass usocket ()
	30 ((socket
	31 :initarg :socket
	32 :accessor socket
	33 :documentation "Implementation specific socket object instance.'")
	34 (wait-list
	35 :initform nil
	36 :accessor wait-list
	37 :documentation "WAIT-LIST the object is associated with.")
	38 (state
	39 :initform nil
	40 :accessor state
	41 :documentation "Per-socket return value for the `wait-for-input' fun…
	42
	43 The value stored in this slot can be any of
	44 NIL - not ready
	45 :READ - ready to read
	46 :READ-WRITE - ready to read and write
	47 :WRITE - ready to write
	48
	49 The last two remain unused in the current version.
	50 ")
	51 #+(and win32 (or sbcl ecl lispworks))
	52 (%ready-p
	53 :initform nil
	54 :accessor %ready-p
	55 :documentation "Indicates whether the socket has been signalled
	56 as ready for reading a new connection.
	57
	58 The value will be set to T by `wait-for-input-internal' (given the
	59 right conditions) and reset to NIL by `socket-accept'.
	60
	61 Don't modify this slot or depend on it as it is really intended
	62 to be internal only.
	63
	64 Note: Accessed, but not used for 'stream-usocket'.
	65 "
	66 ))
	67 (:documentation
	68 "The main socket class.
	69
	70 Sockets should be closed using the `socket-close' method."))
	71
	72 (defgeneric socket-state (socket)
	73 (:documentation "NIL - not ready
	74 :READ - ready to read
	75 :READ-WRITE - ready to read and write
	76 :WRITE - ready to write"))
	77
	78 (defmethod socket-state ((socket usocket))
	79 (state socket))
	80
	81 (defclass stream-usocket (usocket)
	82 ((stream
	83 :initarg :stream
	84 :accessor socket-stream
	85 :documentation "Stream instance associated with the socket."
	86 ;;
	87 ;;Iff an external-format was passed to `socket-connect' or `socket-liste…
	88 ;;the stream is a flexi-stream. Otherwise the stream is implementation
	89 ;;specific."
	90 ))
	91 (:documentation
	92 "Stream socket class.
	93 '
	94 Contrary to other sockets, these sockets may be closed either
	95 with the `socket-close' method or by closing the associated stream
	96 (which can be retrieved with the `socket-stream' accessor)."))
	97
	98 (defclass stream-server-usocket (usocket)
	99 ((element-type
	100 :initarg :element-type
	101 :initform #-lispworks 'character
	102 #+lispworks 'base-char
	103 :reader element-type
	104 :documentation "Default element type for streams created by
	105 `socket-accept'."))
	106 (:documentation "Socket which listens for stream connections to
	107 be initiated from remote sockets."))
	108
	109 (defclass datagram-usocket (usocket)
	110 ((connected-p :type boolean
	111 :accessor connected-p
	112 :initarg :connected-p)
	113 #+(or cmu scl lispworks mcl
	114 (and clisp ffi (not rawsock)))
	115 (%open-p :type boolean
	116 :accessor %open-p
	117 :initform t
	118 :documentation "Flag to indicate if usocket is open,
	119 for GC on implementions operate on raw socket fd.")
	120 #+(or lispworks mcl
	121 (and clisp ffi (not rawsock)))
	122 (recv-buffer :documentation "Private RECV buffer.")
	123 #+(or lispworks mcl)
	124 (send-buffer :documentation "Private SEND buffer."))
	125 (:documentation "UDP (inet-datagram) socket"))
	126
	127 (defun usocket-p (socket)
	128 (typep socket 'usocket))
	129
	130 (defun stream-usocket-p (socket)
	131 (typep socket 'stream-usocket))
	132
	133 (defun stream-server-usocket-p (socket)
	134 (typep socket 'stream-server-usocket))
	135
	136 (defun datagram-usocket-p (socket)
	137 (typep socket 'datagram-usocket))
	138
	139 (defun make-socket (&key socket)
	140 "Create a usocket socket type from implementation specific socket."
	141 (unless socket
	142 (error 'invalid-socket-error))
	143 (make-stream-socket :socket socket))
	144
	145 (defun make-stream-socket (&key socket stream)
	146 "Create a usocket socket type from implementation specific socket
	147 and stream objects.
	148
	149 Sockets returned should be closed using the `socket-close' method or
	150 by closing the stream associated with the socket.
	151 "
	152 (unless socket
	153 (error 'invalid-socket-error))
	154 (unless stream
	155 (error 'invalid-socket-stream-error))
	156 (make-instance 'stream-usocket
	157 :socket socket
	158 :stream stream))
	159
	160 (defun make-stream-server-socket (socket &key (element-type
	161 #-lispworks 'character
	162 #+lispworks 'base-char))
	163 "Create a usocket-server socket type from an
	164 implementation-specific socket object.
	165
	166 The returned value is a subtype of `stream-server-usocket'.
	167 "
	168 (unless socket
	169 (error 'invalid-socket-error))
	170 (make-instance 'stream-server-usocket
	171 :socket socket
	172 :element-type element-type))
	173
	174 (defun make-datagram-socket (socket &key connected-p)
	175 (unless socket
	176 (error 'invalid-socket-error))
	177 (make-instance 'datagram-usocket
	178 :socket socket
	179 :connected-p connected-p))
	180
	181 (defgeneric socket-accept (socket &key element-type)
	182 (:documentation
	183 "Accepts a connection from `socket', returning a `stream-socket'.
	184
	185 The stream associated with the socket returned has `element-type' when
	186 explicitly specified, or the element-type passed to `socket-listen' othe…
	187
	188 (defgeneric socket-close (usocket)
	189 (:documentation "Close a previously opened `usocket'."))
	190
	191 ;; also see http://stackoverflow.com/questions/4160347/close-vs-shutdown…
	192 (defgeneric socket-shutdown (usocket direction)
	193 (:documentation "Shutdown communication on the socket in DIRECTION.
	194
	195 After a shutdown no input and/or output of the indicated DIRECTION
	196 can be performed on the `usocket'.
	197
	198 DIRECTION should be either :INPUT or :OUTPUT or :IO"))
	199
	200 (defgeneric socket-send (usocket buffer length &key host port)
	201 (:documentation "Send packets through a previously opend `usocket'."))
	202
	203 (defgeneric socket-receive (usocket buffer length &key)
	204 (:documentation "Receive packets from a previously opend `usocket'.
	205
	206 Returns 4 values: (values buffer size host port)"))
	207
	208 (defgeneric get-local-address (socket)
	209 (:documentation "Returns the IP address of the socket."))
	210
	211 (defgeneric get-peer-address (socket)
	212 (:documentation
	213 "Returns the IP address of the peer the socket is connected to."))
	214
	215 (defgeneric get-local-port (socket)
	216 (:documentation "Returns the IP port of the socket.
	217
	218 This function applies to both `stream-usocket' and `server-stream-usocke…
	219 type objects."))
	220
	221 (defgeneric get-peer-port (socket)
	222 (:documentation "Returns the IP port of the peer the socket to."))
	223
	224 (defgeneric get-local-name (socket)
	225 (:documentation "Returns the IP address and port of the socket as valu…
	226
	227 This function applies to both `stream-usocket' and `server-stream-usocke…
	228 type objects."))
	229
	230 (defgeneric get-peer-name (socket)
	231 (:documentation
	232 "Returns the IP address and port of the peer
	233 the socket is connected to as values."))
	234
	235 (defmacro with-connected-socket ((var socket) &body body)
	236 "Bind `socket' to `var', ensuring socket destruction on exit.
	237
	238 `body' is only evaluated when `var' is bound to a non-null value.
	239
	240 The `body' is an implied progn form."
	241 `(let ((,var ,socket))
	242 (unwind-protect
	243 (when ,var
	244 (with-mapped-conditions (,var)
	245 ,@body))
	246 (when ,var
	247 (socket-close ,var)))))
	248
	249 (defmacro with-client-socket ((socket-var stream-var &rest socket-connec…
	250 &body body)
	251 "Bind the socket resulting from a call to `socket-connect' with
	252 the arguments `socket-connect-args' to `socket-var' and if `stream-var' …
	253 non-nil, bind the associated socket stream to it."
	254 `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-…
	255 ,(if (null stream-var)
	256 `(progn ,@body)
	257 `(let ((,stream-var (socket-stream ,socket-var)))
	258 ,@body))))
	259
	260 (defmacro with-server-socket ((var server-socket) &body body)
	261 "Bind `server-socket' to `var', ensuring socket destruction on exit.
	262
	263 `body' is only evaluated when `var' is bound to a non-null value.
	264
	265 The `body' is an implied progn form."
	266 `(with-connected-socket (,var ,server-socket)
	267 ,@body))
	268
	269 (defmacro with-socket-listener ((socket-var &rest socket-listen-args)
	270 &body body)
	271 "Bind the socket resulting from a call to `socket-listen' with argumen…
	272 `socket-listen-args' to `socket-var'."
	273 `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args))
	274 ,@body))
	275
	276 (defstruct (wait-list (:constructor %make-wait-list))
	277 %wait ;; implementation specific
	278 waiters ;; the list of all usockets
	279 map) ;; maps implementation sockets to usockets
	280
	281 ;; Implementation specific:
	282 ;;
	283 ;; %setup-wait-list
	284 ;; %add-waiter
	285 ;; %remove-waiter
	286
	287 (defun make-wait-list (waiters)
	288 (let ((wl (%make-wait-list)))
	289 (setf (wait-list-map wl) (make-hash-table))
	290 (%setup-wait-list wl)
	291 (dolist (x waiters wl)
	292 (add-waiter wl x))))
	293
	294 (defun add-waiter (wait-list input)
	295 (setf (gethash (socket input) (wait-list-map wait-list)) input
	296 (wait-list input) wait-list)
	297 (pushnew input (wait-list-waiters wait-list))
	298 (%add-waiter wait-list input))
	299
	300 (defun remove-waiter (wait-list input)
	301 (%remove-waiter wait-list input)
	302 (setf (wait-list-waiters wait-list)
	303 (remove input (wait-list-waiters wait-list))
	304 (wait-list input) nil)
	305 (remhash (socket input) (wait-list-map wait-list)))
	306
	307 (defun remove-all-waiters (wait-list)
	308 (dolist (waiter (wait-list-waiters wait-list))
	309 (%remove-waiter wait-list waiter))
	310 (setf (wait-list-waiters wait-list) nil)
	311 (clrhash (wait-list-map wait-list)))
	312
	313 (defun wait-for-input (socket-or-sockets &key timeout ready-only)
	314 "Waits for one or more streams to become ready for reading from
	315 the socket. When `timeout' (a non-negative real number) is
	316 specified, wait `timeout' seconds, or wait indefinitely when
	317 it isn't specified. A `timeout' value of 0 (zero) means polling.
	318
	319 Returns two values: the first value is the list of streams which
	320 are readable (or in case of server streams acceptable). NIL may
	321 be returned for this value either when waiting timed out or when
	322 it was interrupted (EINTR). The second value is a real number
	323 indicating the time remaining within the timeout period or NIL if
	324 none.
	325
	326 Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in
	327 the original list you passed it. This prevents a new list from being
	328 consed up. Some users of USOCKET were reluctant to use it if it
	329 wouldn't behave that way, expecting it to cost significant performance
	330 to do the associated garbage collection.
	331
	332 Without the READY-ONLY arg, you need to check the socket STATE slot for
	333 the values documented in usocket.lisp in the usocket class."
	334
	335 ;; for NULL sockets, return NIL with respect of TIMEOUT.
	336 (when (null socket-or-sockets)
	337 (when timeout
	338 (sleep timeout))
	339 (return-from wait-for-input nil))
	340
	341 (unless (wait-list-p socket-or-sockets)
	342 (let ((wl (make-wait-list (if (listp socket-or-sockets)
	343 socket-or-sockets (list socket-or-sock…
	344 (multiple-value-bind
	345 (socks to)
	346 (wait-for-input wl :timeout timeout :ready-only ready-only)
	347 ;; NOTE: in case waiter is not created by the user, it should be…
	348 (remove-all-waiters wl)
	349 (return-from wait-for-input
	350 (values (if ready-only socks socket-or-sockets) to)))))
	351 (let* ((start (get-internal-real-time))
	352 (sockets-ready 0))
	353 (dolist (x (wait-list-waiters socket-or-sockets))
	354 (when (setf (state x)
	355 #+(and win32 (or sbcl ecl)) nil ; they cannot rely on …
	356 #-(and win32 (or sbcl ecl))
	357 (if (and (stream-usocket-p x)
	358 (listen (socket-stream x)))
	359 :read
	360 nil))
	361 (incf sockets-ready)))
	362 ;; the internal routine is responsibe for
	363 ;; making sure the wait doesn't block on socket-streams of
	364 ;; which theready- socket isn't ready, but there's space left in the
	365 ;; buffer
	366 (wait-for-input-internal socket-or-sockets
	367 :timeout (if (zerop sockets-ready) timeout …
	368 (let ((to-result (when timeout
	369 (let ((elapsed (/ (- (get-internal-real-time) sta…
	370 internal-time-units-per-second)…
	371 (when (< elapsed timeout)
	372 (- timeout elapsed))))))
	373 (values (if ready-only
	374 (remove-if #'null (wait-list-waiters socket-or-sockets…
	375 socket-or-sockets)
	376 to-result))))
	377
	378 ;;
	379 ;; Data utility functions
	380 ;;
	381
	382 (defun integer-to-octet-buffer (integer buffer octets &key (start 0))
	383 (do ((b start (1+ b))
	384 (i (ash (1- octets) 3) ;; * 8
	385 (- i 8)))
	386 ((> 0 i) buffer)
	387 (setf (aref buffer b)
	388 (ldb (byte 8 i) integer))))
	389
	390 (defun octet-buffer-to-integer (buffer octets &key (start 0))
	391 (let ((integer 0))
	392 (do ((b start (1+ b))
	393 (i (ash (1- octets) 3) ;; * 8
	394 (- i 8)))
	395 ((> 0 i)
	396 integer)
	397 (setf (ldb (byte 8 i) integer)
	398 (aref buffer b)))))
	399
	400 (defmacro port-to-octet-buffer (port buffer &key (start 0))
	401 `(integer-to-octet-buffer ,port ,buffer 2 :start ,start))
	402
	403 (defmacro ip-to-octet-buffer (ip buffer &key (start 0))
	404 `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,star…
	405
	406 (defmacro port-from-octet-buffer (buffer &key (start 0))
	407 `(octet-buffer-to-integer ,buffer 2 :start ,start))
	408
	409 (defmacro ip-from-octet-buffer (buffer &key (start 0))
	410 `(octet-buffer-to-integer ,buffer 4 :start ,start))
	411
	412 ;;
	413 ;; IPv4 utility functions
	414 ;;
	415
	416 (defun list-of-strings-to-integers (list)
	417 "Take a list of strings and return a new list of integers (from
	418 parse-integer) on each of the string elements."
	419 (let ((new-list nil))
	420 (dolist (element (reverse list))
	421 (push (parse-integer element) new-list))
	422 new-list))
	423
	424 (defun ip-address-string-p (string)
	425 "Return a true value if the given string could be an IP address."
	426 (every (lambda (char)
	427 (or (digit-char-p char)
	428 (eql char #\.)))
	429 string))
	430
	431 (defun hbo-to-dotted-quad (integer) ; exported
	432 "Host-byte-order integer to dotted-quad string conversion utility."
	433 (let ((first (ldb (byte 8 24) integer))
	434 (second (ldb (byte 8 16) integer))
	435 (third (ldb (byte 8 8) integer))
	436 (fourth (ldb (byte 8 0) integer)))
	437 (format nil "~A.~A.~A.~A" first second third fourth)))
	438
	439 (defun hbo-to-vector-quad (integer) ; exported
	440 "Host-byte-order integer to dotted-quad string conversion utility."
	441 (let ((first (ldb (byte 8 24) integer))
	442 (second (ldb (byte 8 16) integer))
	443 (third (ldb (byte 8 8) integer))
	444 (fourth (ldb (byte 8 0) integer)))
	445 (vector first second third fourth)))
	446
	447 (defun vector-quad-to-dotted-quad (vector) ; exported
	448 (format nil "~A.~A.~A.~A"
	449 (aref vector 0)
	450 (aref vector 1)
	451 (aref vector 2)
	452 (aref vector 3)))
	453
	454 (defun dotted-quad-to-vector-quad (string) ; exported
	455 (let ((list (list-of-strings-to-integers (split-sequence #\. string))))
	456 (vector (first list) (second list) (third list) (fourth list))))
	457
	458 (defgeneric host-byte-order (address)) ; exported
	459
	460 (defmethod host-byte-order ((string string))
	461 "Convert a string, such as 192.168.1.1, to host-byte-order,
	462 such as 3232235777."
	463 (let ((list (list-of-strings-to-integers (split-sequence #\. string))))
	464 (+ (* (first list) 256 256 256) (* (second list) 256 256)
	465 (* (third list) 256) (fourth list))))
	466
	467 (defmethod host-byte-order ((vector vector)) ; IPv4 only
	468 "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as
	469 3232235777."
	470 (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256)
	471 (* (aref vector 2) 256) (aref vector 3)))
	472
	473 (defmethod host-byte-order ((int integer))
	474 int) ; this assume input integer is already host-byte-order
	475
	476 ;;
	477 ;; IPv6 utility functions
	478 ;;
	479
	480 (defun vector-to-ipv6-host (vector) ; exported
	481 (with-output-to-string (standard-output)
	482 (loop with zeros-collapsed-p
	483 with collapsing-zeros-p
	484 for i below 16 by 2
	485 for word = (+ (ash (aref vector i) 8)
	486 (aref vector (1+ i)))
	487 do (cond
	488 ((and (zerop word)
	489 (not collapsing-zeros-p)
	490 (not zeros-collapsed-p))
	491 (setf collapsing-zeros-p t))
	492 ((or (not (zerop word))
	493 zeros-collapsed-p)
	494 (when collapsing-zeros-p
	495 (write-string ":")
	496 (setf collapsing-zeros-p nil
	497 zeros-collapsed-p t))
	498 (format t "~:[~;:~]~X" (plusp i) word)))
	499 finally (when collapsing-zeros-p
	500 (write-string "::")))))
	501
	502 (defun split-ipv6-address (string)
	503 (let ((pos 0)
	504 word
	505 double-colon-seen-p
	506 words-before-double-colon
	507 words-after-double-colon)
	508 (loop
	509 (multiple-value-setq (word pos) (parse-integer string :radix 16 :j…
	510 (labels ((at-end-p ()
	511 (= pos (length string)))
	512 (looking-at-colon-p ()
	513 (char= (char string pos) #\:))
	514 (ensure-colon ()
	515 (unless (looking-at-colon-p)
	516 (error "unsyntactic IPv6 address string ~S, expected …
	517 string pos))
	518 (incf pos)))
	519 (cond
	520 ((null word)
	521 (when double-colon-seen-p
	522 (error "unsyntactic IPv6 address string ~S, can only have o…
	523 string))
	524 (setf double-colon-seen-p t))
	525 (double-colon-seen-p
	526 (push word words-after-double-colon))
	527 (t
	528 (push word words-before-double-colon)))
	529 (if (at-end-p)
	530 (return (list (nreverse words-before-double-colon) (nreverse…
	531 (ensure-colon))))))
	532
	533 (defun ipv6-host-to-vector (string) ; exported
	534 (assert (> (length string) 2) ()
	535 "Unsyntactic IPv6 address literal ~S, expected at least three …
	536 (destructuring-bind (words-before-double-colon words-after-double-colo…
	537 (split-ipv6-address (concatenate 'string
	538 (when (eql (char string 0) #\:)
	539 "0")
	540 string
	541 (when (eql (char string (1- (leng…
	542 "0")))
	543 (let ((number-of-words-specified (+ (length words-before-double-colo…
	544 (assert (<= number-of-words-specified 8) ()
	545 "Unsyntactic IPv6 address literal ~S, too many colon separ…
	546 (assert (or (= number-of-words-specified 8) words-after-double-col…
	547 "Unsyntactic IPv6 address literal ~S, too few address comp…
	548 (loop with vector = (make-array 16 :element-type '(unsigned-byte 8…
	549 for i below 16 by 2
	550 for word in (append words-before-double-colon
	551 (make-list (- 8 number-of-words-specifie…
	552 words-after-double-colon)
	553 do (setf (aref vector i) (ldb (byte 8 8) word)
	554 (aref vector (1+ i)) (ldb (byte 8 0) word))
	555 finally (return vector)))))
	556
	557 (defun host-to-hostname (host) ; host -> string
	558 "Translate a string, vector quad or 16 byte IPv6 address to a
	559 stringified hostname."
	560 (etypecase host
	561 (string host) ; IPv4 or IPv6
	562 ((or (vector t 4) ; IPv4
	563 (array (unsigned-byte 8) (4)))
	564 (vector-quad-to-dotted-quad host))
	565 ((or (vector t 16) ; IPv6
	566 (array (unsigned-byte 8) (16)))
	567 (vector-to-ipv6-host host))
	568 (integer (hbo-to-dotted-quad host)) ; integer input is IPv4 only
	569 (null "0.0.0.0"))) ; null is IPv4
	570
	571 (defun ip= (ip1 ip2) ; exported
	572 (etypecase ip1
	573 (string (string= ip1 ; IPv4 or IPv6
	574 (host-to-hostname ip2)))
	575 ((or (vector t 4) ; IPv4
	576 (array (unsigned-byte 8) (4)) ; IPv4
	577 (vector t 16) ; IPv6
	578 (array (unsigned-byte 8) (16))) ; IPv6
	579 (equalp ip1 ip2))
	580 (integer (= ip1 ; IPv4 only
	581 (host-byte-order ip2))))) ; convert ip2 to integer (hbo)
	582
	583 (defun ip/= (ip1 ip2) ; exported
	584 (not (ip= ip1 ip2)))
	585
	586 ;;
	587 ;; DNS helper functions
	588 ;;
	589
	590 (defun get-host-by-name (name)
	591 "0.7.1+: if there're IPv4 addresses, return the first IPv4 address."
	592 (let* ((hosts (get-hosts-by-name name))
	593 (pos (position-if #'(lambda (ip) (= 4 (length ip))) hosts)))
	594 (if pos (elt hosts pos)
	595 (car hosts))))
	596
	597 (defun get-random-host-by-name (name)
	598 "0.7.1+: if there're IPv4 addresses, only return a random IPv4 address…
	599 (let* ((hosts (get-hosts-by-name name))
	600 (ipv4-hosts (remove-if-not #'(lambda (ip) (= 4 (length ip))) ho…
	601 (cond (ipv4-hosts
	602 (elt ipv4-hosts (random (length ipv4-hosts))))
	603 (hosts
	604 (elt hosts (random (length hosts)))))))
	605
	606 (defun host-to-vector-quad (host) ; internal
	607 "Translate a host specification (vector quad, dotted quad or domain na…
	608 to a vector quad."
	609 (etypecase host
	610 (string (let* ((ip (when (ip-address-string-p host)
	611 (dotted-quad-to-vector-quad host))))
	612 (if (and ip (= 4 (length ip)))
	613 ;; valid IP dotted quad? not sure
	614 ip
	615 (get-random-host-by-name host))))
	616 ((or (vector t 4)
	617 (array (unsigned-byte 8) (4)))
	618 host)
	619 (integer (hbo-to-vector-quad host))))
	620
	621 (defun host-to-hbo (host) ; internal
	622 (etypecase host
	623 (string (let ((ip (when (ip-address-string-p host)
	624 (dotted-quad-to-vector-quad host))))
	625 (if (and ip (= 4 (length ip)))
	626 (host-byte-order ip)
	627 (host-to-hbo (get-host-by-name host)))))
	628 ((or (vector t 4)
	629 (array (unsigned-byte 8) (4)))
	630 (host-byte-order host))
	631 (integer host)))
	632
	633 ;;
	634 ;; Other utility functions
	635 ;;
	636
	637 (defun split-timeout (timeout &optional (fractional 1000000))
	638 "Split real value timeout into seconds and microseconds.
	639 Optionally, a different fractional part can be specified."
	640 (multiple-value-bind
	641 (secs sec-frac)
	642 (truncate timeout 1)
	643 (values secs
	644 (truncate (* fractional sec-frac) 1))))
	645
	646 ;;
	647 ;; Setting of documentation for backend defined functions
	648 ;;
	649
	650 ;; Documentation for the function
	651 ;;
	652 ;; (defun SOCKET-CONNECT (host port &key element-type nodelay some-other…
	653 ;;
	654 (setf (documentation 'socket-connect 'function)
	655 "Connect to `host' on `port'. `host' is assumed to be a string or
	656 an IP address represented in vector notation, such as #(192 168 1 1).
	657 `port' is assumed to be an integer.
	658
	659 `element-type' specifies the element type to use when constructing the
	660 stream associated with the socket. The default is 'character.
	661
	662 `nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedi…
	663 If this parameter is omitted, the behaviour is inherited from the
	664 CL implementation (in most cases, Nagle's algorithm is
	665 enabled by default, but for example in ACL it is disabled).
	666 If the parameter is specified, one of these three values is possible:
	667 T - Disable Nagle's algorithm; signals an UNSUPPORTED
	668 condition if the implementation does not support explicit
	669 manipulation with that option.
	670 NIL - Leave Nagle's algorithm enabled on the socket;
	671 signals an UNSUPPORTED condition if the implementation does
	672 not support explicit manipulation with that option.
	673 :IF-SUPPORTED - Disables Nagle's algorithm if the implementation
	674 allows this, otherwises just ignore this option.
	675
	676 Returns a usocket object.")
	677
	678 ;; Documentation for the function
	679 ;;
	680 ;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-typ…
	681 ;;###FIXME: extend with default-element-type
	682 (setf (documentation 'socket-listen 'function)
	683 "Bind to interface `host' on `port'. `host' should be the
	684 representation of an ready-interface address. The implementation is
	685 not required to do an address lookup, making no guarantees that
	686 hostnames will be correctly resolved. If `wildcard-host' or NIL is
	687 passed for `host', the socket will be bound to all available
	688 interfaces for the system. `port' can be selected by the IP stack by
	689 passing `auto-port'.
	690
	691 Returns an object of type `stream-server-usocket'.
	692
	693 `reuse-address' and `backlog' are advisory parameters for setting socket
	694 options at creation time. `element-type' is the element type of the
	695 streams to be created by `socket-accept'. `reuseaddress' is supported f…
	696 backward compatibility (but deprecated); when both `reuseaddress' and
	697 `reuse-address' have been specified, the latter takes precedence.
	698 ")
	699
	700 ;;; Small utility functions mapping true/false to 1/0, moved here from o…
	701
	702 (proclaim '(inline bool->int int->bool))
	703
	704 (defun bool->int (bool) (if bool 1 0))
	705 (defun int->bool (int) (= 1 int))