+;;; Zone variables and structures.
+
+(defvar *zones* (make-hash-table :test #'equal)
+ "Map of known zones.")
+
+(export 'zone-find)
+(defun zone-find (name)
+ "Find a zone given its NAME."
+ (gethash (string-downcase (stringify name)) *zones*))
+(defun (setf zone-find) (zone name)
+ "Make the zone NAME map to ZONE."
+ (setf (gethash (string-downcase (stringify name)) *zones*) zone))
+
+(export 'zone-record)
+(defstruct (zone-record (:conc-name zr-))
+ "A zone record."
+ (name '<unnamed>)
+ ttl
+ type
+ (make-ptr-p nil)
+ data)
+
+(export 'zone-subdomain)
+(defstruct (zone-subdomain (:conc-name zs-))
+ "A subdomain.
+
+ Slightly weird. Used internally by `zone-process-records', and shouldn't
+ escape."
+ name
+ ttl
+ records)
+
+(export '*zone-output-path*)
+(defvar *zone-output-path* nil
+ "Pathname defaults to merge into output files.
+
+ If this is nil then use the prevailing `*default-pathname-defaults*'.
+ This is not the same as capturing the `*default-pathname-defaults*' from
+ load time.")
+
+(export '*preferred-subnets*)
+(defvar *preferred-subnets* nil
+ "Subnets to prefer when selecting defaults.")
+
+;;;--------------------------------------------------------------------------
+;;; Zone infrastructure.
+
+(defun zone-file-name (zone type)
+ "Choose a file name for a given ZONE and TYPE."
+ (merge-pathnames (make-pathname :name (string-downcase zone)
+ :type (string-downcase type))
+ (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 (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))))))
+
+(export 'zone-make-name)
+(defun zone-make-name (prefix zone-name)
+ "Compute a full domain name from a PREFIX and a ZONE-NAME.
+
+ If the PREFIX ends with `.' then it's absolute already; otherwise, append
+ the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then
+ return the ZONE-NAME only."
+ (if (or (not prefix) (string= prefix "@"))
+ zone-name
+ (let ((len (length prefix)))
+ (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
+ (join-strings #\. (list prefix zone-name))
+ prefix))))
+
+(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)
+ (let* ((name-a (zr-name zr-a)) (pos-a (length name-a))
+ (name-b (zr-name zr-b)) (pos-b (length name-b)))
+ (loop (let ((dot-a (or (position #\. name-a
+ :from-end t :end pos-a)
+ -1))
+ (dot-b (or (position #\. name-b
+ :from-end t :end pos-b)
+ -1)))
+ (cond ((string< name-a name-b
+ :start1 (1+ dot-a) :end1 pos-a
+ :start2 (1+ dot-b) :end2 pos-b)
+ (return t))
+ ((string> name-a name-b
+ :start1 (1+ dot-a) :end1 pos-a
+ :start2 (1+ dot-b) :end2 pos-b)
+ (return nil))
+ ((= dot-a dot-b -1)
+ (return (string< (zr-type zr-a) (zr-type zr-b))))
+ ((= dot-a -1)
+ (return t))
+ ((= dot-b -1)
+ (return nil))
+ (t
+ (setf pos-a dot-a)
+ (setf pos-b dot-b)))))))))
+
+;;;--------------------------------------------------------------------------