(defmethod make-load-form ((object savable-object) &optional environment)
(make-load-form-saving-slots object :environment environment))
+(defun natural-string< (string1 string2
+ &key (start1 0) (end1 nil)
+ (start2 0) (end2 nil))
+ "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
+
+ In particular, digit sequences are handled in a moderately sensible way.
+ Split the strings into maximally long alternating sequences of non-numeric
+ and numeric characters, such that the non-numeric sequences are
+ non-empty. Compare these lexicographically; numeric sequences order
+ according to their integer values, non-numeric sequences in the usual
+ lexicographic ordering.
+
+ Returns two values: whether STRING1 strictly precedes STRING2, and whether
+ STRING1 strictly follows STRING2."
+
+ (let ((end1 (or end1 (length string1)))
+ (end2 (or end2 (length string2))))
+ (loop
+ (cond ((>= start1 end1)
+ (let ((eqp (>= start2 end2)))
+ (return (values (not eqp) nil))))
+ ((>= start2 end2)
+ (return (values nil t)))
+ ((and (digit-char-p (char string1 start1))
+ (digit-char-p (char string2 start2)))
+ (let* ((lim1 (or (position-if-not #'digit-char-p string1
+ :start start1 :end end1)
+ end1))
+ (n1 (parse-integer string1 :start start1 :end lim1))
+ (lim2 (or (position-if-not #'digit-char-p string2
+ :start start2 :end end2)
+ end2))
+ (n2 (parse-integer string2 :start start2 :end lim2)))
+ (cond ((< n1 n2) (return (values t nil)))
+ ((> n1 n2) (return (values nil t))))
+ (setf start1 lim1
+ start2 lim2)))
+ (t
+ (let ((lim1 (or (position-if #'digit-char-p string1
+ :start start1 :end end1)
+ end1))
+ (lim2 (or (position-if #'digit-char-p string2
+ :start start2 :end end2)
+ end2)))
+ (cond ((string< string1 string2
+ :start1 start1 :end1 lim1
+ :start2 start2 :end2 lim2)
+ (return (values t nil)))
+ ((string> string1 string2
+ :start1 start1 :end1 lim1
+ :start2 start2 :end2 lim2)
+ (return (values nil t))))
+ (setf start1 lim1
+ start2 lim2)))))))
+
;;;--------------------------------------------------------------------------
;;; Parsing primitives for addresses.
"Base class for IP addresses."))
(export 'ipaddr-family)
-(defgeneric ipaddr-family (addr))
+(defgeneric ipaddr-family (addr)
+ (:documentation "Return the address family of ADDR, as a keyword."))
(export 'family-addrclass)
(defgeneric family-addrclass (family)
+ (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.")
(:method ((af symbol)) nil))
(export 'ipaddr-width)
(defgeneric ipaddr-width (class)
+ (:documentation "Return the width, in bits, of addresses from CLASS.
+
+ Alternatively, the CLASS may be given as an example object.")
(:method ((object t)) (ipaddr-width (extract-class-name object))))
(export 'ipaddr-comparable-p)
(defgeneric ipaddr-comparable-p (addr-a addr-b)
+ (:documentation "Is it meaningful to compare ADDR-A and ADDR-B?")
(:method ((addr-a ipaddr) (addr-b ipaddr))
(eq (class-of addr-a) (class-of addr-b))))
(defun guess-address-class (str &key (start 0) (end nil))
- (declare (ignore str start end))
- 'ip4addr)
+ "Return a class name for the address in (the given substring of) STR.
+
+ This ought to be an extension point for additional address families, but
+ it isn't at the moment."
+ (cond ((position #\: str :start start :end end) 'ip6addr)
+ (t 'ip4addr)))
(defgeneric parse-partial-ipaddr (class str &key start end min max)
+ (:documentation
+ "Parse (a substring of) STR into a partial address of the given CLASS.
+
+ Returns three values: the parsed address fragment, as an integer; and the
+ low and high bit positions covered by the response.
+
+ The CLASS may instead be an example object of the required class. The MIN
+ and MAX arguments bound the number of bits acceptable in the response; the
+ result is shifted so that the most significant component of the returned
+ address is in the same component as bit position MAX.")
(:method ((object t) str &rest keywords)
(apply #'parse-partial-ipaddr (extract-class-name object) str keywords)))
(export 'ipaddr-string)
(defgeneric ipaddr-string (ip)
- (:documentation
- "Transform the address IP into a string in dotted-quad form."))
+ (:documentation "Transform the address IP into a numeric textual form."))
(defmethod print-object ((addr ipaddr) stream)
- (print-unreadable-object (addr stream :type t)
- (write-string (ipaddr-string addr) stream)))
+ (if *print-escape*
+ (print-unreadable-object (addr stream :type t)
+ (write-string (ipaddr-string addr) stream))
+ (write-string (ipaddr-string addr) stream)))
(export 'ipaddrp)
(defun ipaddrp (ip)
"Given an integer I, return an N-bit netmask with its I top bits set."
(- (ash 1 n) (ash 1 (- n i))))
-(export 'ipmask-cidl-slash)
-(defun ipmask-cidl-slash (width mask)
+(export 'ipmask-cidr-slash)
+(defun ipmask-cidr-slash (width mask)
"Given a netmask MASK, try to compute a prefix length.
Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if
(let ((w (ipaddr-width addr)))
(if (<= 0 mask w)
(integer-netmask w mask)
- (error "Mask out of range.")))))
+ (error "Prefix length out of range.")))))
(export 'mask-ipaddr)
(defun mask-ipaddr (addr mask)
(export 'ipnet-family)
(defgeneric ipnet-family (ipn)
+ (:documentation "Return the address family of IPN, as a keyword.")
(:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn))))
(export 'ipnet-addr)
(export 'make-ipnet)
(defun make-ipnet (net mask)
- "Construct an IP-network object given the NET and MASK; these are
- transformed as though by `ipaddr' and `ipmask'."
+ "Construct an IP-network object given the NET and MASK.
+
+ These are transformed as though by `ipaddr' and `ipmask'."
(let* ((net (ipaddr net))
(mask (ipmask net mask)))
(ipaddr-ipnet (mask-ipaddr net mask) mask)))
(with-ipnet (net nil mask) ipn
(format nil "~A/~A"
(ipaddr-string net)
- (or (ipmask-cidl-slash (ipnet-width ipn) mask)
+ (or (ipmask-cidr-slash (ipnet-width ipn) mask)
(ipaddr-string (make-instance (class-of net) :addr mask))))))
(defmethod print-object ((ipn ipnet) stream)
- (print-unreadable-object (ipn stream :type t)
- (write-string (ipnet-string ipn) stream)))
+ (if *print-escape*
+ (print-unreadable-object (ipn stream :type t)
+ (write-string (ipnet-string ipn) stream))
+ (write-string (ipnet-string ipn) stream)))
+
+(defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
+ "Parse a subnet description from (a substring of) STR.
+
+ Suppose we have a parent network, with a prefix length of MAX. The WIDTH
+ gives the overall length of addresses of the appropriate class, i.e.,
+ (ipaddr-width WIDTH), but in fact callers have already computed this for
+ their own reasons.
+
+ Parse (the designated substring of) STR to construct the base address of a
+ subnet. The string should have the form BASE/MASK, where the MASK is
+ either a literal bitmask (in the usual syntax for addresses) or an integer
+ prefix length. An explicit prefix length is expected to cover the entire
+ address including the parent prefix: an error is signalled if the prefix
+ isn't long enough to cover any of the subnet. A mask is parsed relative
+ to the end of the parent address, just as the subnet base address is.
+
+ Returns the relative base address and mask as two integer values."
-(defun parse-subnet (class width max str &key (start 0) (end nil))
- "Parse a subnet description from a (substring of) STR."
(setf-default end (length str))
- (let ((sl (position #\/ str :start start :end end)))
+ (let ((sl (and slashp (position #\/ str :start start :end end))))
(multiple-value-bind (addr lo hi)
(parse-partial-ipaddr class str :max max
:start start :end (or sl end))
(error "Mask selects bits not present in base address"))
(values addr mask)))))
-(export 'ipnet-subnet)
-(defun ipnet-subnet (base-ipn sub-net sub-mask)
- "Construct a subnet of IPN, using the NET and MASK.
+(defun check-subipnet (base-ipn sub-addr sub-mask)
+ "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN.
- The NET must either be zero or agree with IPN at all positions indicated
- by their respective masks."
+ The BASE-IPN is an `ipnet'; SUB-ADDR and SUB-MASK are plain integers. If
+ the subnet is invalid (i.e., the subnet disagrees with its putative parent
+ over some of the fixed address bits) then an error is signalled; otherwise
+ return the combined base address (as an `ipaddr') and mask (as an
+ integer)."
(with-ipnet (base-net base-addr base-mask) base-ipn
- (let* ((sub-net (ipaddr sub-net (ipnet-net base-ipn)))
- (sub-addr (ipaddr-addr sub-net))
- (sub-mask (ipmask sub-net sub-mask))
- (common (logand base-mask sub-mask))
+ (let* ((common (logand base-mask sub-mask))
(base-overlap (logand base-addr common))
(sub-overlap (logand sub-addr common))
(full-mask (logior base-mask sub-mask)))
- (unless (or (zerop sub-overlap)
- (= sub-overlap base-overlap))
+ (unless (or (zerop sub-overlap) (= sub-overlap base-overlap))
(error "Subnet doesn't match base network"))
- (ipaddr-ipnet (integer-ipaddr (logand full-mask
- (logior base-addr sub-addr))
- base-net)
- full-mask))))
+ (values (integer-ipaddr (logand full-mask (logior base-addr sub-addr))
+ base-net)
+ full-mask))))
(export 'string-ipnet)
(defun string-ipnet (str &key (start 0) (end nil))
- "Parse an IP-network from the string STR."
+ "Parse an IP network description from the string STR.
+
+ A network description has the form ADDRESS/MASK, where the ADDRESS is a
+ base address in numeric form, and the MASK is either a netmask in the same
+ form, or an integer prefix length."
(setf str (stringify str))
(setf-default end (length str))
(let ((addr-class (guess-address-class str :start start :end end)))
(make-ipnet (make-instance addr-class :addr addr)
(make-instance addr-class :addr mask)))))
-(export 'string-subipnet)
-(defun string-subipnet (ipn str &key (start 0) (end nil))
- (setf str (stringify str))
+(defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t))
+ "Parse STR as a subnet of IPN.
+
+ This is mostly a convenience interface over `parse-subnet'; we compute
+ various of the parameters from IPN rather than requiring them to be passed
+ in explicitly.
+
+ Returns two values: the combined base address, as an `ipnaddr' and
+ combined mask, as an integer."
+
(let* ((addr-class (extract-class-name (ipnet-net ipn)))
(width (ipaddr-width addr-class))
(max (- width
- (or (ipmask-cidl-slash width (ipnet-mask ipn))
+ (or (ipmask-cidr-slash width (ipnet-mask ipn))
(error "Base network has complex netmask")))))
(multiple-value-bind (addr mask)
- (parse-subnet addr-class width max str :start start :end end)
- (ipnet-subnet ipn
- (make-instance addr-class :addr addr)
- (make-instance addr-class :addr mask)))))
+ (parse-subnet addr-class width max (stringify str)
+ :start start :end end :slashp slashp)
+ (check-subipnet ipn addr mask))))
+
+(export 'string-subipnet)
+(defun string-subipnet (ipn str &key (start 0) (end nil))
+ "Parse an IP subnet from a parent net IPN and a suffix string STR.
+
+ The (substring of) STR is expected to have the form ADDRESS/MASK, where
+ ADDRESS is a relative subnet base address, and MASK is either a relative
+ subnet mask or a (full) prefix length. Returns the resulting ipnet. If
+ the relative base address overlaps with the existing subnet (because the
+ base network's prefix length doesn't cover a whole number of components),
+ then the subnet base must either agree in the overlapping portion with the
+ parent base address or be zero.
+
+ For example, if IPN is the network 172.29.0.0/16, then `199/24' or
+ `199/255' both designate the subnet 172.29.199.0/24. Similarly, starting
+ from 2001:ba8:1d9:8000::/52, then `8042/ffff' and `42/64' both designate
+ the network 2001:ba8:1d9:8042::/64."
+
+ (multiple-value-bind (addr mask)
+ (parse-subipnet ipn str :start start :end end)
+ (ipaddr-ipnet addr mask)))
(defun ipnet (net)
"Construct an IP-network object from the given argument.
(defun ipnet-host (ipn host)
"Return the address of the given HOST in network IPN.
- This works even with a non-contiguous netmask."
- (ipnet-index-host (ipnet-host-map ipn) host))
+ The HOST may be a an integer index into the network (this works even with
+ a non-contiguous netmask) or a string or symbolic suffix (as for
+ `string-subnet')."
+ (etypecase host
+ (integer
+ (ipnet-index-host (ipnet-host-map ipn) host))
+ ((or symbol string)
+ (multiple-value-bind (addr mask)
+ (parse-subipnet ipn host :slashp nil)
+ (unless (= mask (mask (ipaddr-width addr)))
+ (error "Host address incomplete"))
+ addr))))
(export 'ipaddr-networkp)
(defun ipaddr-networkp (ip ipn)
(recurse highwidth highmask (+ offset lowwidth)))))))
(recurse width mask 0)))
+;;;--------------------------------------------------------------------------
+;;; Domain names.
+
+(export '(domain-name make-domain-name domain-name-p
+ domain-name-labels domain-name-absolutep))
+(defstruct domain-name
+ "A domain name, which is a list of labels.
+
+ The most significant (top-level) label is first, so they're in
+ right-to-left order.."
+ (labels nil :type list)
+ (absolutep nil :type boolean))
+
+(export 'quotify-label)
+(defun quotify-label (string)
+ "Quote an individual label STRING, using the RFC1035 rules.
+
+ A string which contains only printable characters other than `.', `@',
+ `\"', `\\', `;', `(' and `)' is returned as is. Other strings are
+ surrounded with quotes, and special characters (now only `\\', `\"' and
+ unprintable things) are escaped -- printable characters are preceded by
+ backslashes, and non-printable characters are represented as \\DDD decimal
+ codes."
+
+ (if (every (lambda (ch)
+ (and (<= 33 (char-code ch) 126)
+ (not (member ch '(#\. #\@ #\" #\\ #\; #\( #\))))))
+ string)
+ string
+ (with-output-to-string (out)
+ (write-char #\" out)
+ (dotimes (i (length string))
+ (let ((ch (char string i)))
+ (cond ((or (eql ch #\") (eql ch #\\))
+ (write-char #\\ out)
+ (write-char ch out))
+ ((<= 32 (char-code ch) 126)
+ (write-char ch out))
+ (t
+ (format out "\\~3,'0D" (char-code ch))))))
+ (write-char #\" out))))
+
+(defun unquotify-label (string &key (start 0) (end nil))
+ "Parse and unquote a label from the STRING.
+
+ Returns the parsed label, and the position of the next label."
+
+ (let* ((end (or end (length string)))
+ (i start)
+ (label (with-output-to-string (out)
+ (labels
+ ((numeric-escape-char ()
+ ;; We've just seen a `\', and the next character is
+ ;; a digit. Read the three-digit sequence, and
+ ;; return the appropriate character, or nil if the
+ ;; sequence was invalid.
+
+ (let* ((e (+ i 3))
+ (code
+ (and (<= e end)
+ (do ((j i (1+ j))
+ (a 0
+ (let ((d (digit-char-p
+ (char string j))))
+ (and a d (+ (* 10 a) d)))))
+ ((>= j e) a)))))
+ (unless (<= 0 code 255)
+ (error "Escape code out of range."))
+ (setf i e)
+ (and code (code-char code))))
+
+ (hack-backslash ()
+ ;; We've just seen a `\'. Read the next character
+ ;; and write it to the output stream.
+
+ (let ((ch (cond ((>= i end) nil)
+ ((not (digit-char-p
+ (char string i)))
+ (prog1 (char string i)
+ (incf i)))
+ (t (numeric-escape-char)))))
+ (unless ch
+ (error "Invalid escape in label."))
+ (write-char ch out)))
+
+ (munch (delim)
+ ;; Read characters until we reach an unescaped copy
+ ;; of DELIM, writing the unescaped versions to the
+ ;; output stream. Return nil if we hit the end, or
+ ;; the delimiter character.
+
+ (loop
+ (when (>= i end) (return nil))
+ (let ((ch (char string i)))
+ (incf i)
+ (cond ((char= ch #\\)
+ (hack-backslash))
+ ((char= ch delim)
+ (return ch))
+ (t
+ (write-char ch out)))))))
+
+ ;; If the label starts with a `"' then continue until we
+ ;; get to the next `"', which must either end the string,
+ ;; or be followed by a `.'. If the label isn't quoted,
+ ;; then munch until the `.'.
+ (cond
+ ((and (< i end) (char= (char string i) #\"))
+ (incf i)
+ (let ((delim (munch #\")))
+ (unless (and delim
+ (or (= i end)
+ (char= (prog1 (char string i)
+ (incf i))
+ #\.)))
+ (error "Invalid quoting in label."))))
+ (t
+ (munch #\.)))))))
+
+ ;; We're done. Phew!
+ (when (string= label "")
+ (error "Empty labels aren't allowed."))
+ (values label i)))
+
+(export 'parse-domain-name)
+(defun parse-domain-name (string &key (start 0) (end nil) absolutep)
+ "Parse (a substring of) STRING as a possibly-relative domain name.
+
+ If STRING doesn't end in an unquoted `.', then it's relative (to some
+ unspecified parent domain). The input may be the special symbol `@' to
+ refer to the parent itself, `.' to mean the root, or a sequence of labels
+ separated by `.'. The final name is returned as a `domain-name' object."
+
+ (let ((end (or end (length string)))
+ (i start))
+ (flet ((parse ()
+ ;; Parse a sequence of labels.
+
+ (let ((labels nil))
+ (loop
+ (unless (< i end) (return))
+ (multiple-value-bind (label j)
+ (unquotify-label string :start i :end end)
+ (push label labels)
+ (setf i j)))
+ (unless labels
+ (error "Empty domain names have special notations."))
+ (make-domain-name :labels labels :absolutep absolutep))))
+
+ (cond ((= (1+ i) end)
+ ;; A single-character name. Check for the magic things;
+ ;; otherwise I guess it must just be short.
+
+ (case (char string i)
+ (#\@ (make-domain-name :labels nil :absolutep nil))
+ (#\. (make-domain-name :labels nil :absolutep t))
+ (t (parse))))
+
+ (t
+ ;; Something more complicated. If the name ends with `.', but
+ ;; not `\\.', then it must be absolute.
+ (when (and (< i end)
+ (char= (char string (- end 1)) #\.)
+ (char/= (char string (- end 2)) #\\))
+ (decf end)
+ (setf absolutep t))
+ (parse))))))
+
+(defmethod print-object ((name domain-name) stream)
+ "Print a domain NAME to a STREAM, using RFC1035 quoting rules."
+ (let ((labels (mapcar #'quotify-label
+ (reverse (domain-name-labels name)))))
+ (cond (*print-escape*
+ (print-unreadable-object (name stream :type t)
+ (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~@[.~]~]"
+ labels (domain-name-absolutep name))))
+ (t
+ (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~]"
+ labels (domain-name-absolutep name))))))
+
+(export 'domain-name-concat)
+(defun domain-name-concat (left right)
+ "Concatenate the LEFT and RIGHT names."
+ (if (domain-name-absolutep left)
+ left
+ (make-domain-name :labels (append (domain-name-labels right)
+ (domain-name-labels left))
+ :absolutep (domain-name-absolutep right))))
+
+(export 'domain-name<)
+(defun domain-name< (name-a name-b)
+ "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
+
+ Split the names into labels, and then lexicographically compare the
+ sequences of labels, right to left, using `natural-string<'.
+
+ Returns two values: whether NAME-A strictly precedes NAME-B, and whether
+ NAME-A strictly follows NAME-B.
+
+ This doesn't give useful answers on relative domains unless you know what
+ you're doing."
+
+ (let ((labels-a (domain-name-labels name-a))
+ (labels-b (domain-name-labels name-b)))
+ (loop (cond ((null labels-a)
+ (return (values (not (null labels-b)) (null labels-b))))
+ ((null labels-b)
+ (return (values nil t)))
+ (t
+ (multiple-value-bind (precp follp)
+ (natural-string< (pop labels-a) (pop labels-b))
+ (cond (precp (return (values t nil)))
+ (follp (return (values nil t))))))))))
+
+(export 'root-domain)
+(defparameter root-domain (make-domain-name :labels nil :absolutep t)
+ "The root domain, as a convenient object.")
+
;;;--------------------------------------------------------------------------
;;; Reverse lookups.
IPADDR between bits START (inclusive) and END (exclusive). Address
components which are only partially within the given bounds are included
unless PARTIALP is nil.")
+
(:method ((ipaddr ipaddr) start end &key (partialp t))
(let ((addr (ipaddr-addr ipaddr))
(comp-width (reverse-domain-component-width ipaddr))
(radix (reverse-domain-radix ipaddr)))
- (with-output-to-string (out)
- (do ((i (funcall (if partialp #'round-down #'round-up)
- start comp-width)
- (+ i comp-width))
- (limit (funcall (if partialp #'round-up #'round-down)
- end comp-width))
- (sep nil t))
- ((>= i limit))
- (format out "~:[~;.~]~(~vR~)"
- sep radix (ldb (byte comp-width i) addr)))))))
+ (do ((i (funcall (if partialp #'round-down #'round-up)
+ start comp-width)
+ (+ i comp-width))
+ (limit (funcall (if partialp #'round-up #'round-down)
+ end comp-width))
+ (comps nil (cons (format nil "~(~vR~)" radix
+ (ldb (byte comp-width i) addr))
+ comps)))
+ ((>= i limit) (make-domain-name :labels comps))))))
(export 'reverse-domain)
(defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
If PREFIX-LEN is nil then it defaults to the length of the network's fixed
prefix.")
+
(:method ((ipn ipnet) &optional prefix-len)
(let* ((addr (ipnet-net ipn))
(mask (ipnet-mask ipn))
(width (ipaddr-width addr)))
- (concatenate 'string
- (reverse-domain-fragment
- addr
- (if prefix-len
- (- width prefix-len)
- (ipnet-changeable-bits width mask))
- width
- :partialp nil)
- "."
- (reverse-domain-suffix addr))))
+ (domain-name-concat (reverse-domain-fragment
+ addr
+ (if prefix-len
+ (- width prefix-len)
+ (ipnet-changeable-bits width mask))
+ width
+ :partialp nil)
+ (reverse-domain-suffix addr))))
+
(:method ((addr ipaddr) &optional prefix-len)
(let* ((width (ipaddr-width addr)))
- (reverse-domain (make-ipnet addr (mask width))
+ (reverse-domain (make-ipnet addr width)
(or prefix-len width)))))
;;;--------------------------------------------------------------------------
(process-net-form name net subnets))
',name))
+(defun filter-by-family (func form family)
+ "Handle a family-switch form.
+
+ Here, FUNC is a function of two arguments ITEM and FAMILY. FORM is either
+ a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly
+ acceptable to FUNC. Return a list of the resulting outputs of FUNC."
+
+ (if (and (listp form)
+ (every (lambda (clause)
+ (and (listp clause)
+ (family-addrclass (car clause))))
+ form))
+ (mapcan (lambda (clause)
+ (let ((fam (car clause)))
+ (and (or (eq family t)
+ (eq family fam))
+ (list (funcall func (cdr clause) fam)))))
+ form)
+ (list (funcall func form family))))
+
(export 'net-parse-to-ipnets)
(defun net-parse-to-ipnets (form &optional (family t))
+ "Parse FORM into a list of ipnet objects.
+
+ The FORM can be any of the following.
+
+ * NAME -- a named network, established using `net-create' or `defnet'
+
+ * IPNET -- a network, in a form acceptable to `ipnet'
+
+ * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY"
+
(flet ((hack (form family)
(let* ((form (if (and (consp form)
(endp (cdr form)))
(remove family ipns
:key #'ipnet-family
:test-not #'eq)))))
- (let* ((ipns (if (and (listp form)
- (every (lambda (clause)
- (and (listp clause)
- (symbolp (car clause))
- (or (eq (car clause) t)
- (family-addrclass
- (car clause)))))
- form))
- (mappend (lambda (clause)
- (hack (cdr clause) (car clause)))
- form)
- (hack form family)))
+ (let* ((ipns (apply #'append (filter-by-family #'hack form family)))
(merged (reduce (lambda (ipns ipn)
(if (find (ipnet-family ipn) ipns
:key #'ipnet-family)
(cons ipn ipns)))
ipns
:initial-value nil)))
- (or merged (error "No matching addresses.")))))
+ (or merged
+ (error "No addresses match ~S~:[ in family ~S~;~*~]."
+ form (eq family t) family)))))
(export 'net-host)
(defun net-host (net-form host &optional (family t))
"Return the given HOST on the NET, as an anonymous `host' object.
- HOST may be an index (in range, of course), or one of the keywords:
+ HOST may be an index (in range, of course), a suffix (as a symbol or
+ string, as for `string-subnet'), or one of the keywords:
:next next host, as by net-next-host
:net network base address
otherwise return all available addresses."
(flet ((hosts (ipns host)
(mapcar (lambda (ipn) (ipnet-host ipn host))
- (remove host ipns :key #'ipnet-hosts :test-not #'<))))
+ (if (integerp host)
+ (remove host ipns :key #'ipnet-hosts :test #'>=)
+ ipns))))
(let* ((net (and (typep net-form '(or string symbol))
(net-find net-form)))
(ipns (net-parse-to-ipnets net-form family))
(net-host (car form) (cadr form) family))
(t
(filter-addresses (list (ipaddr indic)) family))))))
- (let ((host (cond
- ((not (eq family t))
- (hack addr family))
- ((and (listp addr)
- (every (lambda (clause)
- (and (listp clause)
- (symbolp (car clause))
- (or (eq (car clause) t)
- (family-addrclass (car clause)))))
- addr))
- (make-instance 'host
- :addrs (reduce #'merge-addresses
- (mapcar
- (lambda (clause)
- (host-addrs
- (hack (cdr clause)
- (car clause))))
- (reverse addr))
- :initial-value nil)))
- (t
- (hack addr t)))))
+ (let* ((list (filter-by-family #'hack addr family))
+ (host (if (and list (cdr list))
+ (make-instance 'host
+ :addrs (reduce #'merge-addresses
+ (mapcar #'host-addrs
+ (reverse list))
+ :initial-value nil))
+ (car list))))
(unless (host-addrs host)
- (error "No matching addresses."))
+ (error "No addresses match ~S~:[ in family ~S~;~*~]."
+ addr (eq family t) family))
host)))
(export 'host-create)
~mdw / zone / blobdiff