X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/e97012de8f47dd6ae68e288b4e983731a3b96b13..80b5c2ffcd36eb88b6b8f87dc711cf93ebfc27d9:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 2228c07..b9c8fa1 100644
--- 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 --------------------------------------------------