[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Mon Jul 20 21:32:53 UTC 2009
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory cl-net:/tmp/cvs-serv19281/src
Modified Files:
tests.lisp clouchdb.lisp
Log Message:
Added support to (document-property) and (setf (document-property)) to
allow gettting/setting/creating nested document property using a
property list. Added corresponding tests.
--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2009/07/18 21:14:49 1.26
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2009/07/20 21:32:52 1.27
@@ -143,19 +143,139 @@
(document-property (car e) doc)))
doc)))))
+;;
+;; (document-property) tests
+;;
+
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Test accessing document property with property list")
+ general-tests-document-property-single
+ (ensure-same 2
+ (document-property ':one
+ '((:one . 2) (:a . ((:b . ((:c . "found")))))))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Test accessing document property with property list")
+ general-tests-document-property-single-list
+ (ensure-same 2
+ (document-property '(:one)
+ '((:one . 2) (:a . ((:b . ((:c . "found")))))))))
+
(addtest (clouchdb-general-tests)
(:documentation "Test accessing document property with property list")
general-tests-document-property-list-access
(ensure-same "found"
(document-property '(:a :b :c)
- '((:one . 2)(:a . ((:b . ((:c . "found")))))))))
+ '((:one . 2) (:a . ((:b . ((:c . "found")))))))))
+
+;;
+;; (setf document-property) tests
+;;
(addtest (clouchdb-general-tests)
- (:documentation "Test accessing document property with property list")
+ (:documentation "Set existing document property with single property")
+ general-tests-document-property-modify
+ (let ((doc '((:one . 2) (:a . ((:b . ((:c . "not searched for"))))))))
+ (ensure-same "found"
+ (document-property :a
+ (setf (document-property :a doc) "found")))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Set existing document property with single element list property")
+ general-tests-document-property-single-list-modify
+ (let ((doc '((:one . 2) (:a . ((:b . ((:c . "not searched for"))))))))
+ (ensure-same "found"
+ (document-property
+ :a
+ (setf (document-property '(:a) doc) "found")))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Set existing document property with property list")
general-tests-document-property-list-modify
- (let ((doc '((:one . 2) (:a . ((:b . ((:c . "not found"))))))))
- (setf (document-property '(:a :b :c) doc) "found")
- (ensure-same "found" (document-property '(:a :b :c) doc))))
+ (let ((doc '((:one . 2) (:a . ((:b . ((:c . "not found")))))))
+ (properties '(:a :b :c)))
+ (ensure-same "found"
+ (document-property
+ properties
+ (setf (document-property properties doc) "found")))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Add top level document property
+ with (setf (document-property))")
+ general-tests-document-property-add-top-level
+ (let ((doc '((:one . 1) (:two . 2))))
+ (ensure-same 3 (document-property
+ :three
+ (setf (document-property :three doc) 3)))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Add document property list to document.")
+ general-tests-document-property-add-property-list
+ (let ((doc '((:one . 1) (:two . 2)))
+ (properties '(:three :four)))
+ (ensure-same 4
+ (document-property
+ properties
+ (setf (document-property properties doc) 4)))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Replace document property with nested property list.")
+ general-tests-document-property-replace-property-list
+ (let ((doc '((:one . 1) (:two . 2) (:three . 3)))
+ (properties '(:three :four)))
+ (ensure-same 4
+ (document-property
+ properties
+ (setf (document-property properties doc) 4)))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Change nested document property.")
+ general-tests-document-property-replace-property-list1
+ (let ((doc '((:one . 1) (:two . ((:four . ((:nine . 8))))) (:three . 3)))
+ (properties '(:two :four :nine)))
+ (ensure-same 9
+ (document-property
+ properties
+ (setf (document-property properties doc) 9)))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Truncate deep document property list.")
+ general-tests-document-property-replace-property-list2
+ (let ((doc '((:one . 1) (:two . ((:four . ((:nine . 9))))) (:three . 3)))
+ (properties '(:two :four)))
+ (ensure-same 4
+ (document-property
+ properties
+ (setf (document-property properties doc) 4)))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Create document with single property (setf (document-property))")
+ general-tests-document-property-create-property
+ (ensure-same 44
+ (document-property
+ :value
+ (setf (document-property ':value nil) 44))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Create document with property list (setf (document-property))")
+ general-tests-document-property-create-propert-list1
+ (ensure-same 44
+ (document-property
+ :value
+ (setf (document-property '(:value) nil) 44))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Create document with property list (setf (document-property))")
+ general-tests-document-property-create-propert-list-multi
+ (ensure-same 44
+ (document-property
+ '(:some :nested :value)
+ (setf (document-property '(:some :nested :value) nil) 44))))
+
+;;
+;;
+;;
(addtest (clouchdb-general-tests)
(:documentation "Test case-encoded field name functions")
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/07/18 21:14:49 1.43
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/07/20 21:32:53 1.44
@@ -277,7 +277,8 @@
((db-p input) (couchdb-database-url input))
(t (error 'invalid-type
:input input
- :description "Database must be a string or a database structure"))))
+ :description
+ "Database must be a string or a database structure"))))
(defun make-uri (&rest rest)
"Return a URI containing protocol://host:port/ and the concatenation
@@ -358,18 +359,42 @@
"Allows setting of existing document properties in
place (destructively). The name paramter may be either a single
keyword identifier (document property identifier) or it may be a list
-of identifiers."
- (let ((name (as-keyword-symbol name)))
- (cond ((listp name)
- (if (> (length name) 1)
- (setf (document-property (rest name)
- (document-property (car name) doc))
- value)
- (setf (document-property (car name) doc) value)))
- ((hash-table-p doc)
- (setf (gethash name doc) value))
- (t (rplacd (assoc name doc) value)))
- doc))
+of identifiers. If the specified document property does not already
+exist it is created."
+ (labels ((recursive-compose (pl val)
+ (if (null pl)
+ val
+ (list (cons (car pl)
+ (recursive-compose (cdr pl) val))))))
+ (let ((kw-name (as-keyword-symbol name)))
+ (cond ((and (listp name) (> (length name) 1))
+ (cond ((null (document-property (car name) doc))
+ ;; Specified property does not exist in current
+ ;; document, fill in potentially nested value.
+ (setf doc (nconc doc (recursive-compose name value))))
+ ((not (assoclp (document-property (car name) doc)))
+ ;; Value being set is replacing existing value
+ ;; which is not a more deeply nested document
+ ;; value.
+ (rplacd (assoc (as-keyword-symbol (car name)) doc)
+ (recursive-compose (rest name) value))
+ doc)
+ (t
+ (setf (document-property
+ (rest name)
+ (document-property (car name) doc))
+ value)
+ doc)))
+ ((listp name)
+ (setf (document-property (car name) doc) value))
+ ((hash-table-p doc)
+ (setf (gethash kw-name doc) value))
+ (t
+ (let ((v (assoc kw-name doc)))
+ (if (or (null v) (not (listp v)))
+ (setf doc (nconc doc (list (cons kw-name value))))
+ (rplacd v value))
+ doc))))))
(defun set-document-property (doc &rest args)
"Set a property of a document. If the named property does not exist,
@@ -377,9 +402,7 @@
destructively modify input document, so be sure to use return value."
(let ((doc (copy-tree doc)))
(loop for (name value) on args by #'cddr
- do (if (assoc name doc)
- (setf (document-property name doc) value)
- (setf doc (cons `(,(as-keyword-symbol name) . ,value) doc))))
+ do (setf doc (setf (document-property name doc) value)))
doc))
(defun document-id (doc)
@@ -473,7 +496,6 @@
(let ((*text-content-types* *text-types*))
(multiple-value-bind (body status headers uri stream must-close reason-phrase)
(apply #'drakma:http-request (make-uri uri) args)
- ;;(declare (ignore must-close reason-phrase stream uri headers status))
(when *debug-requests*
(format t "uri: ~s~%args: ~s~%must-close:~s~%reason-phrase:
~s~%status: ~s~%headers: ~s~%stream:~s~%body:~s~%" uri args
@@ -763,16 +785,17 @@
(setf doc (document-properties doc))))
(when attachments
(setf doc (cons (encode-attachments attachments) doc)))
- (let ((res (ensure-db () (db-request (cat (url-encode (db-name *couchdb*)) "/"
- (url-encode (if id id current-id)))
- :content-type "text/javascript"
- :external-format-out +utf-8+
- :content-length nil
- :content (document-to-json
- (document-update-notify
- (db-document-update-fn *couchdb*)
- doc))
- :method :put))))
+ (let ((res (ensure-db ()
+ (db-request (cat (url-encode (db-name *couchdb*)) "/"
+ (url-encode (if id id current-id)))
+ :content-type "text/javascript"
+ :external-format-out +utf-8+
+ :content-length nil
+ :content (document-to-json
+ (document-update-notify
+ (db-document-update-fn *couchdb*)
+ doc))
+ :method :put))))
(when (document-property :|error| res)
(error (if (equal "conflict" (document-property :|error| res))
'id-or-revision-conflict
@@ -913,7 +936,8 @@
(url-encode (value-as-string rev)))
:method :delete))))
(when (document-property :|error| res)
- (error 'doc-error :id id :reason (document-property :|reason| res)))
+ (error 'doc-error :id id
+ :reason (document-property :|reason| res)))
res)))
(cond ((stringp doc-or-id)
(del doc-or-id
@@ -1200,8 +1224,33 @@
:method :get
:parameters (transform-params options *view-options*))))
+(defun add-ps-fns (id type &rest list-defs)
+ "Add lists in list-defs to document identified by id. If the
+document does not exist, create it. If any list function definitions
+already exist in the document, update them."
+ (let* ((list-id (cat "_design/" id))
+ (doc (get-document list-id :if-missing :ignore)))
+ (dolist (list-def (mapcar #'json-to-document list-defs))
+ (setf doc (setf (document-property (list type (caar list-def)) doc)
+ (cdar list-def))))
+ (put-document doc :id list-id)))
+
+(defun add-ps-lists (id &rest list-defs)
+ "Add lists in list-defs to document identified by id. If the
+document does not exist, create it. If any list function definitions
+already exist in the document, update them."
+ (apply #'add-ps-fns id :|lists| list-defs))
-;; (defun add-ps-lists (id &rest list-defs)
-;; (let ((doc (get-document id :if-missing '((:lists)))))
-;; (put-document (set-document-property
-;; :id id
\ No newline at end of file
+(defun invoke-list (doc-id list-id)
+ ""
+ (multiple-value-bind (body status headers uri stream must-close reason-phrase)
+ (let ((url (make-uri (url-encode (db-name *couchdb*))
+ "/_design/"
+ (url-encode doc-id)
+ "/_list/"
+ (url-encode list-id))))
+ (format t "uri: ~S~%" url)
+ (drakma:http-request url))
+ (when stream
+ (close stream))
+ body))
\ No newline at end of file
More information about the clouchdb-cvs
mailing list