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.

diff --git a/zone.lisp b/zone.lisp
index f3d85d0..0ea9360 100644 (file)
--- 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))