[clouchdb-cvs] CVS clouchdb/src

[peddy]

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

Modified Files:
	tests.lisp clouchdb.lisp 
Log Message:
Added support to document-property for using strings, keyword symbols
or regular symgbols for field name, added tests for this feature


--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp	2007/12/18 17:26:56	1.5
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp	2007/12/18 21:33:34	1.6
@@ -89,16 +89,6 @@
 		     (push d results))))))
     results))
 
-;; (defun create-view-test2 ()
-;;   "Create a view that uses a key query param"
-;;   (create-test-documents *people*)
-;;   (create-view "key-view"
-;; 	       (cons "friendof"
-;; 		     (ps (lambda (doc)
-;; 			   (with-slots (friends) doc
-;; 			     (dolist (friend friends)
-;; 			       (map friend doc))))))))
-
 ;;
 ;; Database API Tests
 ;;
@@ -115,6 +105,53 @@
    (*protocol* "http")))
 
 ;;
+;; General tests that do not require a db connection
+;;
+
+(deftestsuite clouchdb-general-tests (clouchdb-tests) () ())
+
+(addtest (clouchdb-general-tests)
+  (:documentation "Test document-property")
+  general-tests-document-property
+  (ensure
+   (let ((doc '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "NaMe"))))
+     (reduce #'(lambda (a b) (and a b))
+             (mapcar #'(lambda (e)
+                         (equal (cdr (assoc (car e) doc))
+                                (document-property (car e) doc)))
+                     doc)))))
+
+(addtest (clouchdb-general-tests)
+  (:documentation "Test document-property using property name strings")
+  general-tests-document-property-string
+  (ensure-same "name1"
+               (document-property "name" '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+  (ensure-same "name2"
+               (document-property "Name" '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+  (ensure-same "name3"
+               (document-property "NaMe" '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3")))))
+
+(addtest (clouchdb-general-tests)
+  (:documentation "Test document-property using keyword symbols")
+  general-tests-document-property-keyword
+  (ensure-same "name1"
+               (document-property :NAME '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+  (ensure-same "name2"
+               (document-property :*NAME '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+  (ensure-same "name3"
+               (document-property :*NA-ME'((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3")))))
+
+(addtest (clouchdb-general-tests)
+  (:documentation "Test document-property using non-keyword symbols")
+  general-tests-document-property-symbol
+  (ensure-same "name1"
+               (document-property 'name '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+  (ensure-same "name2"
+               (document-property '*name '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+  (ensure-same "name3"
+               (document-property '*na-me '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3")))))
+
+;;
 ;; Db Administration Tests
 ;;
 ;; Test the APIs that create, delete, and get information about
@@ -501,7 +538,8 @@
 ;;
 
 (defun run-all-tests ()
-  (dolist (suite '(clouchdb-db-admin-tests
+  (dolist (suite '(clouchdb-general-tests
+                   clouchdb-db-admin-tests
 		   clouchdb-doc-api-tests
 		   clouchdb-view-tests))
     (format t "~S~%" (run-tests :suite suite))))
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2007/12/18 18:09:53	1.10
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2007/12/18 21:33:34	1.11
@@ -245,18 +245,52 @@
 	   new-doc))
 	(t doc)))
 
+
+(defun camel-case-to-lisp (string)
+  "Converts a string in camelCase to the same lisp-friendly syntax used in parenscript.
+Stolen from the cl-json library since it's not exported. Examples:
+\"camelCase\" -> \"CAMEL-CASE\", \"CamelCase\" -> \"*CAMEL-CASE\",
+\"dojo.widget.TreeNode\" -> \"DOJO.WIDGET.*TREE-NODE\""
+  (with-output-to-string (out)
+    (loop for ch across string
+          with last-char do
+          (if (upper-case-p ch)
+              (progn 
+                (if (and last-char (lower-case-p last-char))
+                    (write-char #\- out)
+                    (write-char #\* out))
+                (write-char ch out))
+              (write-char (char-upcase ch) out))
+          (setf last-char ch))))
+
+(defun as-keyword-symbol (value)
+  "Return value in a form that would be used to identify the car of a
+value in a document. For example, a value of \"FIELD-NAME\" would
+return :FIELD-NAME, 'FIELD-NAME would become :FIELD-NAME, and
+\"Field-Name\" would become \":*FIELD-NAME\"."
+  (cond ((keywordp value)
+         value)
+        ((stringp value)
+         (intern (camel-case-to-lisp value) "KEYWORD"))
+        ((symbolp value)
+         (as-keyword-symbol (intern (symbol-name value) "KEYWORD")))))
+
 (defun document-property (name doc)
-  "Get the value associated with the document property or nil"
-  (cond ((hash-table-p doc)
-	 (gethash name doc))
-	(t (cdr (assoc name doc)))))
+  "Get the value associated with the document property or nil if there
+is no associated value. Note that name may be either a keyword symbol,
+a regular symbol or a string."
+  (let ((name (as-keyword-symbol name)))
+    (cond ((hash-table-p doc)
+           (gethash name doc))
+          (t (cdr (assoc name doc))))))
 
 (defun (setf document-property) (value name doc)
   "Allows setting of document properties in place (destructively)."
-  (cond ((hash-table-p doc)
-	 (setf (gethash name doc) value))
-	(t (rplacd (assoc name doc) value)))
-  value)
+  (let ((name (as-keyword-symbol name)))
+    (cond ((hash-table-p doc)
+           (setf (gethash name doc) value))
+          (t (rplacd (assoc name doc) value)))
+    value))
 
 (defun db-request (uri &rest keys &key &allow-other-keys)
   "Used by all Couchdb APIs to make the actual REST request."