zone.lisp: Abstract out and improve the enum machinery from `:sshfp'.

We're going to want it for something else soon.  Also add ancillary
functionality for reverse lookups and iteration, and a switch
controlling exports.

diff --git a/zone.lisp b/zone.lisp
index 9a1a026..c5a55b7 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -111,6 +111,67 @@
       (when timep
        (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 
+(defmacro defenum (name (&key export) &body values)
+  "Set up symbol properties for manifest constants.
+
+   The VALUES are a list of (TAG VALUE) pairs. Each TAG is a symbol; we set
+   the NAME property on TAG to VALUE, and export TAG.  There are also handy
+   hash-tables mapping in the forward and reverse directions, in the name
+   symbol's `enum-forward' and `enum-reverse' properties."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     ,(let*/gensyms (export)
+       (with-gensyms (forward reverse valtmp)
+         `(let ((,forward (make-hash-table))
+                (,reverse (make-hash-table)))
+            (when ,export (export ',name))
+            ,@(mapcar (lambda (item)
+                        (destructuring-bind (tag value) item
+                          (let ((constant
+                                 (intern (concatenate 'string
+                                                      (symbol-name name)
+                                                      "/"
+                                                      (symbol-name tag)))))
+                            `(let ((,valtmp ,value))
+                               (when ,export
+                                 (export ',constant)
+                                 (when (eq (symbol-package ',tag) *package*)
+                                   (export ',tag)))
+                               (defconstant ,constant ,valtmp)
+                               (setf (get ',tag ',name) ,value
+                                     (gethash ',tag ,forward) ,valtmp
+                                     (gethash ,valtmp ,reverse) ',tag)))))
+                      values)
+            (setf (get ',name 'enum-forward) ,forward
+                  (get ',name 'enum-reverse) ,reverse))))))
+
+(defun lookup-enum (name tag &key min max)
+  "Look up a TAG in an enumeration.
+
+   If TAG is a symbol, check its NAME property; if it's a fixnum then take it
+   as it is.  Make sure that it's between MIN and MAX, if they're not nil."
+  (let ((value (etypecase tag
+               (fixnum tag)
+               (symbol (or (get tag name)
+                           (error "~S is not a known ~A" tag name))))))
+    (unless (and (or (null min) (<= min value))
+               (or (null max) (<= value max)))
+      (error "Value ~S out of range for ~A" value name))
+    value))
+
+(defun reverse-enum (name value)
+  "Reverse-lookup of a VALUE in enumeration NAME.
+
+   If a tag for the VALUE is found, return it and `t'; otherwise return VALUE
+   unchanged and `nil'."
+  (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse))
+    (if foundp
+       (values tag t)
+       (values value nil))))
+
+(defun mapenum (func name)
+  "Call FUNC on TAG/VALUE pairs from the enumeration called NAME."
+  (maphash func (get name 'enum-forward)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 
@@ -798,15 +859,8 @@
       (rec :type :txt
           :data (nreverse things)))))
 
-(eval-when (:load-toplevel :execute)
-  (dolist (item '((sshfp-algorithm rsa 1)
-                 (sshfp-algorithm dsa 2)
-                 (sshfp-algorithm ecdsa 3)
-                 (sshfp-type sha-1 1)
-                 (sshfp-type sha-256 2)))
-    (destructuring-bind (prop sym val) item
-      (setf (get sym prop) val)
-      (export sym))))
+(defenum sshfp-algorithm (rsa 1) (dsa 2) (ecdsa 3))
+(defenum sshfp-type (sha-1 1) (sha-256 2))
 
 (export '*sshfp-pathname-defaults*)
 (defvar *sshfp-pathname-defaults*
@@ -830,17 +884,12 @@
                    (rec :data (list (parse-integer alg)
                                     (parse-integer type)
                                     fpr)))))))
-      (flet ((lookup (what prop)
-              (etypecase what
-                (fixnum what)
-                (symbol (or (get what prop)
-                            (error "~S is not a known ~A" what prop))))))
-       (dolist (item (listify data))
-         (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
-             (listify item)
-           (rec :data (list (lookup alg 'sshfp-algorithm)
-                            (lookup type 'sshfp-type)
-                            fpr)))))))
+      (dolist (item (listify data))
+       (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
+           (listify item)
+         (rec :data (list (lookup-enum alg 'sshfp-algorithm :min 0 :max 255)
+                          (lookup-enum type 'sshfp-type :min 0 :max 255)
+                          fpr))))))
 
 (defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
   (destructuring-bind (alg type fpr) (zr-data zr)