zone: Change default subnet selection.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 74ecf58..0e579dc 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -34,6 +34,7 @@
             #:*default-zone-min-ttl* #:*default-zone-ttl*
             #:*default-mx-priority* #:*default-zone-admin*
           #:*zone-output-path*
+          #:*preferred-subnets* #:zone-preferred-subnet-p
           #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
           #:defrevzone #:zone-save #:zone-make-name
           #:defzoneparse #:zone-parse-host
@@ -213,6 +214,9 @@
 (defvar *zone-output-path* *default-pathname-defaults*
   "Pathname defaults to merge into output files.")
 
+(defvar *preferred-subnets* nil
+  "Subnets to prefer when selecting defaults.")
+
 ;;;--------------------------------------------------------------------------
 ;;; Zone infrastructure.
 
@@ -222,6 +226,10 @@
                                  :type (string-downcase type))
                   *zone-output-path*))
 
+(defun zone-preferred-subnet-p (name)
+  "Answer whether NAME (a string or symbol) names a preferred subnet."
+  (member name *preferred-subnets* :test #'string-equal))
+
 (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."
@@ -249,19 +257,23 @@
           (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))))
+                  (let ((preferred nil))
+                    (dolist (s sub)
+                      (when (some #'zone-preferred-subnet-p
+                                  (listify (zs-name s)))
+                        (setf preferred s)))
+                    (unless preferred
+                      (setf preferred (car sub)))
+                    (when preferred
+                      (process (zs-records preferred)
+                               dom
+                               (zs-ttl preferred))))
+                  (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)