X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/8bd2576ecb4dc8c7ba9d917021d923af40320b5e..f4decf40ece4ec98a4a6531a28f9fec84f99a0ca:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index be6a16e..611a6ac 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -39,6 +39,8 @@ (defpackage #:zone
 	   #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
 	   #:defrevzone #:zone-save #:zone-make-name
 	   #:defzoneparse #:zone-parse-host
+	   #:bind-hostname #:bind-record #:bind-format-record
+	   #:bind-record-type #:bind-record-format-args
 	   #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)
@@ -377,46 +379,6 @@ (defun zone-cidr-delg-default-name (ipn bytes)
 		      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)))))))
-
 ;;;--------------------------------------------------------------------------
 ;;; Serial numbering.
 
@@ -536,6 +498,7 @@ 	   (defun ,func (,prefix ,zname ,data ,ttl ,col)
 				   ((:data ,tdata) ,data)
 				   ((:ttl ,tttl) ,ttl)
 				   ((:make-ptr-p ,tmakeptrp) nil))
+			#+cmu (declare (optimize ext:inhibit-warnings))
 			(collect (make-zone-record :name ,tname
 						   :type ,ttype
 						   :data ,tdata
@@ -738,34 +701,53 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec)
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
-(defun zone-write (zone &optional (stream *standard-output*))
-  "Write a ZONE's records to STREAM."
-  (labels ((fix-admin (a)
-	     (let ((at (position #\@ a))
-		   (s (concatenate 'string (string-downcase a) ".")))
-	       (when s
-		 (setf (char s at) #\.))
-	       s))
-	   (fix-host (h)
-	     (if (not h)
-		 "@"
-		 (let* ((h (string-downcase (stringify h)))
-			(hl (length h))
-			(r (string-downcase (zone-name 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 "."))))))
-	   (printrec (zr)
-	     (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
-		     (fix-host (zr-name zr))
-		     (and (/= (zr-ttl zr) (zone-default-ttl zone))
-			  (zr-ttl zr))
-		     (string-upcase (symbol-name (zr-type zr))))))
-    (format stream "~
+(defgeneric zone-write (format zone stream)
+  (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
+
+(defvar *writing-zone* nil
+  "The zone currently being written.")
+
+(defvar *zone-output-stream* nil
+  "Stream to write zone data on.")
+
+(defmethod zone-write :around (format zone stream)
+  (let ((*writing-zone* zone)
+	(*zone-output-stream* stream))
+    (call-next-method)))
+
+(defun zone-save (zones &key (format :bind))
+  "Write the named ZONES to files.  If no zones are given, write all the
+   zones."
+  (unless zones
+    (setf zones (hash-table-keys *zones*)))
+  (safely (safe)
+    (dolist (z zones)
+      (let ((zz (zone-find z)))
+	(unless zz
+	  (error "Unknown zone `~A'." z))
+	(let ((stream (safely-open-output-stream safe
+						 (zone-file-name z :zone))))
+	  (zone-write format zz stream))))))
+
+;;;--------------------------------------------------------------------------
+;;; Bind format output.
+
+(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 "."))))))
+
+(defmethod zone-write ((format (eql :bind)) zone stream)
+  (format stream "~
 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 
@@ -774,7 +756,13 @@ (defun zone-write (zone &optional (stream *standard-output*))
 	    (zone-name zone)
 	    (iso-date :now :datep t :timep t)
 	    (zone-default-ttl zone))
-    (let ((soa (zone-soa zone)))
+  (let* ((soa (zone-soa zone))
+	 (admin (let* ((name (soa-admin soa))
+		       (at (position #\@ name))
+		       (copy (format nil "~(~A~)." name)))
+		  (when at
+		    (setf (char copy at) #\.))
+		  copy)))
       (format stream "~
 ~A~30TIN SOA~40T~A ~A (
 ~45T~10D~60T ;serial
@@ -782,42 +770,46 @@ (defun zone-write (zone &optional (stream *standard-output*))
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"
-	      (fix-host (zone-name zone))
-	      (fix-host (soa-source soa))
-	      (fix-admin (soa-admin soa))
+	      (bind-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))
-      (ecase (zr-type zr)
-	(:a
-	 (printrec zr)
-	 (format stream "~A~%" (ipaddr-string (zr-data zr))))
-	((:ptr :cname :ns)
-	 (printrec zr)
-	 (format stream "~A~%" (fix-host (zr-data zr))))
-	(:mx
-	 (printrec zr)
-	 (let ((mx (zr-data zr)))
-	   (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
-	(:txt
-	 (printrec zr)
-	 (format stream "~S~%" (stringify (zr-data zr))))))))
-
-(defun zone-save (zones)
-  "Write the named ZONES to files.  If no zones are given, write all the
-   zones."
-  (unless zones
-    (setf zones (hash-table-keys *zones*)))
-  (safely (safe)
-    (dolist (z zones)
-      (let ((zz (zone-find z)))
-	(unless zz
-	  (error "Unknown zone `~A'." z))
-	(let ((stream (safely-open-output-stream safe
-						 (zone-file-name z :zone))))
-	  (zone-write zz stream))))))
+  (dolist (zr (zone-records zone))
+    (bind-record (zr-type zr) zr)))
+
+(defgeneric bind-record (type zr))
+
+(defun bind-format-record (name ttl type format args)
+  (format *zone-output-stream*
+	  "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
+	  (bind-hostname name)
+	  (and (/= ttl (zone-default-ttl *writing-zone*))
+	       ttl)
+	  (string-upcase (symbol-name type))
+	  format args))
+
+(defmethod bind-record (type zr)
+  (destructuring-bind (format &rest args)
+      (bind-record-format-args type (zr-data zr))
+    (bind-format-record (zr-name zr)
+			(zr-ttl zr)
+			(bind-record-type type)
+			format args)))
+
+(defgeneric bind-record-type (type)
+  (:method (type) type))
+
+(defgeneric bind-record-format-args (type data)
+  (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
+  (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :mx)) data)
+    (list "~2D ~A" (cdr data) (bind-hostname (car data))))
+  (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
 
 ;;;----- That's all, folks --------------------------------------------------