[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Fri Dec 21 19:58:32 UTC 2007
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv32651/src
Modified Files:
tests.lisp package.lisp examples.lisp encoder.lisp
clouchdb.lisp changelog.txt
Log Message:
Field name encoding updates, documentation reflecting those changes
--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2007/12/18 21:33:34 1.6
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2007/12/21 19:58:31 1.7
@@ -125,31 +125,39 @@
(: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"))))
+ (document-property "name" '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3"))))
(ensure-same "name2"
- (document-property "Name" '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+ (document-property "Name" '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3"))))
(ensure-same "name3"
- (document-property "NaMe" '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "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"))))
+ (document-property :NAME '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3"))))
(ensure-same "name2"
- (document-property :*NAME '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+ (document-property :-NAME '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3"))))
(ensure-same "name3"
- (document-property :*NA-ME'((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "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"))))
+ (document-property 'name '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3"))))
(ensure-same "name2"
- (document-property '*name '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3"))))
+ (document-property '-name '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3"))))
(ensure-same "name3"
- (document-property '*na-me '((:NAME . "name1") (:*NAME . "name2") (:*NA-ME . "name3")))))
+ (document-property '-na-me '((:NAME . "name1") (:-NAME . "name2") (:-NA-ME . "name3")))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Test case-encoded field name functions")
+ general-tests-case-encoded
+ (ensure-same "lowercase" (as-field-name-string (as-keyword-symbol "lowercase")))
+ (ensure-same "MixedCase" (as-field-name-string (as-keyword-symbol "MixedCase")))
+ (ensure-same "Mixed-Case-Hyphen" (as-field-name-string (as-keyword-symbol "Mixed-Case-Hyphen")))
+ (ensure-same "UPPER-CASE" (as-field-name-string (as-keyword-symbol "UPPER-CASE"))))
;;
;; Db Administration Tests
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2007/12/17 13:58:32 1.2
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2007/12/21 19:58:32 1.3
@@ -30,6 +30,8 @@
:*host*
:*port*
:*db-name*
+ :as-keyword-symbol
+ :as-field-name-string
:db-existential-error
:db-does-not-exist
:db-already-exists
--- /project/clouchdb/cvsroot/clouchdb/src/examples.lisp 2007/12/17 23:22:23 1.4
+++ /project/clouchdb/cvsroot/clouchdb/src/examples.lisp 2007/12/21 19:58:32 1.5
@@ -95,15 +95,15 @@
;; Strings may be used for field names instead of symbols when
;; submitting documents. Fetched documents will always have
;; symbols for field names regardless of how they were created.
- (create-document '(("name" . "Czech Republic")
- ("tags" . ("country" "european"))
- ("motto" . "Truth prevails")
- ("demographics" . ((:population . 10230000)
- ;; A nested map property:
- (:religion . ((:agnostic . 0.59)
- (:roman-catholic . 0.26)
- (:protestant . 2.5)))
- (:political-system . "democracy"))))
+ (create-document '((:name . "Czech Republic")
+ (:tags . ("country" "european"))
+ (:motto . "Truth prevails")
+ (:demographics . ((:population . 10230000)
+ ;; A nested map property:
+ (:religion . ((:agnostic . 0.59)
+ (:roman-catholic . 0.26)
+ (:protestant . 2.5)))
+ (:political-system . "democracy"))))
:id "czechrepublic")
;; Create a persistant view that retrieves documents by their
;; tags. Views can also be queried with a browser at:
--- /project/clouchdb/cvsroot/clouchdb/src/encoder.lisp 2007/12/20 23:57:09 1.2
+++ /project/clouchdb/cvsroot/clouchdb/src/encoder.lisp 2007/12/21 19:58:32 1.3
@@ -23,12 +23,10 @@
;;; DEALINGS IN THE SOFTWARE.
;; The encoder in the cl-json package didn't work the way I needed it
-;; to, hence this code which is partially stolen from that package.
+;; to, hence this code which is mostly stolen from that package.
(in-package :clouchdb)
-(defparameter *symbol-to-string-fn* #'js::symbol-to-js)
-
(defparameter *json-lisp-escaped-chars*
`((#\" . #\")
(#\\ . #\\)
@@ -39,6 +37,98 @@
(#\r . #\Return)
(#\t . #\Tab)))
+;; (defun val-to-string (val)
+;; (if (symbolp val)
+;; (string-downcase (symbol-name val))
+;; (princ-to-string val)))
+
+;; (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil))
+;; (do ((len (length string))
+;; (i 0 (1+ i))
+;; (last 0)
+;; res)
+;; ((= i len)
+;; (let ((split (if (> i last)
+;; (cons (subseq string last i) res)
+;; res)))
+;; (nreverse (if remove-empty-subseqs
+;; (delete "" split :test #'string-equal)
+;; split))))
+;; (when (member (char string i) separators)
+;; (push (subseq string last i) res)
+;; (when keep-separators (push (string (char string i)) res))
+;; (setf last (1+ i)))))
+
+;; (defparameter *special-chars*
+;; '((#\! . "Bang")
+;; (#\? . "What")
+;; (#\# . "Hash")
+;; (#\@ . "At")
+;; (#\% . "Percent")
+;; (#\+ . "Plus")
+;; (#\* . "Star")
+;; (#\/ . "Slash")))
+
+;;; Parenscript-style symbol -> Javascript-style symbol
+
+;; (defun constant-string-p (string)
+;; (let ((len (length string))
+;; (constant-chars '(#\+ #\*)))
+;; (and (> len 2)
+;; (member (char string 0) constant-chars)
+;; (member (char string (1- len)) constant-chars))))
+
+;; (defun first-uppercase-p (string)
+;; (and (> (length string) 1)
+;; (member (char string 0) '(#\+ #\*))))
+
+;; (defun untouchable-string-p (string)
+;; (and (> (length string) 1)
+;; (char= #\: (char string 0))))
+
+;; (defun symbol-to-js (symbol)
+;; "Given a Lisp symbol or string, produces to a valid JavaScript
+;; identifier by following transformation heuristics case conversion. For
+;; example, paren-script becomes parenScript, *some-global* becomes
+;; SOMEGLOBAL. (stolen from parenscript)"
+;; (when (symbolp symbol)
+;; (setf symbol (symbol-name symbol)))
+;; (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
+;; (cond ((null symbols) "")
+;; ((= (length symbols) 1)
+;; (let (res
+;; (do-not-touch nil)
+;; (lowercase t)
+;; (all-uppercase nil))
+;; (cond ((constant-string-p symbol)
+;; (setf all-uppercase t
+;; symbol (subseq symbol 1 (1- (length symbol)))))
+;; ((first-uppercase-p symbol)
+;; (setf lowercase nil
+;; symbol (subseq symbol 1)))
+;; ((untouchable-string-p symbol)
+;; (setf do-not-touch t
+;; symbol (subseq symbol 1))))
+;; (flet ((reschar (c)
+;; (push (cond
+;; (do-not-touch c)
+;; ((and lowercase (not all-uppercase))
+;; (char-downcase c))
+;; (t (char-upcase c)))
+;; res)
+;; (setf lowercase t)))
+;; (dotimes (i (length symbol))
+;; (let ((c (char symbol i)))
+;; (cond
+;; ((eql c #\-)
+;; (setf lowercase (not lowercase)))
+;; ((assoc c *special-chars*)
+;; (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
+;; (reschar i)))
+;; (t (reschar c))))))
+;; (coerce (nreverse res) 'string)))
+;; (t (string-join (mapcar #'symbol-to-js symbols) "")))))
+
(defun lisp-special-char-to-json (lisp-char)
(car (rassoc lisp-char *json-lisp-escaped-chars*)))
@@ -72,7 +162,10 @@
(cond
((null symbol) (write-json-chars "null" stream))
((eq 't symbol) (write-json-chars "true" stream))
- (t (write-json-string (funcall *symbol-to-string-fn* symbol) stream))))
+ (t (write-json-string (as-field-name-string symbol) stream))))
+
+;; (t (write-json-string (symbol-to-js symbol) stream))))
+;; (t (write-json-string (funcall *symbol-to-string-fn* symbol) stream))))
(defun keyword-assocp (e)
"Return true if element is a list that begins with a keyword. This
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/20 23:40:29 1.12
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/21 19:58:32 1.13
@@ -223,10 +223,6 @@
associative list or hashtable, to json data"
(encode-document doc))
-;; (cond ((listp doc)
-;; (json:encode-json-alist-to-string doc))
-;; (t
-;; (json:encode-json-to-string doc))))
(defun document-as-hash (doc)
"Convert a document to a hashtable if it isn't one already. Document
@@ -247,35 +243,51 @@
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\""
+Stolen from the cl-json library since it's not exported from
+there. Examples: \"camelCase\" -> \"CAMEL-CASE\", \"CamelCase\" ->
+\"*CAMEL-CASE\", \"dojo.widget.TreeNode\" ->
+\"DOJO.WIDGET.*TREE-NODE\""
+ (with-output-to-string (out)
+ (loop for ch across string
+ do
+ (when (upper-case-p ch)
+ (write-char #\- out))
+ (write-char (char-upcase ch) out))))
+
+(defun lisp-to-camel-case (string)
+ "Reverses the output of camel-case-to-lisp"
(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))))
+ with last-char do
+ (cond ((char= #\- ch)
+ (if (and last-char (char= #\- last-char))
+ (write-char #\- out)))
+ (t (write-char (if (and last-char (char= #\- last-char))
+ (char-upcase ch)
+ (char-downcase 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)
+ (cond ((stringp value)
(intern (camel-case-to-lisp value) "KEYWORD"))
+ ((keywordp value)
+ value)
((symbolp value)
- (as-keyword-symbol (intern (symbol-name value) "KEYWORD")))))
+ (as-keyword-symbol (intern (symbol-name value) "KEYWORD")))
+ (t value)))
+
+(defun as-field-name-string (value)
+ "Convert a case-encoded symbol to a potentially mixed case string."
+ (cond ((symbolp value)
+ (lisp-to-camel-case (symbol-name value)))
+ (t value)))
(defun document-property (name doc)
"Get the value associated with the document property or nil if there
@@ -302,9 +314,10 @@
(apply #'drakma:http-request (make-uri uri) keys)
;; (format t " -> uri: ~S~%" uri)
;; (format t " -> headers: ~S~%" headers)
- (if must-close
- (json:decode-json-from-string body)
- nil))))
+ (cond (must-close
+;; (format t "body: ~S~%" body)
+ (json:decode-json-from-string body))
+ (t nil)))))
;;
;;
--- /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2007/12/18 18:20:09 1.5
+++ /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2007/12/21 19:58:32 1.6
@@ -1,4 +1,11 @@
+0.0.7:
+ - Copied and modified cl-json encoding functions to better handle
+ conversion of lisp associative lists to json data types.
+ - Updated documentation to recommend using only keyword symbols for
+ field names.
+ - Export
+
0.0.6:
- Finally fixed utf-8 encoding bug for document contents
- Revised document ID encoding to 1) Support utf-8 characters
More information about the clouchdb-cvs
mailing list