From 5952892a334c94bcb2a03b0013c99a31c23ffc18 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 22 Dec 2014 20:32:58 +0000
Subject: [PATCH] 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.
---
 zone.lisp | 89 +++++++++++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 69 insertions(+), 20 deletions(-)

diff --git a/zone.lisp b/zone.lisp
index 9a1a026..c5a55b7 100644
--- 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)
-- 
2.11.0