X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/4e7e3780c0f92094c6def85910e14901b9e1070f..590ad96179e11b59ae83bac2072a89ba1d529212:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index f3d85d0..74ecf58 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -35,7 +35,7 @@
 	     #:*default-mx-priority* #:*default-zone-admin*
 	   #:*zone-output-path*
 	   #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
-	   #:defrevzone #:zone-save
+	   #:defrevzone #:zone-save #:zone-make-name
 	   #:defzoneparse #:zone-parse-host
 	   #:timespec-seconds #:make-zone-serial))
 
@@ -200,6 +200,7 @@
   (name '<unnamed>)
   ttl
   type
+  (make-ptr-p nil)
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
@@ -446,8 +447,17 @@
 		      :min-ttl (timespec-seconds min-ttl)
 		      :serial serial))))
 
+(defun zone-make-name (prefix zone-name)
+  (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))))
+
 (defmacro defzoneparse (types (name data list
-			       &key (zname (gensym "ZNAME"))
+			       &key (prefix (gensym "PREFIX"))
+			            (zname (gensym "ZNAME"))
 			            (ttl (gensym "TTL")))
 			&body body)
   "Define a new zone record type (or TYPES -- a list of synonyms is
@@ -460,43 +470,47 @@
 
    LIST		A function to add a record to the zone.  See below.
 
+   PREFIX	The prefix tag used in the original form.
+
    ZNAME	The name of the zone being constructed.
 
    TTL		The TTL for this record.
 
-   You get to choose your own names for these.  ZNAME and TTL are optional:
-   you don't have to accept them if you're not interested.
+   You get to choose your own names for these.  ZNAME, PREFIX and TTL are
+   optional: you don't have to accept them if you're not interested.
 
    The LIST argument names a function to be bound in the body to add a new
    low-level record to the zone.  It has the prototype
 
-     (LIST &key :name :type :data :ttl)
+     (LIST &key :name :type :data :ttl :make-ptr-p)
 
-   These default to the above arguments (even if you didn't accept the
-   arguments)."
+   These (except MAKE-PTR-P, which defaults to nil) default to the above
+   arguments (even if you didn't accept the arguments)."
   (setf types (listify types))
   (let* ((type (car types))
 	 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
     (with-parsed-body (body decls doc) body
-      (with-gensyms (col tname ttype tttl tdata i)
+      (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 	`(progn
 	   (dolist (,i ',types)
 	     (setf (get ,i 'zone-parse) ',func))
-	   (defun ,func (,name ,data ,ttl ,col ,zname)
+	   (defun ,func (,prefix ,zname ,data ,ttl ,col)
 	     ,@doc
 	     ,@decls
-	     (declare (ignorable ,zname))
-	     (flet ((,list (&key ((:name ,tname) ,name)
-				 ((:type ,ttype) ,type)
-				 ((:data ,tdata) ,data)
-				 ((:ttl ,tttl) ,ttl))
-		      (collect (make-zone-record :name ,tname
-						 :type ,ttype
-						 :data ,tdata
-						 :ttl ,tttl)
-			       ,col)))
-	       ,@body))
-	   ',type)))))
+	     (let ((,name (zone-make-name ,prefix ,zname)))
+	       (flet ((,list (&key ((:name ,tname) ,name)
+				   ((:type ,ttype) ,type)
+				   ((:data ,tdata) ,data)
+				   ((:ttl ,tttl) ,ttl)
+				   ((:make-ptr-p ,tmakeptrp) nil))
+			(collect (make-zone-record :name ,tname
+						   :type ,ttype
+						   :data ,tdata
+						   :ttl ,tttl
+						   :make-ptr-p ,tmakeptrp)
+				 ,col)))
+		 ,@body)))
+	  ',type)))))
 
 (defun zone-parse-records (zone records)
   (let ((zname (zone-name zone)))
@@ -505,22 +519,13 @@
 		 (let ((func (or (get (zr-type zr) 'zone-parse)
 				 (error "No parser for record ~A."
 					(zr-type zr))))
-		       (name (and (zr-name zr)
-				  (stringify (zr-name zr)))))
-		   (if (or (not name)
-			   (string= name "@"))
-		       (setf name zname)
-		       (let ((len (length name)))
-			 (if (or (zerop len)
-				 (char/= (char name (1- len)) #\.))
-			     (setf name (join-strings #\.
-						      (list name zname))))))
+		       (name (and (zr-name zr) (stringify (zr-name zr)))))
 		   (funcall func
 			    name
+			    zname
 			    (zr-data zr)
 			    (zr-ttl zr)
-			    rec
-			    zname))))
+			    rec))))
 	  (zone-process-records records
 				(zone-default-ttl zone)
 				#'parse-record))
@@ -570,7 +575,11 @@
 
 (defzoneparse :a (name data rec)
   ":a IPADDR"
-  (rec :data (parse-ipaddr data)))
+  (rec :data (parse-ipaddr data) :make-ptr-p t))
+
+(defzoneparse :svc (name data rec)
+  ":svc IPADDR"
+  (rec :type :a :data (parse-ipaddr data)))
 
 (defzoneparse :ptr (name data rec :zname zname)
   ":ptr HOST"
@@ -635,6 +644,7 @@
 		     (hash-table-keys *zones*)))
 	(dolist (zr (zone-records (zone-find z)))
 	  (when (and (eq (zr-type zr) :a)
+		     (zr-make-ptr-p zr)
 		     (ipaddr-networkp (zr-data zr) net))
 	    (let ((name (string-downcase
 			 (join-strings