-(defun natural-string< (string1 string2
- &key (start1 0) (end1 nil)
- (start2 0) (end2 nil))
- "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
-
- In particular, digit sequences are handled in a moderately sensible way.
- Split the strings into maximally long alternating sequences of non-numeric
- and numeric characters, such that the non-numeric sequences are
- non-empty. Compare these lexicographically; numeric sequences order
- according to their integer values, non-numeric sequences in the usual
- lexicographic ordering.
-
- Returns two values: whether STRING1 strictly precedes STRING2, and whether
- STRING1 strictly follows STRING2."
-
- (let ((end1 (or end1 (length string1)))
- (end2 (or end2 (length string2))))
- (loop
- (cond ((>= start1 end1)
- (let ((eqp (>= start2 end2)))
- (return (values (not eqp) nil))))
- ((>= start2 end2)
- (return (values nil t)))
- ((and (digit-char-p (char string1 start1))
- (digit-char-p (char string2 start2)))
- (let* ((lim1 (or (position-if-not #'digit-char-p string1
- :start start1 :end end1)
- end1))
- (n1 (parse-integer string1 :start start1 :end lim1))
- (lim2 (or (position-if-not #'digit-char-p string2
- :start start2 :end end2)
- end2))
- (n2 (parse-integer string2 :start start2 :end lim2)))
- (cond ((< n1 n2) (return (values t nil)))
- ((> n1 n2) (return (values nil t))))
- (setf start1 lim1
- start2 lim2)))
- (t
- (let ((lim1 (or (position-if #'digit-char-p string1
- :start start1 :end end1)
- end1))
- (lim2 (or (position-if #'digit-char-p string2
- :start start2 :end end2)
- end2)))
- (cond ((string< string1 string2
- :start1 start1 :end1 lim1
- :start2 start2 :end2 lim2)
- (return (values t nil)))
- ((string> string1 string2
- :start1 start1 :end1 lim1
- :start2 start2 :end2 lim2)
- (return (values nil t))))
- (setf start1 lim1
- start2 lim2)))))))
-
-(defun domain-name< (name-a name-b)
- "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
-
- Split the names into labels at the dots, and then lexicographically
- compare the sequences of labels, right to left, using `natural-string<'.
-
- Returns two values: whether NAME-A strictly precedes NAME-B, and whether
- NAME-A strictly follows NAME-B."
- (let ((pos-a (length name-a))
- (pos-b (length name-b)))
- (loop (let ((dot-a (or (position #\. name-a
- :from-end t :end pos-a)
- -1))
- (dot-b (or (position #\. name-b
- :from-end t :end pos-b)
- -1)))
- (multiple-value-bind (precp follp)
- (natural-string< name-a name-b
- :start1 (1+ dot-a) :end1 pos-a
- :start2 (1+ dot-b) :end2 pos-b)
- (cond (precp
- (return (values t nil)))
- (follp
- (return (values nil t)))
- ((= dot-a -1)
- (let ((eqp (= dot-b -1)))
- (return (values (not eqp) nil))))
- ((= dot-b -1)
- (return (values nil t)))
- (t
- (setf pos-a dot-a
- pos-b dot-b))))))))
+(deftype octet () '(unsigned-byte 8))
+(deftype octet-vector (&optional n) `(array octet (,n)))
+
+(defun decode-hex (hex &key (start 0) end)
+ "Decode a hexadecimal-encoded string, returning a vector of octets."
+ (let* ((end (or end (length hex)))
+ (len (- end start))
+ (raw (make-array (floor len 2) :element-type 'octet)))
+ (unless (evenp len)
+ (error "Invalid hex string `~A' (odd length)" hex))
+ (do ((i start (+ i 2)))
+ ((>= i end) raw)
+ (let ((high (digit-char-p (char hex i) 16))
+ (low (digit-char-p (char hex (1+ i)) 16)))
+ (unless (and high low)
+ (error "Invalid hex string `~A' (bad digit)" hex))
+ (setf (aref raw (/ (- i start) 2)) (+ (* 16 high) low))))))
+
+(defun slurp-file (file &optional (element-type 'character))
+ "Read and return the contents of FILE as a vector."
+ (with-open-file (in file :element-type element-type)
+ (let ((buf (make-array 1024 :element-type element-type))
+ (pos 0))
+ (loop
+ (let ((end (read-sequence buf in :start pos)))
+ (when (< end (length buf))
+ (return (adjust-array buf end)))
+ (setf pos end
+ buf (adjust-array buf (* 2 pos))))))))
+
+(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)))
+
+(defun hash-file (hash file context)
+ "Hash the FILE using the OpenSSL HASH function, returning an octet string.
+
+ CONTEXT is a temporary-files context."
+ (let ((temp (temporary-file context "hash")))
+ (run-program (list "openssl" "dgst" (concatenate 'string "-" hash))
+ :input file :output temp)
+ (with-open-file (in temp)
+ (let ((line (read-line in)))
+ (assert (and (>= (length line) 9)
+ (string= line "(stdin)= " :end1 9)))
+ (decode-hex line :start 9)))))