zone.lisp: For BIND output, omit record names where possible.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 2228c07..b9c8fa1 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -286,6 +286,37 @@
            (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)))))))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Serial numbering.
 
@@ -986,20 +1017,33 @@
 ;;;--------------------------------------------------------------------------
 ;;; Bind format output.
 
+(defvar *bind-last-record-name* nil
+  "The previously emitted record name.
+
+   Used for eliding record names on output.")
+
 (export 'bind-hostname)
 (defun bind-hostname (hostname)
-  (if (not hostname)
-      "@"
-      (let* ((h (string-downcase (stringify hostname)))
-            (hl (length h))
-            (r (string-downcase (zone-name *writing-zone*)))
-            (rl (length r)))
-       (cond ((string= r h) "@")
-             ((and (> hl rl)
-                   (char= (char h (- hl rl 1)) #\.)
-                   (string= h r :start1 (- hl rl)))
-              (subseq h 0 (- hl rl 1)))
-             (t (concatenate 'string h "."))))))
+  (let* ((h (string-downcase (stringify hostname)))
+        (hl (length h))
+        (r (string-downcase (zone-name *writing-zone*)))
+        (rl (length r)))
+    (cond ((string= r h) "@")
+         ((and (> hl rl)
+               (char= (char h (- hl rl 1)) #\.)
+               (string= h r :start1 (- hl rl)))
+          (subseq h 0 (- hl rl 1)))
+         (t (concatenate 'string h ".")))))
+
+(export 'bind-output-hostname)
+(defun bind-output-hostname (hostname)
+  (let ((name (bind-hostname hostname)))
+    (cond ((and *bind-last-record-name*
+               (string= name *bind-last-record-name*))
+          "")
+         (t
+          (setf *bind-last-record-name* name)
+          name))))
 
 (export 'bind-record)
 (defgeneric bind-record (type zr))
@@ -1014,7 +1058,8 @@ $TTL ~2@*~D~2%"
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))
-  (let* ((soa (zone-soa zone))
+  (let* ((*bind-last-record-name* nil)
+        (soa (zone-soa zone))
         (admin (let* ((name (soa-admin soa))
                       (at (position #\@ name))
                       (copy (format nil "~(~A~)." name)))
@@ -1029,22 +1074,22 @@ $TTL ~2@*~D~2%"
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"
-             (bind-hostname (zone-name zone))
+             (bind-output-hostname (zone-name zone))
              (bind-hostname (soa-source soa))
              admin
              (soa-serial soa)
              (soa-refresh soa)
              (soa-retry soa)
              (soa-expire soa)
-             (soa-min-ttl soa)))
-  (dolist (zr (zone-records zone))
-    (bind-record (zr-type zr) zr)))
+             (soa-min-ttl soa))
+      (dolist (zr (zone-records-sorted zone))
+       (bind-record (zr-type zr) zr))))
 
 (export 'bind-format-record)
 (defun bind-format-record (name ttl type format args)
   (format *zone-output-stream*
          "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
-         (bind-hostname name)
+         (bind-output-hostname name)
          (and (/= ttl (zone-default-ttl *writing-zone*))
               ttl)
          (string-upcase (symbol-name type))
@@ -1163,7 +1208,7 @@ $TTL ~2@*~D~2%"
                    (soa-expire soa)
                    (soa-min-ttl soa)
                    (zone-default-ttl zone)))
-  (dolist (zr (zone-records zone))
+  (dolist (zr (zone-records-sorted zone))
     (tinydns-record (zr-type zr) zr)))
 
 ;;;----- That's all, folks --------------------------------------------------