RailsOnLisp/rol-uri

diff --git a/expand.lisp b/expand.lisp
new file mode 100644
index 0000000..4095a7f
--- /dev/null
+++ b/expand.lisp
@@ -0,0 +1,71 @@
+(defvar *op*)
+(defvar *uri-env*)
+(defvar *separator*)
+
+(defgeneric expand-value (x))
+
+
+(defun expand-uri-template (template &optional env)
+  (macrolet ((op (op &body body) `(let ((*op* ,op)) ,@body))
+	     (var (sym) `(expand-value (getf *uri-env* ,sym)))
+	     (explode (var) `(let ((*separator* (op-explode-separator *op*)))
+			       ,var)))
+    (flet ((prefix (n s) (if (<= (length s) n) s (subseq s 0 n))))
+      (let ((*op* nil)
+	    (*separator* #\,)
+	    (*uri-env* env))
+	(uri-template-parts template)))))
+
+(defgeneric expand-value (x)
+  (:documentation "Returns the expansion of X as a string"))
+
+(defmethod expand-value ((x string))
+  x)
+
+(defun join-alist (alist joiner)
+  (with-output-to-string (out)
+    (format out "~A=~A" (caar alist) (cdar alist))
+    (dolist (i (cdr alist))
+      (format out "~A~A=~A" joiner (car i) (cdr i)))))
+
+(defun join-list (list joiner)
+  (with-output-to-string (out)
+    (format out "~A" (first list))
+    (dolist (i (cdr list))
+      (format out "~A~A" joiner i))))
+
+(defmethod expand-value ((x cons) (joiner character))
+  (if (consp (car x))
+      (join-alist x joiner)
+      (join-list x joiner)))
+
+(defun var (name &key prefix explode)
+  (declare (type symbol name))
+  (cond (prefix (prefix (var name :explode explode) prefix))
+	(explode (explode (var name :prefix prefix)))
+	(t (getf *env* name))))
+
+(defun op (*op* &rest vars)
+  (declare (type character *op*))
+  (when *op* (write-char *op*))
+  (dolist (v vars)
+    (destructuring-bind (f &rest args) v
+      (declare (type (member var) f))
+      (apply (symbol-function f) args))))
+
+(defun uri-template-expand (template &optional stream)
+  (if (null stream)
+      (with-output-to-string (s) (uri-template-expand template s))
+      (dolist (part (uri-template-parts template))
+	(typecase part
+	  (string (write-string part stream))
+	  (cons (destructuring-bind (f &rest args) part
+		  (declare (type (member op) f))
+		  (apply (symbol-function f) args)))))))
+
+(defmacro uri-template-bind ((template target) &body body)
+  (multiple-value-bind (regex vars) (uri-template-regex template)
+    `(cl-ppcre:register-groups-bind
+	 ,vars
+	 (',regex ,target)
+       ,@body)))
diff --git a/pstr.lisp b/pstr.lisp
new file mode 100644
index 0000000..d6eca6f
--- /dev/null
+++ b/pstr.lisp
@@ -0,0 +1,61 @@
+
+;;  pstr
+
+(defstruct pstr
+  (str "" :type string :read-only t)
+  (pos 0 :type positive-fixnum))
+
+(defmacro with-pstr ((str pos) x &body body)
+  (let ((g!pstr (gensym "PSTR-")))
+    `(let ((,g!pstr ,x))
+       (let ((,str (pstr-str ,g!pstr))
+	     (,pos (pstr-pos ,g!pstr)))
+	 ,@body))))
+
+(defun pstr-copy (x)
+  (declare (type pstr x))
+  (make-pstr :str (pstr-str x) :pos (pstr-pos x)))
+
+(defun pstr-eat-n (x n)
+  (declare (type pstr x)
+	   (type positive-fixnum n))
+  (when (< (length (pstr-str x)) (+ (pstr-pos x) n))
+    (error "pstr-eat-n past end of string"))
+  (incf (pstr-pos x) n)
+  x)
+
+(defun pstr-peek (x &optional (n 0))
+  (with-pstr (s p) x
+    (let ((i (+ p n)))
+      (when (< i (length s))
+	(char s i)))))
+
+(defun pstr-eat-char (x char)
+  (when (char= char (pstr-peek x))
+    (pstr-eat-n x 1)
+    char))
+
+(defun pstr-eat-string (x string)
+  (with-pstr (s p) x
+    (let* ((len (length string))
+	   (e (+ p len)))
+      (when (and (<= e (length s))
+		 (string= s string :start1 p :end1 e))
+	(pstr-eat-n x len)
+	string))))
+
+(define-constant +hexdigits+ "0123456789ABCDEFabcdef"
+  :test 'string=)
+
+(defun pstr-eat-pct-encoded (x)
+  (when (and (char= #\% (pstr-peek x))
+	     (find (pstr-peek x 1) +hexdigits+)
+	     (find (pstr-peek x 2) +hexdigits+))
+    (with-pstr (s p) x
+      (prog1 (parse-integer s :start p :end (+ 2 p) :radix 16)
+	(pstr-eat-n x 3)))))
+
+(defun pstr-eat-if (n fn x)
+  (when-let ((r (funcall fn (pstr-peek x))))
+    (pstr-eat x n)
+    r))