From 5bf80328af386b6737e9c5a75ad1d0d95bf5f38b Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Fri, 15 Jun 2007 15:12:16 +0100
Subject: [PATCH] zone: Allow record parsers more control over the names they
 produce.

Pass in the parent zone and the given prefix, rather than computing the
final name.  The defzoneparse macro wrapper computes the final name,
though parsers have access to the original data and the function to
compute the name so that they can produce different names should they so
wish.
---
 zone.lisp | 60 +++++++++++++++++++++++++++++++-----------------------------
 1 file changed, 31 insertions(+), 29 deletions(-)

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))
-- 
2.11.0