X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/eebb70af6da9dff795108a04520523437c6a14f9..1a339c77202274463e6150bea957ddf53b800815:/net.lisp

diff --git a/net.lisp b/net.lisp
index 1750da0..85faede 100644
--- a/net.lisp
+++ b/net.lisp
@@ -315,10 +315,10 @@
   (print-unreadable-object (ipn stream :type t)
     (write-string (ipnet-string ipn) stream)))
 
-(defun parse-subnet (class width max str &key (start 0) (end nil))
+(defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
   "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))
@@ -339,27 +339,24 @@
 	  (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))
@@ -374,19 +371,26 @@
       (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'."
   (let* ((addr-class (extract-class-name (ipnet-net ipn)))
 	 (width (ipaddr-width addr-class))
 	 (max (- width
 		 (or (ipmask-cidl-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."
+  (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.
@@ -492,8 +496,18 @@
 (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)
@@ -762,6 +776,26 @@
 	       (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))
   (flet ((hack (form family)
@@ -776,18 +810,7 @@
 		 (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)
@@ -801,7 +824,8 @@
 (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
@@ -811,7 +835,9 @@
    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))
@@ -900,27 +926,14 @@
 		      (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."))
       host)))