zone: Allow record parsers more control over the names they produce.

[zone] / zone.lisp

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