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