[clouchdb-cvs] CVS clouchdb/src

[peddy]

Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv27637/src

Modified Files:
	clouchdb.lisp 
Log Message:
Updated view functions to support CouchDb 8.0+ style views


--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2008/03/01 19:19:17	1.23
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2008/06/14 21:30:40	1.24
@@ -146,6 +146,12 @@
 		     (id condition))))
   (:documentation "Error raised when no document matching ID is found"))
 
+;; (define-condition ps-view-def-error (error)
+;;   ((ps-view-def :initarg :ps-view-def :reader ps-view-def))
+;;   (:report (lambda (condition stream)
+;;              (format stream "Invalid parenscript ps-view-def: \"~s\"" ps-view-def)))
+;;   (:documentation "Error raised for invalid ps-view definition"))
+
 ;;
 ;; Unexported utility functions
 ;;
@@ -162,19 +168,17 @@
         ((stringp value)
          (parse-integer value))))
 
-(defun string-join (list &optional (delim #\,)) 
-  "Join a bunch of strings into one with a delimiter. Implementation
-by Russel McManus on c.l.l."
-  (unless list (return-from string-join "")) 
-  (let ((out (make-array (1- (loop for s in list sum (1+ (length s)))) 
-                         :element-type 'character)) 
-        (start (length (car list)))) 
-    (setf (subseq out 0 (length (car list))) (car list)) 
-    (dolist (s (cdr list)) 
-      (setf (aref out start) delim 
-            (subseq out (+ 1 start) (+ 1 start (length s))) s 
-            start (+ 1 start (length s)))) 
-    out))
+(defun string-join (list &key (delim ",") (ignore-nil nil))
+  "Join list of strings into a single result. Strings are delimited by
+specified delimiter. If ignore-nil is true, then nil strings in the
+list are skipped, and no delimiter is output."
+  (with-output-to-string (out)
+    (loop for (element . more?) on list do
+         (unless (and (null element) ignore-nil)
+           (if element
+               (write-string element out))
+           (when more?
+             (write-string delim out))))))
 
 (defmacro cat (&rest rest)
   "Shorthand for (concatenate 'string)"
@@ -712,30 +716,45 @@
     (db-request (cat (url-encode *db-name*) "/_temp_view")
 		:method :post
                 :external-format-out +utf-8+
-		:content-type "text/javascript"
+		:content-type "application/json"
                 :content-length nil
                 :parameters (transform-params options *view-options*)
 		:content view)))
 
-(defun create-view (id &rest view-defs)
+(defun create-view (id view &key (language "javascript"))
+  "Create one or more views in the specified view document ID."
+  (ensure-db ()
+    (db-request (cat (url-encode *db-name*) "/_design/" (url-encode id))
+                :method :put
+                :external-format-out +utf-8+
+                :content-length nil
+                :content
+                (cat "{\"language\" : \"" language "\"," 
+                     "\"views\" : {" view "}}"))))
+
+(defun create-ps-view (id &rest view-defs)
   "Create one or more views in the specified view document ID."
-  (labels ((mk-view-js (views)
-	     (cond ((null views)
-		    nil)
-		   (t
-		    (let ((v (car views)))
-		      (cat "\"" (car v) "\" : \"" (cdr v) "\""
-			   (if (not (null (cdr views))) ", ")
-			   (mk-view-js (cdr views))))))))
-    (ensure-db ()
-      (db-request (cat (url-encode *db-name*) "/_design/" (url-encode id))
-		  :method :put
-                  :external-format-out +utf-8+
-                  :content-type "text/javascript"
-                  :content-length nil
-		  :content
-		  (cat "{\"language\" : \"text/javascript\"," 
-		       "\"views\" : {" (mk-view-js view-defs) "}}")))))
+  (create-view id (string-join view-defs)))
+
+(defmacro ps-view ((&optional view-name) &body body)
+  `(with-output-to-string (out)
+     (when ,view-name
+       (write-string (cat "\"" ,view-name "\":") out))
+     (write-string "{" out)
+     (write-string 
+      (string-join
+       (list 
+         ,@(mapcar #'(lambda (fn)
+                       (destructuring-bind (defun fn-name fn-param fn-body) fn
+                         (declare (ignore defun))
+                         `(cat "\"" 
+                               (string-downcase (symbol-name (quote ,fn-name)))
+                               "\": \""
+                               (parenscript::ps (lambda (, at fn-param) ,fn-body))
+                               "\"")))
+                   body))
+       :ignore-nil t) out)
+     (write-string "}" out)))
 
 (defun delete-view (id &key revision if-missing)
   "Delete identified view document"