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 f3d85d09da72c3def540965a0b5338d03f55fe66..0ea9360e0d74117763a68ce2bb2b9ec6dc0ed48c 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -35,7 +35,7 @@ (defpackage #:zone
             #:*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 @@ (defun zone-parse-head (head)
                      :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 @@ (defmacro defzoneparse (types (name data list
 
    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 @@ (defmacro defzoneparse (types (name data list
        `(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 @@ (defun zone-parse-records (zone records)
                 (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))