X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/800554956d25b239b4a4892cf058d8a13ec54966..cc0fa47a50532786e202ee24c6518e50ba6959e2:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index d2a8e47..ea9fda3 100644
--- 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.
-;;; 
+;;;
 ;;; 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.
@@ -27,40 +27,26 @@
 ;;; Packaging.
 
 (defpackage #:zone
-  (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:safely)
-  (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
-	   #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
-	     #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
-	     #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
-	     #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
-	   #:host-find# #:host-create #:defhost #:parse-ipaddr
-	     #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
-	     #:net-next-host #:net-host
-	   #:soa #:mx #:zone #:zone-record #:zone-subdomain
+  (:use #:common-lisp
+	#:mdw.base #:mdw.str #:collect #:safely
+	#:net #:services)
+  (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
 	   #:*default-zone-source* #:*default-zone-refresh*
 	     #:*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
+	   #:bind-hostname #:bind-record #:bind-format-record
+	   #:bind-record-type #:bind-record-format-args
 	   #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)
 
-;;;--------------------------------------------------------------------------
-;;; Basic types.
-
-(defun mask (n)
-  "Return 2^N - 1: i.e., a mask of N set bits."
-  (1- (ash 1 n)))
-(deftype u32 ()
-  "The type of unsigned 32-bit values."
-  '(unsigned-byte 32))
-(deftype ipaddr ()
-  "The type of IP (version 4) addresses."
-  'u32)
-
 ;;;--------------------------------------------------------------------------
 ;;; Various random utilities.
 
@@ -70,7 +56,7 @@ (defun to-integer (x)
 
 (defun from-mixed-base (base val)
   "BASE is a list of the ranges for the `digits' of a mixed-base
-representation.  Convert VAL, a list of digits, into an integer."
+   representation.  Convert VAL, a list of digits, into an integer."
   (do ((base base (cdr base))
        (val (cdr val) (cdr val))
        (a (car val) (+ (* a (car base)) (car val))))
@@ -78,7 +64,7 @@ (defun from-mixed-base (base val)
 
 (defun to-mixed-base (base val)
   "BASE is a list of the ranges for the `digits' of a mixed-base
-representation.  Convert VAL, an integer, into a list of digits."
+   representation.  Convert VAL, an integer, into a list of digits."
   (let ((base (reverse base))
 	(a nil))
     (loop
@@ -91,8 +77,8 @@ (defun to-mixed-base (base val)
 
 (defun timespec-seconds (ts)
   "Convert a timespec TS to seconds.  A timespec may be a real count of
-seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
-units."
+   seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
+   time units."
   (cond ((null ts) 0)
 	((realp ts) (floor ts))
 	((atom ts)
@@ -120,9 +106,9 @@ (defun hash-table-keys (ht)
 
 (defun iso-date (&optional time &key datep timep (sep #\ ))
   "Construct a textual date or time in ISO format.  The TIME is the universal
-time to convert, which defaults to now; DATEP is whether to emit the date;
-TIMEP is whether to emit the time, and SEP (default is space) is how to
-separate the two."
+   time to convert, which defaults to now; DATEP is whether to emit the date;
+   TIMEP is whether to emit the time, and SEP (default is space) is how to
+   separate the two."
   (multiple-value-bind
       (sec min hr day mon yr dow dstp tz)
       (decode-universal-time (if (or (null time) (eq time :now))
@@ -137,365 +123,6 @@ (defun iso-date (&optional time &key datep timep (sep #\ ))
       (when timep
 	(format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 
-(defun count-low-zero-bits (n)
-  "Return the number of low-order zero bits in the integer N."
-  (if (zerop n) nil
-      (loop for i from 0
-	    until (logbitp i n)
-	    finally (return i))))
-
-;;;--------------------------------------------------------------------------
-;;; Simple messing with IP addresses.
-
-(defun string-ipaddr (str &key (start 0) (end nil))
-  "Parse STR as an IP address in dotted-quad form and return the integer
-equivalent.  STR may be anything at all: it's converted as if by
-`stringify'.  The START and END arguments may be used to parse out a
-substring."
-  (setf str (stringify str))
-  (unless end
-    (setf end (length str)))
-  (let ((addr 0) (noct 0))
-    (loop
-      (let* ((pos (position #\. str :start start :end end))
-	     (i (parse-integer str :start start :end (or pos end))))
-	(unless (<= 0 i 256)
-	  (error "IP address octet out of range"))
-	(setf addr (+ (* addr 256) i))
-	(incf noct)
-	(unless pos
-	  (return))
-	(setf start (1+ pos))))
-    (unless (= noct 4)
-      (error "Wrong number of octets in IP address"))
-    addr))
-
-(defun ipaddr-byte (ip n)
-  "Return byte N (from most significant downwards) of an IP address."
-  (assert (<= 0 n 3))
-  (logand #xff (ash ip (* -8 (- 3 n)))))
-
-(defun ipaddr-string (ip)
-  "Transform the address IP into a string in dotted-quad form."
-  (check-type ip ipaddr)
-  (join-strings #\. (collecting ()
-		      (dotimes (i 4)
-			(collect (ipaddr-byte ip i))))))
-
-(defun ipaddrp (ip)
-  "Answer true if IP is a valid IP address in integer form."
-  (typep ip 'ipaddr))
-
-(defun ipaddr (ip)
-  "Convert IP to an IP address.  If it's an integer, return it unchanged;
-otherwise convert by `string-ipaddr'."
-  (typecase ip
-    (ipaddr ip)
-    (t (string-ipaddr ip))))
-
-;;;--------------------------------------------------------------------------
-;;; Netmasks.
-
-(defun integer-netmask (i)
-  "Given an integer I, return a netmask with its I top bits set."
-  (- (ash 1 32) (ash 1 (- 32 i))))
-
-(defun ipmask (ip)
-  "Transform IP into a netmask.  If it's a small integer then it's converted
-by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
-`ipaddr'."
-  (typecase ip
-    (null (mask 32))
-    ((integer 0 32) (integer-netmask ip))
-    (t (ipaddr ip))))
-
-(defun ipmask-cidl-slash (mask)
-  "Given a netmask MASK, return an integer N such that (integer-netmask N) =
-MASK, or nil if this is impossible."
-  (dotimes (i 33)
-    (when (= mask (integer-netmask i))
-      (return i))))
-
-;;;--------------------------------------------------------------------------
-;;; Networks: pairing an address and netmask.
-
-(defun make-ipnet (net mask)
-  "Construct an IP-network object given the NET and MASK; these are
-transformed as though by `ipaddr' and `ipmask'."
-  (let ((net (ipaddr net))
-	(mask (ipmask mask)))
-    (cons (logand net mask) mask)))
-
-(defun string-ipnet (str &key (start 0) (end nil))
-  "Parse an IP-network from the string STR."
-  (setf str (stringify str))
-  (unless end (setf end (length str)))
-  (let ((sl (position #\/ str :start start :end end)))
-    (if sl
-	(make-ipnet (parse-ipaddr (subseq str start sl))
-		    (if (find #\. str :start (1+ sl) :end end)
-			(string-ipaddr str :start (1+ sl) :end end)
-			(integer-netmask (parse-integer str
-							:start (1+ sl)
-							:end end))))
-	(make-ipnet (parse-ipaddr (subseq str start end))
-		    (integer-netmask 32)))))
-
-(defun ipnet (net)
-  "Construct an IP-network object from the given argument.  A number of
-forms are acceptable:
-
-  * ADDR -- a single address (equivalent to ADDR 32)
-  * (NET . MASK|nil) -- a single-object representation.
-  * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
-  (cond ((or (stringp net) (symbolp net)) (string-ipnet net))
-	(t (apply #'make-ipnet (pairify net 32)))))
-
-(defun ipnet-net (ipn)
-  "Return the base network address of IPN."
-  (car ipn))
-
-(defun ipnet-mask (ipn)
-  "Return the netmask of IPN."
-  (cdr ipn))
-
-(defmacro with-ipnet ((net mask) ipn &body body)
-  "Evaluate BODY with NET and MASK bound to the base address and netmask of
-IPN.  Either NET or MASK (or, less usefully, both) may be nil if not wanted."
-  (with-gensyms tmp
-    `(let ((,tmp ,ipn))
-       (let (,@(and net `((,net (ipnet-net ,tmp))))
-	     ,@(and mask `((,mask (ipnet-mask ,tmp)))))
-	 ,@body))))
-
-(defun ipnet-pretty (ipn)
-  "Convert IPN to a pretty cons-cell form."
-  (with-ipnet (net mask) ipn
-    (cons (ipaddr-string net)
-	  (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
-
-(defun ipnet-string (ipn)
-  "Convert IPN to a string."
-  (with-ipnet (net mask) ipn
-    (format nil "~A/~A"
-	    (ipaddr-string net)
-	    (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
-
-(defun ipnet-broadcast (ipn)
-  "Return the broadcast address for the network IPN."
-  (with-ipnet (net mask) ipn
-    (logior net (logxor (mask 32) mask))))
-
-(defun ipnet-hosts (ipn)
-  "Return the number of available addresses in network IPN."
-  (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
-
-(defun ipnet-host (ipn host)
-  "Return the address of the given HOST in network IPN.  This works even with
-a non-contiguous netmask."
-  (check-type host u32)
-  (with-ipnet (net mask) ipn
-    (let ((i 0) (m 1) (a net) (h host))
-      (loop
-        (when (>= i 32)
-	  (error "Host index ~D out of range for network ~A"
-		 host (ipnet-pretty ipn)))
-        (cond ((zerop h)
-	       (return a))
-	      ((logbitp i mask)
-	       (setf h (ash h 1)))
-	      (t
-	       (setf a (logior a (logand m h)))
-	       (setf h (logandc2 h m))))
-	(setf m (ash m 1))
-	(incf i)))))
-
-(defun ipaddr-networkp (ip ipn)
-  "Returns true if address IP is within network IPN."
-  (with-ipnet (net mask) ipn
-    (= net (logand ip mask))))
-
-(defun ipnet-subnetp (ipn subn)
-  "Returns true if SUBN is a (non-strict) subnet of IPN."
-  (with-ipnet (net mask) ipn
-    (with-ipnet (subnet submask) subn
-      (and (= net (logand subnet mask))
-	   (= submask (logior mask submask))))))
-
-(defun ipnet-changeable-bytes (mask)
-  "Answers how many low-order bytes of MASK are (entirely or partially)
-changeable.  This is used when constructing reverse zones."
-  (dotimes (i 4 4)
-    (when (/= (ipaddr-byte mask i) 255)
-      (return (- 4 i)))))
-
-;;;--------------------------------------------------------------------------
-;;; Name resolution.
-
-#+cmu
-(defun resolve-hostname (name)
-  "Resolve a hostname to an IP address using the DNS, or return nil."
-  (let ((he (ext:lookup-host-entry name)))
-    (and he
-	 (ext:host-entry-addr he))))
-
-#+cmu
-(defun canonify-hostname (name)
-  "Resolve a hostname to canonical form using the DNS, or return nil."
-  (let ((he (ext:lookup-host-entry name)))
-    (and he
-	 (ext:host-entry-name he))))
-
-;;;--------------------------------------------------------------------------
-;;; Host names and specifiers.
-
-(defun parse-ipaddr (addr)
-  "Convert the string ADDR into an IP address: tries all sorts of things:
-
-  (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
-    INDEX is an index or one of the special symbols understood by net-host,
-    and defaults to :next
-  INTEGER -- an integer IP address
-  IPADDR -- an IP address in dotted-quad form
-  HOST -- a host name defined by defhost
-  DNSNAME -- a name string to look up in the DNS"
-  (cond ((listp addr)
-	 (destructuring-bind
-	     (net host)
-	     (pairify addr :next)
-	   (net-host (or (net-find net)
-			 (error "Network ~A not found" net))
-		     host)))
-	((ipaddrp addr) addr)
-	(t
-	 (setf addr (string-downcase (stringify addr)))
-	 (or (host-find addr)
-	     (and (plusp (length addr))
-		  (digit-char-p (char addr 0))
-		  (string-ipaddr addr))
-	     (resolve-hostname (stringify addr))
-	     (error "Host name ~A unresolvable" addr)))))
-
-(defvar *hosts* (make-hash-table :test #'equal)
-  "The table of known hostnames.")
-
-(defun host-find (name)
-  "Find a host by NAME."
-  (gethash (string-downcase (stringify name)) *hosts*))
-
-(defun (setf host-find) (addr name)
-  "Make NAME map to ADDR (must be an ipaddr in integer form)."
-  (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
-
-(defun host-create (name addr)
-  "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
-  (setf (host-find name) (parse-ipaddr addr)))
-
-(defmacro defhost (name addr)
-  "Main host definition macro.  Neither NAME nor ADDR is evaluated."
-  `(progn
-     (host-create ',name ',addr)
-     ',name))
-
-;;;--------------------------------------------------------------------------
-;;; Network names and specifiers.
-
-(defstruct (net (:predicate netp))
-  "A network structure.  Slots:
-
-NAME       The network's name, as a string
-IPNET      The network base address and mask
-HOSTS      Number of hosts in the network
-NEXT       Index of the next unassigned host"
-  name
-  ipnet
-  hosts
-  next)
-
-(defvar *networks* (make-hash-table :test #'equal)
-  "The table of known networks.")
-
-(defun net-find (name)
-  "Find a network by NAME."
-  (gethash (string-downcase (stringify name)) *networks*))
-
-(defun (setf net-find) (net name)
-  "Make NAME map to NET."
-  (setf (gethash (string-downcase (stringify name)) *networks*) net))
-
-(defun net-get-as-ipnet (form)
-  "Transform FORM into an ipnet.  FORM may be a network name, or something
-acceptable to the ipnet function."
-  (let ((net (net-find form)))
-    (if net (net-ipnet net)
-	(ipnet form))))
-
-(defun process-net-form (root addr subnets)
-  "Unpack a net-form.  The return value is a list of entries, each of which
-is a list of the form (NAME ADDR MASK).  The first entry is merely repeats
-the given ROOT and ADDR arguments (unpacking ADDR into separate network
-address and mask).  The SUBNETS are then processed: they are a list of items
-of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
-NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
-the same form.  An error is signalled if a net's subnets use up more hosts
-than the net has to start with."
-  (labels ((frob (subnets limit finger)
-	     (when subnets
-	       (destructuring-bind (name size &rest subs) (car subnets)
-		 (when (> (count-low-zero-bits size)
-			  (count-low-zero-bits finger))
-		   (error "Bad subnet size for ~A." name))
-		 (when (> (+ finger size) limit)
-		   (error "Subnet ~A out of range." name))
-		 (append (and name
-			      (list (list name finger (- (ash 1 32) size))))
-			 (frob subs (+ finger size) finger)
-			 (frob (cdr subnets) limit (+ finger size)))))))
-    (let ((ipn (ipnet addr)))
-      (with-ipnet (net mask) ipn
-	(unless (ipmask-cidl-slash mask)
-	  (error "Bad mask for subnet form."))
-	(cons (list root net mask)
-	      (frob subnets (+ net (ipnet-hosts ipn) 1) net))))))
-
-(defun net-create (name net)
-  "Construct a new network called NAME and add it to the map.  The ARGS
-describe the new network, in a form acceptable to the ipnet function."
-  (let ((ipn (ipnet net)))
-    (setf (net-find name)
-	  (make-net :name (string-downcase (stringify name))
-		    :ipnet ipn
-		    :hosts (ipnet-hosts ipn)
-		    :next 1))))
-
-(defmacro defnet (name net &rest subnets)
-  "Main network definition macro.  None of the arguments is evaluated."
-  `(progn
-    ,@(loop for (name addr mask) in (process-net-form name net subnets)
-	    collect `(net-create ',name '(,addr . ,mask)))
-    ',name))
-
-(defun net-next-host (net)
-  "Given a NET, return the IP address (as integer) of the next available
-address in the network."
-  (unless (< (net-next net) (net-hosts net))
-    (error "No more hosts left in network ~A" (net-name net)))
-  (let ((next (net-next net)))
-    (incf (net-next net))
-    (net-host net next)))
-
-(defun net-host (net host)
-  "Return the given HOST on the NEXT.  HOST may be an index (in range, of
-course), or one of the keywords:
-:NEXT       next host, as by net-next-host
-:NET        network base address
-:BROADCAST  network broadcast address"
-  (case host
-    (:next (net-next-host net))
-    (:net (ipnet-net (net-ipnet net)))
-    (:broadcast (ipnet-broadcast (net-ipnet net)))
-    (t (ipnet-host (net-ipnet net) host))))
-
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 
@@ -524,8 +151,18 @@ (defstruct (zone (:predicate zonep))
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 
+#+ecl
+(cffi:defcfun gethostname :int
+  (name :pointer)
+  (len :uint))
+
 (defvar *default-zone-source*
-  (let ((hn (unix:unix-gethostname)))
+  (let ((hn #+cmu (unix:unix-gethostname)
+	    #+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.")
 
@@ -550,35 +187,6 @@ (defvar *default-zone-ttl* (* 8 60 60)
 (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.
 
@@ -598,22 +206,58 @@ (defstruct (zone-record (:conc-name zr-))
   (name '<unnamed>)
   ttl
   type
-  (defsubp nil)
+  (make-ptr-p nil)
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
   "A subdomain.  Slightly weird.  Used internally by zone-process-records
-below, and shouldn't escape."
+   below, and shouldn't escape."
   name
   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.
 
+(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."
+   the default time-to-live for records which don't specify one."
   (labels ((sift (rec ttl)
 	     (collecting (top sub)
 	       (loop
@@ -635,35 +279,35 @@ (defun zone-process-records (rec ttl func)
 				     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)
-		   (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)
-			  (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;
-otherwise it's relative to ZNAME."
+   otherwise it's relative to ZNAME."
   (setf f (stringify f))
   (cond ((string= f "@") (stringify zname))
 	((and (plusp (length f))
@@ -673,7 +317,7 @@ (defun zone-parse-host (f zname)
 					 (stringify zname))))))
 (defun default-rev-zone (base bytes)
   "Return the default reverse-zone name for the given BASE address and number
-of fixed leading BYTES."
+   of fixed leading BYTES."
   (join-strings #\. (collecting ()
 		      (loop for i from (- 3 bytes) downto 0
 			    do (collect (ipaddr-byte base i)))
@@ -681,7 +325,7 @@ (defun default-rev-zone (base bytes)
 
 (defun zone-name-from-net (net &optional bytes)
   "Given a NET, and maybe the BYTES to use, convert to the appropriate
-subdomain of in-addr.arpa."
+   subdomain of in-addr.arpa."
   (let ((ipn (net-get-as-ipnet net)))
     (with-ipnet (net mask) ipn
       (unless bytes
@@ -719,54 +363,16 @@ (defun zone-net-from-name (name)
     (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."
+  "Given a NET, and the NAME of a domain to guess from if NET is null, return
+   the ipnet for the network."
   (if net
       (net-get-as-ipnet net)
       (zone-net-from-name name)))
 
 (defun zone-cidr-delg-default-name (ipn bytes)
   "Given a delegated net IPN and the parent's number of changing BYTES,
-return the default deletate zone prefix."
+   return the default deletate zone prefix."
   (with-ipnet (net mask) ipn
     (join-strings #\.
 		  (reverse
@@ -775,46 +381,35 @@ (defun zone-cidr-delg-default-name (ipn bytes)
 		      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.
 
@@ -824,8 +419,8 @@ (defun zone-parse-head (head)
      (NAME &key :source :admin :refresh :retry
                 :expire :min-ttl :ttl :serial)
 
-though a singleton NAME needn't be a list.  Returns the default TTL and an
-soa structure representing the zone head."
+   though a singleton NAME needn't be a list.  Returns the default TTL and an
+   soa structure representing the zone head."
   (destructuring-bind
       (zname
        &key
@@ -849,58 +444,71 @@ (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"))
-			            (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:
+   permitted).  The arguments are as follows:
 
-NAME	The name of the record to be added.
+   NAME		The name of the record to be added.
 
-DATA	The content of the record to be added (a single object, unevaluated).
+   DATA		The content of the record to be added (a single object,
+		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.
 
-ZNAME	The name of the zone being constructed.
+   PREFIX	The prefix tag used in the original form.
 
-TTL	The TTL for this record.
+   ZNAME	The name of the zone being constructed.
 
-DEFSUBP	Whether this is the default subdomain for this entry.
+   TTL		The TTL for this record.
 
-You get to choose your own names for these.  ZNAME, TTL and DEFSUBP 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
+   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))))
-    (with-gensyms (col tname ttype tttl tdata tdefsubp i)
-      `(progn
-	 (dolist (,i ',types)
-	   (setf (get ,i 'zone-parse) ',func))
-	 (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
-	   (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))))
+    (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))
+	   (defun ,func (,prefix ,zname ,data ,ttl ,col)
+	     ,@doc
+	     ,@decls
+	     (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)))
@@ -909,37 +517,27 @@ (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
-			    (zr-defsubp zr)))))
+			    rec))))
 	  (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)
   "Parse a ZONE form.  The syntax of a zone form is as follows:
 
-ZONE-FORM:
-  ZONE-HEAD ZONE-RECORD*
+   ZONE-FORM:
+     ZONE-HEAD ZONE-RECORD*
 
-ZONE-RECORD:
-  ((NAME*) ZONE-RECORD*)
-| SYM ARGS"
+   ZONE-RECORD:
+     ((NAME*) ZONE-RECORD*)
+   | SYM ARGS"
   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
     (let ((zone (make-zone :name zname
 			   :default-ttl ttl
@@ -950,7 +548,7 @@ (defun zone-parse (zf)
 
 (defun zone-create (zf)
   "Zone construction function.  Given a zone form ZF, construct the zone and
-add it to the table."
+   add it to the table."
   (let* ((zone (zone-parse zf))
 	 (name (zone-name zone)))
     (setf (zone-find name) zone)
@@ -973,9 +571,13 @@ (defmacro defrevzone (head &rest zf)
 ;;;--------------------------------------------------------------------------
 ;;; Zone record parsers.
 
-(defzoneparse :a (name data rec :defsubp defsubp)
+(defzoneparse :a (name data rec)
   ":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"
@@ -1012,6 +614,31 @@ (defzoneparse :alias (name data rec :zname zname)
 	 :type :cname
 	 :data name)))
 
+(defzoneparse :srv (name data rec :zname zname)
+  ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
+  (dolist (srv data)
+    (destructuring-bind (servopts &rest providers) srv
+      (destructuring-bind
+	  (service &key ((:port default-port)) (protocol :tcp))
+	  (listify servopts)
+	(unless default-port
+	  (let ((serv (serv-by-name service protocol)))
+	    (setf default-port (and serv (serv-port serv)))))
+	(let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
+	  (dolist (prov providers)
+	    (destructuring-bind
+		(srvname
+		 &key
+		 (port default-port)
+		 (prio *default-mx-priority*)
+		 (weight 0)
+		 ip)
+		(listify prov)
+	      (let ((host (zone-parse-host srvname zname)))
+		(when ip (rec :name host :type :a :data (parse-ipaddr ip)))
+		(rec :name rname
+		     :data (list prio weight port host))))))))))
+
 (defzoneparse :net (name data rec)
   ":net (NETWORK*)"
   (dolist (net (listify data))
@@ -1025,117 +652,139 @@ (defzoneparse :net (name data rec)
       (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))
-  (destructuring-bind
-      (net &key bytes)
-      (listify (car data))
+  (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 (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)))))))
-
-(defzoneparse (:cidr-delegation :cidr) (name data rec)
+    (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 :zname zname)
   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
-  (destructuring-bind
-      (net &key bytes)
-      (listify (car data))
+  (setf data (listify data))
+  (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)
+    (dolist (map (or (cdr data) (list (list net))))
+      (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)))		 
+		 (ipnet-pretty net)))
 	(unless tdom
 	  (with-ipnet (net mask) tnet
 	    (setf tdom
 		  (join-strings
 		   #\.
 		   (append (reverse (loop
-				       for i from (1- bytes) downto 0
-				       until (zerop (logand mask
-							    (ash #xff
-								 (* 8 i))))
-				       collect (logand #xff
-						       (ash net (* -8 i)))))
+				     for i from (1- bytes) downto 0
+				     until (zerop (logand mask
+							  (ash #xff
+							       (* 8 i))))
+				     collect (ldb (byte 8 (* i 8)) net)))
 			   (list name))))))
-	(setf tdom (string-downcase tdom))
+	(setf tdom (string-downcase (stringify tdom)))
 	(dotimes (i (ipnet-hosts tnet))
-	  (let* ((addr (ipnet-host tnet i))
-		 (tail (join-strings #\.
-				     (loop
+	  (unless (zerop i)
+	    (let* ((addr (ipnet-host tnet i))
+		   (tail (join-strings #\.
+				       (loop
 					for i from 0 below bytes
 					collect
-					  (logand #xff
-						  (ash addr (* 8 i)))))))
-	    (rec :name (format nil "~A.~A" tail name)
-		 :type :cname
-		 :data (format nil "~A.~A" tail tdom))))))))
+					(logand #xff
+						(ash addr (* 8 i)))))))
+	      (rec :name (format nil "~A.~A" tail name)
+		   :type :cname
+		   :data (format nil "~A.~A" tail tdom)))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; 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)
 
-$ORIGIN ~@0*~(~A.~)
-$TTL ~@2*~D~2%"
+$ORIGIN ~0@*~(~A.~)
+$TTL ~2@*~D~2%"
 	    (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
@@ -1143,47 +792,49 @@ (defun zone-write (zone &optional (stream *standard-output*))
 ~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)))
-    (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 :srv)) data)
+    (destructuring-bind (prio weight port host) data
+      (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
+  (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
 
 ;;;----- That's all, folks --------------------------------------------------