zone: Quench warnings from zone-parser functions.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 64488c2a0d11f3875462fc00fa505f5c8753b661..611a6ac8af75676810ca65ff0fdae7363349054a 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -13,12 +13,12 @@
 ;;; it under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 2 of the License, or
 ;;; (at your option) any later version.
 ;;; it under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 2 of the License, or
 ;;; (at your option) any later version.

-;;; 
+;;;

 ;;; This program is distributed in the hope that it will be useful,
 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
 ;;; This program is distributed in the hope that it will be useful,
 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.

-;;; 
+;;;

 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.


@@ -33,9 +33,14 @@ (defpackage #:zone
             #:*default-zone-retry* #:*default-zone-expire*
             #:*default-zone-min-ttl* #:*default-zone-ttl*
             #:*default-mx-priority* #:*default-zone-admin*
             #:*default-zone-retry* #:*default-zone-expire*
             #:*default-zone-min-ttl* #:*default-zone-ttl*
             #:*default-mx-priority* #:*default-zone-admin*

-            #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
-            #:defrevzone #:zone-save
+          #:*zone-output-path*
+          #:*preferred-subnets* #:zone-preferred-subnet-p
+          #:preferred-subnet-case
+          #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
+          #:defrevzone #:zone-save #:zone-make-name

           #:defzoneparse #:zone-parse-host
           #:defzoneparse #:zone-parse-host

+          #:bind-hostname #:bind-record #:bind-format-record
+          #:bind-record-type #:bind-record-format-args

           #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)
           #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)


@@ -144,9 +149,18 @@ (defstruct (zone (:predicate zonep))
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 

+#+ecl
+(cffi:defcfun gethostname :int
+  (name :pointer)
+  (len :uint))
+

 (defvar *default-zone-source*
   (let ((hn #+cmu (unix:unix-gethostname)
 (defvar *default-zone-source*
   (let ((hn #+cmu (unix:unix-gethostname)

-           #+clisp (unix:get-host-name)))
+           #+clisp (unix:get-host-name)
+           #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
+                   (let ((rc (gethostname buffer len)))
+                     (unless (zerop rc)
+                       (error "gethostname(2) failed (rc = ~A)." rc))))))

     (and hn (concatenate 'string (canonify-hostname hn) ".")))
   "The default zone source: the current host's name.")
 
     (and hn (concatenate 'string (canonify-hostname hn) ".")))
   "The default zone source: the current host's name.")
 


@@ -171,35 +185,6 @@ (defvar *default-zone-ttl* (* 8 60 60)
 (defvar *default-mx-priority* 50
   "Default MX priority.")
 
 (defvar *default-mx-priority* 50
   "Default MX priority.")
 

-;;;--------------------------------------------------------------------------
-;;; Serial numbering.
-
-(defun make-zone-serial (name)
-  "Given a zone NAME, come up with a new serial number.  This will (very
-   carefully) update a file ZONE.serial in the current directory."
-  (let* ((file (format nil "~(~A~).serial" name))
-        (last (with-open-file (in file
-                                  :direction :input
-                                  :if-does-not-exist nil)
-                (if in (read in)
-                    (list 0 0 0 0))))
-        (now (multiple-value-bind
-                 (sec min hr dy mon yr dow dstp tz)
-                 (get-decoded-time)
-               (declare (ignore sec min hr dow dstp tz))
-               (list dy mon yr)))
-        (seq (cond ((not (equal now (cdr last))) 0)
-                   ((< (car last) 99) (1+ (car last)))
-                   (t (error "Run out of sequence numbers for ~A" name)))))
-    (safely-writing (out file)
-      (format out
-             ";; Serial number file for zone ~A~%~
-               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
-               ~S~%"
-             name
-             (cons seq now)))
-    (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
-

 ;;;--------------------------------------------------------------------------
 ;;; Zone variables and structures.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone variables and structures.
 


@@ -219,7 +204,7 @@ (defstruct (zone-record (:conc-name zr-))
   (name '<unnamed>)
   ttl
   type
   (name '<unnamed>)
   ttl
   type

-  (defsubp nil)
+  (make-ptr-p nil)

   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))


@@ -229,9 +214,45 @@ (defstruct (zone-subdomain (:conc-name zs-))
   ttl
   records)
 
   ttl
   records)
 

+(defvar *zone-output-path* *default-pathname-defaults*
+  "Pathname defaults to merge into output files.")
+
+(defvar *preferred-subnets* nil
+  "Subnets to prefer when selecting defaults.")
+

 ;;;--------------------------------------------------------------------------
 ;;; Zone infrastructure.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone infrastructure.
 

+(defun zone-file-name (zone type)
+  "Choose a file name for a given ZONE and TYPE."
+  (merge-pathnames (make-pathname :name (string-downcase zone)
+                                 :type (string-downcase type))
+                  *zone-output-path*))
+
+(defun zone-preferred-subnet-p (name)
+  "Answer whether NAME (a string or symbol) names a preferred subnet."
+  (member name *preferred-subnets* :test #'string-equal))
+
+(defmacro preferred-subnet-case (&body clauses)
+  "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
+   SUBNETS (a list or single symbol, not evaluated) are considered preferred
+   by zone-preferred-subnet-p.  If SUBNETS is the symbol t then the clause
+   always matches."
+  `(cond
+    ,@(mapcar (lambda (clause)
+               (let ((subnets (car clause)))
+                 (cons (cond ((eq subnets t)
+                              t)
+                             ((listp subnets)
+                              `(or ,@(mapcar (lambda (subnet)
+                                               `(zone-preferred-subnet-p
+                                                 ',subnet))
+                                             subnets)))
+                             (t
+                              `(zone-preferred-subnet-p ',subnets)))
+                       (cdr clause))))
+             clauses)))
+

 (defun zone-process-records (rec ttl func)
   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
    the default time-to-live for records which don't specify one."
 (defun zone-process-records (rec ttl func)
   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
    the default time-to-live for records which don't specify one."


@@ -256,31 +277,31 @@ (defun zone-process-records (rec ttl func)
                                     sub)))
                         (t
                          (error "Unexpected record form ~A" (car r))))))))
                                     sub)))
                         (t
                          (error "Unexpected record form ~A" (car r))))))))

