From: Mark Wooding Date: Fri, 15 Jun 2007 14:07:08 +0000 (+0100) Subject: zone: Use hash-table for reversing zones; eliminate defsubp. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/commitdiff_plain/4e7e3780c0f92094c6def85910e14901b9e1070f zone: Use hash-table for reversing zones; eliminate defsubp. For :reverse, use a hash-table to keep track of which addresses have been assigned PTR records so far. Eliminate the defsubp slot of zone records as being a bad (and confusing) idea. --- diff --git a/zone.lisp b/zone.lisp index 6b11880..f3d85d0 100644 --- a/zone.lisp +++ b/zone.lisp @@ -200,7 +200,6 @@ (defstruct (zone-record (:conc-name zr-)) (name ') ttl type - (defsubp nil) data) (defstruct (zone-subdomain (:conc-name zs-)) @@ -246,31 +245,27 @@ (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) + (zs-ttl s)) (process (zs-records s) (cons (zs-name s) dom) - (zs-ttl s) - t)) + (zs-ttl s))) (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)))) (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; @@ -453,8 +448,7 @@ (defun zone-parse-head (head) (defmacro defzoneparse (types (name data list &key (zname (gensym "ZNAME")) - (ttl (gensym "TTL")) - (defsubp (gensym "DEFSUBP"))) + (ttl (gensym "TTL"))) &body body) "Define a new zone record type (or TYPES -- a list of synonyms is permitted). The arguments are as follows: @@ -470,40 +464,36 @@ (defsubp (gensym "DEFSUBP"))) 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 - optional: you don't have to accept them if you're not interested. + 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. 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) - Except for defsubp, these default to the above arguments (even if you - didn't accept the arguments)." + These 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-parsed-body (body decls doc) body - (with-gensyms (col tname ttype tttl tdata tdefsubp i) + (with-gensyms (col tname ttype tttl tdata i) `(progn (dolist (,i ',types) (setf (get ,i 'zone-parse) ',func)) - (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp) + (defun ,func (,name ,data ,ttl ,col ,zname) ,@doc ,@decls - (declare (ignorable ,zname ,defsubp)) + (declare (ignorable ,zname)) (flet ((,list (&key ((:name ,tname) ,name) ((:type ,ttype) ,type) ((:data ,tdata) ,data) - ((:ttl ,tttl) ,ttl) - ((:defsubp ,tdefsubp) nil)) + ((:ttl ,tttl) ,ttl)) (collect (make-zone-record :name ,tname :type ,ttype :data ,tdata - :ttl ,tttl - :defsubp ,tdefsubp) + :ttl ,tttl) ,col))) ,@body)) ',type))))) @@ -530,8 +520,7 @@ (defun zone-parse-records (zone records) (zr-data zr) (zr-ttl zr) rec - zname - (zr-defsubp zr))))) + zname)))) (zone-process-records records (zone-default-ttl zone) #'parse-record)) @@ -579,9 +568,9 @@ (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))) (defzoneparse :ptr (name data rec :zname zname) ":ptr HOST" @@ -641,23 +630,24 @@ (defzoneparse (:rev :reverse) (name data rec) (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) + (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])*)"