- *zone-output-path*))
-
-(defun zone-process-records (rec ttl func)
- "Sort out the list of records in REC, calling FUNC for each one. TTL is
- the default time-to-live for records which don't specify one."
- (labels ((sift (rec ttl)
- (collecting (top sub)
- (loop
- (unless rec
- (return))
- (let ((r (pop rec)))
- (cond ((eq r :ttl)
- (setf ttl (pop rec)))
- ((symbolp r)
- (collect (make-zone-record :type r
- :ttl ttl
- :data (pop rec))
- top))
- ((listp r)
- (dolist (name (listify (car r)))
- (collect (make-zone-subdomain :name name
- :ttl ttl
- :records (cdr r))
- sub)))
- (t
- (error "Unexpected record form ~A" (car r))))))))
- (process (rec dom ttl)
- (multiple-value-bind (top sub) (sift rec ttl)
- (if (and dom (null top) sub)
- (let ((s (pop sub)))
- (process (zs-records s)
- dom
- (zs-ttl s))
- (process (zs-records s)
- (cons (zs-name s) dom)
- (zs-ttl s)))
- (let ((name (and dom
- (string-downcase
- (join-strings #\. (reverse dom))))))
- (dolist (zr top)
- (setf (zr-name zr) name)
- (funcall func zr))))
- (dolist (s sub)
- (process (zs-records s)
- (cons (zs-name s) dom)
- (zs-ttl s))))))
- (process rec nil ttl)))
-
-(defun zone-parse-host (f zname)
- "Parse a host name F: if F ends in a dot then it's considered absolute;
- otherwise it's relative to ZNAME."
- (setf f (stringify f))
- (cond ((string= f "@") (stringify zname))
- ((and (plusp (length f))
- (char= (char f (1- (length f))) #\.))
- (string-downcase (subseq f 0 (1- (length f)))))
- (t (string-downcase (concatenate 'string f "."
- (stringify zname))))))
-(defun default-rev-zone (base bytes)
- "Return the default reverse-zone name for the given BASE address and number
- of fixed leading BYTES."
- (join-strings #\. (collecting ()
- (loop for i from (- 3 bytes) downto 0
- do (collect (ipaddr-byte base i)))
- (collect "in-addr.arpa"))))
-
-(defun zone-name-from-net (net &optional bytes)
- "Given a NET, and maybe the BYTES to use, convert to the appropriate
- subdomain of in-addr.arpa."
- (let ((ipn (net-get-as-ipnet net)))
- (with-ipnet (net mask) ipn
- (unless bytes
- (setf bytes (- 4 (ipnet-changeable-bytes mask))))
- (join-strings #\.
- (append (loop
- for i from (- 4 bytes) below 4
- collect (logand #xff (ash net (* -8 i))))
- (list "in-addr.arpa"))))))
-
-(defun zone-net-from-name (name)
- "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
- (let* ((name (string-downcase (stringify name)))
- (len (length name))
- (suffix ".in-addr.arpa")
- (sufflen (length suffix))
- (addr 0)
- (n 0)
- (end (- len sufflen)))
- (unless (and (> len sufflen)
- (string= name suffix :start1 end))
- (error "`~A' not in ~A." name suffix))
- (loop
- with start = 0
- for dot = (position #\. name :start start :end end)
- for byte = (parse-integer name
- :start start
- :end (or dot end))
- do (setf addr (logior addr (ash byte (* 8 n))))
- (incf n)
- when (>= n 4)
- do (error "Can't deduce network from ~A." name)
- while dot
- do (setf start (1+ dot)))
- (setf addr (ash addr (* 8 (- 4 n))))
- (make-ipnet addr (* 8 n))))
-
-(defun zone-parse-net (net name)
- "Given a NET, and the NAME of a domain to guess from if NET is null, return
- the ipnet for the network."
- (if net
- (net-get-as-ipnet net)
- (zone-net-from-name name)))
-
-(defun zone-cidr-delg-default-name (ipn bytes)
- "Given a delegated net IPN and the parent's number of changing BYTES,
- return the default deletate zone prefix."
- (with-ipnet (net mask) ipn
- (join-strings #\.
- (reverse
- (loop
- for i from (1- bytes) downto 0
- until (zerop (logand mask (ash #xff (* 8 i))))
- collect (logand #xff (ash net (* -8 i))))))))
-
-(defun zone-cidr-delegation (data name ttl list)
- "Given :cidr-delegation info DATA, for a record called NAME and the current
- TTL, write lots of CNAME records to LIST."
- (destructuring-bind
- (net &key bytes)
- (listify (car data))
- (setf net (zone-parse-net net name))
- (unless bytes
- (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
- (dolist (map (cdr data))
- (destructuring-bind
- (tnet &optional tdom)
- (listify map)
- (setf tnet (zone-parse-net tnet name))
- (unless (ipnet-subnetp net tnet)
- (error "~A is not a subnet of ~A."
- (ipnet-pretty tnet)
- (ipnet-pretty net)))
- (unless tdom
- (setf tdom
- (join-strings #\.
- (list (zone-cidr-delg-default-name tnet bytes)
- name))))
- (setf tdom (string-downcase tdom))
- (dotimes (i (ipnet-hosts tnet))
- (let* ((addr (ipnet-host tnet i))
- (tail (join-strings #\.
- (loop
- for i from 0 below bytes
- collect
- (logand #xff
- (ash addr (* 8 i)))))))
- (collect (make-zone-record
- :name (join-strings #\.
- (list tail name))
- :type :cname
- :ttl ttl
- :data (join-strings #\. (list tail tdom)))
- list)))))))
+ (or *zone-output-path* *default-pathname-defaults*)))
+
+(export 'zone-preferred-subnet-p)
+(defun zone-preferred-subnet-p (name)
+ "Answer whether NAME (a string or symbol) names a preferred subnet."
+ (member name *preferred-subnets* :test #'string-equal))
+
+(export 'preferred-subnet-case)
+(defmacro preferred-subnet-case (&body clauses)
+ "Execute a form based on which networks are considered preferred.
+
+ The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
+ whose SUBNETS (a list or single symbol, not evaluated) are listed in
+ `*preferred-subnets*'. If SUBNETS is the symbol `t' then the clause
+ always matches."
+ `(cond
+ ,@(mapcar (lambda (clause)
+ (let ((subnets (car clause)))
+ (cons (cond ((eq subnets t)
+ t)
+ ((listp subnets)
+ `(or ,@(mapcar (lambda (subnet)
+ `(zone-preferred-subnet-p
+ ',subnet))
+ subnets)))
+ (t
+ `(zone-preferred-subnet-p ',subnets)))
+ (cdr clause))))
+ clauses)))
+
+(export 'zone-parse-host)
+(defun zone-parse-host (form &optional tail)
+ "Parse a host name FORM from a value in a zone form.
+
+ The underlying parsing is done using `parse-domain-name'. Here, we
+ interpret various kinds of Lisp object specially. In particular: `nil'
+ refers to the TAIL zone (just like a plain `@'); and a symbol is downcased
+ before use."
+ (let ((name (etypecase form
+ (null (make-domain-name :labels nil :absolutep nil))
+ (domain-name form)
+ (symbol (parse-domain-name (string-downcase form)))
+ (string (parse-domain-name form)))))
+ (if (null tail) name
+ (domain-name-concat name tail))))
+
+(export 'zone-records-sorted)
+(defun zone-records-sorted (zone)
+ "Return the ZONE's records, in a pleasant sorted order."
+ (sort (copy-seq (zone-records zone))
+ (lambda (zr-a zr-b)
+ (multiple-value-bind (precp follp)
+ (domain-name< (zr-name zr-a) (zr-name zr-b))
+ (cond (precp t)
+ (follp nil)
+ (t (string< (zr-type zr-a) (zr-type zr-b))))))))