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

diff --git a/zone.lisp b/zone.lisp
index f3d85d0..0ea9360 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))
 
@@ -446,8 +446,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,12 +469,14 @@
 
    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
@@ -482,21 +493,21 @@
 	`(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))
+			(collect (make-zone-record :name ,tname
+						   :type ,ttype
+						   :data ,tdata
+						   :ttl ,tttl)
+				 ,col)))
+		 ,@body)))
+	  ',type)))))
 
 (defun zone-parse-records (zone records)
   (let ((zname (zone-name zone)))
@@ -505,22 +516,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))