-          (process (rec dom ttl defsubp)
+          (process (rec dom ttl)

             (multiple-value-bind (top sub) (sift rec ttl)
               (if (and dom (null top) sub)
             (multiple-value-bind (top sub) (sift rec ttl)
               (if (and dom (null top) sub)

-                  (let ((s (pop sub)))
-                    (process (zs-records s)
-                             dom
-                             (zs-ttl s)
-                             defsubp)
-                    (process (zs-records s)
-                             (cons (zs-name s) dom)
-                             (zs-ttl s)
-                             t))
-                (let ((name (and dom
-                                 (string-downcase
-                                  (join-strings #\. (reverse dom))))))
-                  (dolist (zr top)
-                    (setf (zr-name zr) name)
-                    (setf (zr-defsubp zr) defsubp)
-                    (funcall func zr))))
+                  (let ((preferred nil))
+                    (dolist (s sub)
+                      (when (some #'zone-preferred-subnet-p
+                                  (listify (zs-name s)))
+                        (setf preferred s)))
+                    (unless preferred
+                      (setf preferred (car sub)))
+                    (when preferred
+                      (process (zs-records preferred)
+                               dom
+                               (zs-ttl preferred))))
+                  (let ((name (and dom
+                                   (string-downcase
+                                    (join-strings #\. (reverse dom))))))
+                    (dolist (zr top)
+                      (setf (zr-name zr) name)
+                      (funcall func zr))))

               (dolist (s sub)
                 (process (zs-records s)
                          (cons (zs-name s) dom)
               (dolist (s sub)
                 (process (zs-records s)
                          (cons (zs-name s) dom)

-                         (zs-ttl s)
-                         defsubp)))))
-    (process rec nil ttl nil)))
+                         (zs-ttl s))))))
+    (process rec nil ttl)))

 
 (defun zone-parse-host (f zname)
   "Parse a host name F: if F ends in a dot then it's considered absolute;
 
 (defun zone-parse-host (f zname)
   "Parse a host name F: if F ends in a dot then it's considered absolute;


@@ -340,44 +361,6 @@ (defun zone-net-from-name (name)
     (setf addr (ash addr (* 8 (- 4 n))))
     (make-ipnet addr (* 8 n))))
 
     (setf addr (ash addr (* 8 (- 4 n))))
     (make-ipnet addr (* 8 n))))
 

-(defun zone-reverse-records (records net list bytes dom)
-  "Construct a reverse zone given a forward zone's RECORDS list, the NET that
-   the reverse zone is to serve, a LIST to collect the records into, how many
-   BYTES of data need to end up in the zone, and the DOM-ain suffix."
-  (dolist (zr records)
-    (when (and (eq (zr-type zr) :a)
-              (not (zr-defsubp zr))
-              (ipaddr-networkp (zr-data zr) net))
-      (collect (make-zone-record
-               :name (string-downcase
-                      (join-strings
-                       #\.
-                       (collecting ()
-                         (dotimes (i bytes)
-                           (collect (logand #xff (ash (zr-data zr)
-                                                      (* -8 i)))))
-                         (collect dom))))
-               :type :ptr
-               :ttl (zr-ttl zr)
-               :data (zr-name zr))
-              list))))
-
-(defun zone-reverse (data name list)
-  "Process a :reverse record's DATA, for a domain called NAME, and add the
-   records to the LIST."
-  (destructuring-bind
-      (net &key bytes zones)
-      (listify data)
-    (setf net (zone-parse-net net name))
-    (dolist (z (or (listify zones)
-                  (hash-table-keys *zones*)))
-      (zone-reverse-records (zone-records (zone-find z))
-                           net
-                           list
-                           (or bytes
-                               (ipnet-changeable-bytes (ipnet-mask net)))
-                           name))))
-

 (defun zone-parse-net (net name)
   "Given a NET, and the NAME of a domain to guess from if NET is null, return
    the ipnet for the network."
 (defun zone-parse-net (net name)
   "Given a NET, and the NAME of a domain to guess from if NET is null, return
    the ipnet for the network."


@@ -396,46 +379,35 @@ (defun zone-cidr-delg-default-name (ipn bytes)
                      until (zerop (logand mask (ash #xff (* 8 i))))
                      collect (logand #xff (ash net (* -8 i))))))))
 
                      until (zerop (logand mask (ash #xff (* 8 i))))
                      collect (logand #xff (ash net (* -8 i))))))))
 

-(defun zone-cidr-delegation (data name ttl list)
-  "Given :cidr-delegation info DATA, for a record called NAME and the current
-   TTL, write lots of CNAME records to LIST."
-  (destructuring-bind
-      (net &key bytes)
-      (listify (car data))
-    (setf net (zone-parse-net net name))
-    (unless bytes
-      (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
-    (dolist (map (cdr data))
-      (destructuring-bind
-         (tnet &optional tdom)
-         (listify map)
-       (setf tnet (zone-parse-net tnet name))
-       (unless (ipnet-subnetp net tnet)
-         (error "~A is not a subnet of ~A."
-                (ipnet-pretty tnet)
-                (ipnet-pretty net)))            
-       (unless tdom
-         (setf tdom
-               (join-strings #\.
-                             (list (zone-cidr-delg-default-name tnet bytes)
-                                   name))))
-       (setf tdom (string-downcase tdom))
-       (dotimes (i (ipnet-hosts tnet))
-         (let* ((addr (ipnet-host tnet i))
-                (tail (join-strings #\.
-                                    (loop
-                                       for i from 0 below bytes
-                                       collect
-                                         (logand #xff
-                                                 (ash addr (* 8 i)))))))
-           (collect (make-zone-record
-                     :name (join-strings #\.
-                                         (list tail name))
-                     :type :cname
-                     :ttl ttl
-                     :data (join-strings #\. (list tail tdom)))
-                    list)))))))
-                                                 
+;;;--------------------------------------------------------------------------
+;;; Serial numbering.
+
+(defun make-zone-serial (name)
+  "Given a zone NAME, come up with a new serial number.  This will (very
+   carefully) update a file ZONE.serial in the current directory."
+  (let* ((file (zone-file-name name :serial))
+        (last (with-open-file (in file
+                                  :direction :input
+                                  :if-does-not-exist nil)
+                (if in (read in)
+                    (list 0 0 0 0))))
+        (now (multiple-value-bind
+                 (sec min hr dy mon yr dow dstp tz)
+                 (get-decoded-time)
+               (declare (ignore sec min hr dow dstp tz))
+               (list dy mon yr)))
+        (seq (cond ((not (equal now (cdr last))) 0)
+                   ((< (car last) 99) (1+ (car last)))
+                   (t (error "Run out of sequence numbers for ~A" name)))))
+    (safely-writing (out file)
+      (format out
+             ";; Serial number file for zone ~A~%~
+               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
+               ~S~%"
+             name
+             (cons seq now)))
+    (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
+

 ;;;--------------------------------------------------------------------------
 ;;; Zone form parsing.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone form parsing.
 


@@ -470,10 +442,18 @@ (defun zone-parse-head (head)
                      :min-ttl (timespec-seconds min-ttl)
                      :serial serial))))
 
                      :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
 (defmacro defzoneparse (types (name data list

-                              &key (zname (gensym "ZNAME"))
-                                   (ttl (gensym "TTL"))
-                                   (defsubp (gensym "DEFSUBP")))
+                              &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
    permitted).  The arguments are as follows:
                        &body body)
   "Define a new zone record type (or TYPES -- a list of synonyms is
    permitted).  The arguments are as follows:


@@ -481,51 +461,52 @@                               (defsubp (gensym "DEFSUBP")))
    NAME                The name of the record to be added.
 
    DATA                The content of the record to be added (a single object,
    NAME                The name of the record to be added.
 
    DATA                The content of the record to be added (a single object,

-               unevaluated). 
+               unevaluated).

 
    LIST                A function to add a record to the zone.  See below.
 
 
    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.
 
    ZNAME       The name of the zone being constructed.
 
    TTL         The TTL for this record.
 

-   DEFSUBP     Whether this is the default subdomain for this entry.
-
-   You get to choose your own names for these.  ZNAME, TTL and DEFSUBP are
+   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
 
    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
 

-     (LIST &key :name :type :data :ttl :defsubp)
+     (LIST &key :name :type :data :ttl :make-ptr-p)

 
 

-   Except for defsubp, these default to the above arguments (even if you
-   didn't accept the arguments)."
+   These (except MAKE-PTR-P, which defaults to nil) default to the above
+   arguments (even if you didn't accept the arguments)."

   (setf types (listify types))
   (let* ((type (car types))
         (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
   (setf types (listify types))
   (let* ((type (car types))
         (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))

-    (multiple-value-bind (doc decls body) (parse-body body)
-      (with-gensyms (col tname ttype tttl tdata tdefsubp i)
+    (with-parsed-body (body decls doc) body
+      (with-gensyms (col tname ttype tttl tdata tmakeptrp i)

        `(progn
           (dolist (,i ',types)
             (setf (get ,i 'zone-parse) ',func))
        `(progn
           (dolist (,i ',types)
             (setf (get ,i 'zone-parse) ',func))

-          (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
+          (defun ,func (,prefix ,zname ,data ,ttl ,col)

             ,@doc
             ,@decls
             ,@doc
             ,@decls

-            (declare (ignorable ,zname ,defsubp))
-            (flet ((,list (&key ((:name ,tname) ,name)
-                                ((:type ,ttype) ,type)
-                                ((:data ,tdata) ,data)
-                                ((:ttl ,tttl) ,ttl)
-                                ((:defsubp ,tdefsubp) nil))
-                     (collect (make-zone-record :name ,tname
-                                                :type ,ttype
-                                                :data ,tdata
-                                                :ttl ,tttl
-                                                :defsubp ,tdefsubp)
-                              ,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)
+                                  ((:make-ptr-p ,tmakeptrp) nil))
+                       #+cmu (declare (optimize ext:inhibit-warnings))
+                       (collect (make-zone-record :name ,tname
+                                                  :type ,ttype
+                                                  :data ,tdata
+                                                  :ttl ,tttl
+                                                  :make-ptr-p ,tmakeptrp)
+                                ,col)))
+                ,@body)))
+         ',type)))))

 
 (defun zone-parse-records (zone records)
   (let ((zname (zone-name zone)))
 
 (defun zone-parse-records (zone records)
   (let ((zname (zone-name zone)))


@@ -534,26 +515,16 @@ (defun zone-parse-records (zone records)
                 (let ((func (or (get (zr-type zr) 'zone-parse)
                                 (error "No parser for record ~A."
                                        (zr-type zr))))
                 (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
                   (funcall func
                            name

+                           zname

                            (zr-data zr)
                            (zr-ttl zr)
                            (zr-data zr)
                            (zr-ttl zr)

-                           rec
-                           zname
-                           (zr-defsubp zr)))))
+                           rec))))

          (zone-process-records records
                                (zone-default-ttl zone)
          (zone-process-records records
                                (zone-default-ttl zone)

-                               #'parse-record ))
+                               #'parse-record))

       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 
 (defun zone-parse (zf)
       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 
 (defun zone-parse (zf)


@@ -598,9 +569,13 @@ (defmacro defrevzone (head &rest zf)
 ;;;--------------------------------------------------------------------------
 ;;; Zone record parsers.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone record parsers.
 

-(defzoneparse :a (name data rec :defsubp defsubp)
+(defzoneparse :a (name data rec)

   ":a IPADDR"
   ":a IPADDR"

-  (rec :data (parse-ipaddr data) :defsubp defsubp))
+  (rec :data (parse-ipaddr data) :make-ptr-p t))
+
+(defzoneparse :svc (name data rec)
+  ":svc IPADDR"
+  (rec :type :a :data (parse-ipaddr data)))

 
 (defzoneparse :ptr (name data rec :zname zname)
   ":ptr HOST"
 
 (defzoneparse :ptr (name data rec :zname zname)
   ":ptr HOST"


@@ -650,7 +625,7 @@ (defzoneparse :net (name data rec)
       (rec :name (zone-parse-host "broadcast" name)
           :type :a
           :data (ipnet-broadcast n)))))
       (rec :name (zone-parse-host "broadcast" name)
           :type :a
           :data (ipnet-broadcast n)))))

-  
+

 (defzoneparse (:rev :reverse) (name data rec)
   ":reverse ((NET :bytes BYTES) ZONE*)"
   (setf data (listify data))
 (defzoneparse (:rev :reverse) (name data rec)
   ":reverse ((NET :bytes BYTES) ZONE*)"
   (setf data (listify data))


@@ -660,23 +635,25 @@ (defzoneparse (:rev :reverse) (name data rec)
     (setf net (zone-parse-net net name))
     (unless bytes
       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
     (setf net (zone-parse-net net name))
     (unless bytes
       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))

-    (dolist (z (or (cdr data)
-                  (hash-table-keys *zones*)))
-      (dolist (zr (zone-records (zone-find z)))
-       (when (and (eq (zr-type zr) :a)
-                  (not (zr-defsubp zr))
-                  (ipaddr-networkp (zr-data zr) net))
-         (rec :name (string-downcase
-                     (join-strings
-                      #\.
-                      (collecting ()
-                        (dotimes (i bytes)
-                          (collect (logand #xff (ash (zr-data zr)
-                                                     (* -8 i)))))
-                        (collect name))))
-              :type :ptr
-              :ttl (zr-ttl zr)
-              :data (zr-name zr)))))))
+    (let ((seen (make-hash-table :test #'equal)))
+      (dolist (z (or (cdr data)
+                    (hash-table-keys *zones*)))
+       (dolist (zr (zone-records (zone-find z)))
+         (when (and (eq (zr-type zr) :a)
+                    (zr-make-ptr-p zr)
+                    (ipaddr-networkp (zr-data zr) net))
+           (let ((name (string-downcase
+                        (join-strings
+                         #\.
+                         (collecting ()
+                           (dotimes (i bytes)
+                             (collect (logand #xff (ash (zr-data zr)
+                                                        (* -8 i)))))
+                           (collect name))))))
+             (unless (gethash name seen)
+               (rec :name name :type :ptr
+                    :ttl (zr-ttl zr) :data (zr-name zr))
+               (setf (gethash name seen) t)))))))))

 
 (defzoneparse (:cidr-delegation :cidr) (name data rec)
   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
 
 (defzoneparse (:cidr-delegation :cidr) (name data rec)
   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"


@@ -694,7 +671,7 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec)
        (unless (ipnet-subnetp net tnet)
          (error "~A is not a subnet of ~A."
                 (ipnet-pretty tnet)
        (unless (ipnet-subnetp net tnet)
          (error "~A is not a subnet of ~A."
                 (ipnet-pretty tnet)

-                (ipnet-pretty net)))            
+                (ipnet-pretty net)))

        (unless tdom
          (with-ipnet (net mask) tnet
            (setf tdom
        (unless tdom
          (with-ipnet (net mask) tnet
            (setf tdom


@@ -724,34 +701,53 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec)
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 

-(defun zone-write (zone &optional (stream *standard-output*))
-  "Write a ZONE's records to STREAM."
-  (labels ((fix-admin (a)
-            (let ((at (position #\@ a))
-                  (s (concatenate 'string (string-downcase a) ".")))
-              (when s
-                (setf (char s at) #\.))
-              s))
-          (fix-host (h)
-            (if (not h)
-                "@"
-                (let* ((h (string-downcase (stringify h)))
-                       (hl (length h))
-                       (r (string-downcase (zone-name zone)))
-                       (rl (length r)))
-                  (cond ((string= r h) "@")
-                        ((and (> hl rl)
-                              (char= (char h (- hl rl 1)) #\.)
-                              (string= h r :start1 (- hl rl)))
-                         (subseq h 0 (- hl rl 1)))
-                        (t (concatenate 'string h "."))))))
-          (printrec (zr)
-            (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
-                    (fix-host (zr-name zr))
-                    (and (/= (zr-ttl zr) (zone-default-ttl zone))
-                         (zr-ttl zr))
-                    (string-upcase (symbol-name (zr-type zr))))))
-    (format stream "~
+(defgeneric zone-write (format zone stream)
+  (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
+
+(defvar *writing-zone* nil
+  "The zone currently being written.")
+
+(defvar *zone-output-stream* nil
+  "Stream to write zone data on.")
+
+(defmethod zone-write :around (format zone stream)
+  (let ((*writing-zone* zone)
+       (*zone-output-stream* stream))
+    (call-next-method)))
+
+(defun zone-save (zones &key (format :bind))
+  "Write the named ZONES to files.  If no zones are given, write all the
+   zones."
+  (unless zones
+    (setf zones (hash-table-keys *zones*)))
+  (safely (safe)
+    (dolist (z zones)
+      (let ((zz (zone-find z)))
+       (unless zz
+         (error "Unknown zone `~A'." z))
+       (let ((stream (safely-open-output-stream safe
+                                                (zone-file-name z :zone))))
+         (zone-write format zz stream))))))
+
+;;;--------------------------------------------------------------------------
+;;; Bind format output.
+
+(defun bind-hostname (hostname)
+  (if (not hostname)
+      "@"
+      (let* ((h (string-downcase (stringify hostname)))
+            (hl (length h))
+            (r (string-downcase (zone-name *writing-zone*)))
+            (rl (length r)))
+       (cond ((string= r h) "@")
+             ((and (> hl rl)
+                   (char= (char h (- hl rl 1)) #\.)
+                   (string= h r :start1 (- hl rl)))
+              (subseq h 0 (- hl rl 1)))
+             (t (concatenate 'string h "."))))))
+
+(defmethod zone-write ((format (eql :bind)) zone stream)
+  (format stream "~

 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 
 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 


@@ -760,7 +756,13 @@ (defun zone-write (zone &optional (stream *standard-output*))
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))

-    (let ((soa (zone-soa zone)))
+  (let* ((soa (zone-soa zone))
+        (admin (let* ((name (soa-admin soa))
+                      (at (position #\@ name))
+                      (copy (format nil "~(~A~)." name)))
+                 (when at
+                   (setf (char copy at) #\.))
+                 copy)))

       (format stream "~
 ~A~30TIN SOA~40T~A ~A (
 ~45T~10D~60T ;serial
       (format stream "~
 ~A~30TIN SOA~40T~A ~A (
 ~45T~10D~60T ;serial


@@ -768,47 +770,46 @@ (defun zone-write (zone &optional (stream *standard-output*))
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"

-             (fix-host (zone-name zone))
-             (fix-host (soa-source soa))
-             (fix-admin (soa-admin soa))
+             (bind-hostname (zone-name zone))
+             (bind-hostname (soa-source soa))
+             admin

              (soa-serial soa)
              (soa-refresh soa)
              (soa-retry soa)
              (soa-expire soa)
              (soa-min-ttl soa)))
              (soa-serial soa)
              (soa-refresh soa)
              (soa-retry soa)
              (soa-expire soa)
              (soa-min-ttl soa)))

-    (dolist (zr (zone-records zone))
-      (case (zr-type zr)
-       (:a
-        (printrec zr)
-        (format stream "~A~%" (ipaddr-string (zr-data zr))))
-       ((:ptr :cname)
-        (printrec zr)
-        (format stream "~A~%" (fix-host (zr-data zr))))
-       (:ns
-        (printrec zr)
-        (format stream "~A~%" (fix-host (zr-data zr))))
-       (:mx
-        (printrec zr)
-        (let ((mx (zr-data zr)))
-          (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
-       (:txt
-        (printrec zr)
-        (format stream "~S~%" (stringify (zr-data zr))))))))
-
-(defun zone-save (zones)
-  "Write the named ZONES to files.  If no zones are given, write all the
-   zones."
-  (unless zones
-    (setf zones (hash-table-keys *zones*)))
-  (safely (safe)
-    (dolist (z zones)
-      (let ((zz (zone-find z)))
-       (unless zz
-         (error "Unknown zone `~A'." z))
-       (let ((stream (safely-open-output-stream safe
-                                                (format nil
-                                                        "~(~A~).zone"
-                                                        z))))
-         (zone-write zz stream))))))
+  (dolist (zr (zone-records zone))
+    (bind-record (zr-type zr) zr)))
+
+(defgeneric bind-record (type zr))
+
+(defun bind-format-record (name ttl type format args)
+  (format *zone-output-stream*
+         "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
+         (bind-hostname name)
+         (and (/= ttl (zone-default-ttl *writing-zone*))
+              ttl)
+         (string-upcase (symbol-name type))
+         format args))
+
+(defmethod bind-record (type zr)
+  (destructuring-bind (format &rest args)
+      (bind-record-format-args type (zr-data zr))
+    (bind-format-record (zr-name zr)
+                       (zr-ttl zr)
+                       (bind-record-type type)
+                       format args)))
+
+(defgeneric bind-record-type (type)
+  (:method (type) type))
+
+(defgeneric bind-record-format-args (type data)
+  (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
+  (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :mx)) data)
+    (list "~2D ~A" (cdr data) (bind-hostname (car data))))
+  (:method ((type (eql :txt)) data) (list "~S" (stringify data))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------