Permalink
Browse files

building tests; adding functionality

  • Loading branch information...
1 parent 8641124 commit 212cc6923ff9aaecb9620c0e344689967e28b704 fons committed Mar 28, 2010
Showing with 760 additions and 199 deletions.
  1. +21 −1 cl-mongo.asd
  2. +50 −0 src/bson-encode-container.lisp
  3. +19 −0 src/bson-regex.lisp
  4. +24 −18 src/bson.lisp
  5. +39 −12 src/db.lisp
  6. +0 −36 src/document.lisp
  7. +92 −0 src/mongo-syntax.lisp
  8. +80 −15 src/mongo.lisp
  9. +6 −4 src/packages.lisp
  10. +77 −46 src/pair.lisp
  11. +41 −22 src/shell.lisp
  12. +10 −0 test/package.lisp
  13. +160 −0 test/regression.lisp
  14. +58 −0 test/test-utils.lisp
  15. +83 −45 test/test.lisp
View
22 cl-mongo.asd
@@ -13,22 +13,26 @@
:depends-on (:uuid
:babel
:documentation-template
+ :lisp-unit
:usocket)
:serial t
:components
((:module "src"
:serial t
:components ((:file "packages")
(:file "octets")
+ (:file "pair")
(:file "encode-float")
(:file "bson-oid")
(:file "bson-binary")
(:file "bson-time")
+ (:file "bson-regex")
(:file "bson-code")
- (:file "pair")
(:file "bson")
(:file "bson-array")
(:file "document")
+ (:file "mongo-syntax")
+ (:file "bson-encode-container")
(:file "protocol")
(:file "mongo")
(:file "db")
@@ -37,6 +41,22 @@
(:static-file "README.md")
(:static-file "COPYING")))
+(asdf:defsystem cl-mongo-test
+ :name "cl-mongo"
+ :author "Fons Haffmans; fons.haffmans@gmail.com"
+ :version "0.0.1"
+ :licence "MIT"
+ :description "tesing cl-mongo"
+ :depends-on (:cl-mongo)
+ :serial t
+ :components
+ ((:module "test"
+ :serial t
+ :components ((:file "package")
+ (:file "test-utils")
+ (:file "regression")))))
+
+
View
50 src/bson-encode-container.lisp
@@ -0,0 +1,50 @@
+(in-package :cl-mongo)
+
+
+(defgeneric bson-encode-container ( container &key )
+ (:documentation "encode a container of key-value pairs.."))
+
+(defmethod bson-encode-container ( (container pair) &key (array nil) (size 10) )
+ (bson-encode-container (kv->ht container) :array array :size size))
+
+(defmethod bson-encode-container ( (container (eql nil) ) &key (array nil) )
+ (bson-encode nil nil :array array))
+
+(defmethod bson-encode-container ( (container document) &key (array nil) (size 10) )
+ (setf (gethash "_id" (elements container)) (_id container))
+ (bson-encode-container (elements container) :array array :size size))
+
+(defmethod bson-encode-container ( (container hash-table) &key (array nil) (size nil) )
+ (let* ((size (or size 10))
+ (array (or array (make-octet-vector size))))
+ (add-octets (int32-to-octet 0) array )
+ (with-hash-table-iterator (iterator container)
+ (dotimes (repeat (hash-table-count container))
+ (multiple-value-bind (exists-p key value) (iterator)
+ (if exists-p (add-octets (bson-encode key value) array :start 4 :from-end 1)))))
+ (normalize-array array)))
+
+(defmethod bson-encode-container ( (kv-container kv-container) &key (array nil) (size nil) )
+ (let* ((size (or size 10))
+ (array (or array (make-octet-vector size))))
+ (add-octets (int32-to-octet 0) array )
+ (dotimes (index (kv-container-length kv-container))
+ (multiple-value-bind (key value) (kv-container-kv index kv-container)
+ (add-octets (bson-encode key value) array :start 4 :from-end 1)))
+ (normalize-array array)))
+
+(defmethod bson-encode-container ( (kv pair) &key )
+ (bson-encode (pair-key kv) (pair-value kv)))
+
+(defmethod bson-encode ( (key string) (value hash-table) &key )
+ (bson-encode key (bson-encode-container value :array (make-octet-vector (* (hash-table-count value) 12)))))
+
+(defmethod bson-encode ( (key string) (value document) &key )
+ (bson-encode key (bson-encode-container value )))
+
+(defmethod bson-encode ( (key string) (value kv-container) &key )
+ (bson-encode key (bson-encode-container value )))
+
+
+(defmethod bson-encode ( (key string) (value pair) &key )
+ (bson-encode key (bson-encode-container value)))
View
19 src/bson-regex.lisp
@@ -0,0 +1,19 @@
+(in-package :cl-mongo)
+
+(defclass bson-regex()
+ ((regex :reader regex :initarg :regex)
+ (options :reader options :initarg :options)))
+
+(defun make-bson-regex (regex options)
+ (make-instance 'bson-regex :regex regex :options options))
+
+(defmethod print-object ((bson-regex bson-regex) stream)
+ (format stream "~S [/~A/~A] ~%" (type-of bson-regex)
+ (if (slot-boundp bson-regex 'regex)
+ (regex bson-regex)
+ "regex not set..")
+ (if (slot-boundp bson-regex 'options)
+ (options bson-regex)
+ "options not set..")))
+
+
View
42 src/bson.lisp
@@ -11,6 +11,7 @@
(defconstant +bson-data-boolean+ 8 "bson boolean encoding")
(defconstant +bson-data-date+ 9 "bson date encoding")
(defconstant +bson-data-null+ 10 "bson null encoding")
+(defconstant +bson-data-regex+ 11 "bson regex encoding")
(defconstant +bson-data-code+ 13 "bson code encoding")
(defconstant +bson-data-int32+ 16 "bson 32 bit int encoding")
(defconstant +bson-data-long+ 18 "bson 64 bit int encoding")
@@ -42,11 +43,12 @@ clashed with the encoding for booleans..
(:documentation "encode a bson data element"))
(defmethod bson-encode( (key string) (value t) &key array type encoder)
+ ;(format t "89here~%")
(let* ((head (fill-pointer array))) ; save the stack pointer
(add-octets (int32-to-octet 0) array) ; length, set to zero
(add-octets (byte-to-octet type) array) ; data element code
(add-octets (string-to-null-terminated-octet key) array) ; key
- (funcall encoder array) ; call type sepcifi encoder
+ (funcall encoder array) ; call type specific encoder
(add-octets (byte-to-octet 0) array) ; ending nul
(set-octets head (int32-to-octet (- (length array) head) ) array) ; set length
array))
@@ -136,21 +138,33 @@ clashed with the encoding for booleans..
(call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
-(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
- (let ((array (or array (make-octet-vector +default-array-size+))))
- (labels ((encode-value (array)
- (add-octets (byte-to-octet (bool-to-byte value)) array))) ; add value
- (call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
+;(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
+; (let ((array (or array (make-octet-vector +default-array-size+))))
+; (labels ((encode-value (array)
+; (add-octets (byte-to-octet (bool-to-byte value)) array))) ; add value
+; (call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
;
; nil is the opposite of t, and is already mapped as a boolean. Also, there a seperate encoder
; for symbols, so something like the below won't work (and propably doesn't need to )
;(defmethod bson-encode ( (key string) (value (eql 'void)) &key (array nil) )
-; (let ((array (or array (make-octet-vector +default-array-size+))))
-; (labels ((encode-value (array)
-; array))
-; (call-next-method key value :array array :type +bson-data-null+ :encoder #'encode-value))))
+
+(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
+ (let ((array (or array (make-octet-vector +default-array-size+))))
+ (labels ((encode-value (array)
+ array))
+ (call-next-method key value :array array :type +bson-data-null+ :encoder #'encode-value))))
+
+(defmethod bson-encode ( (key string) (value bson-regex) &key (array nil) (type +bson-data-regex+) )
+ (let ((array (or array (make-octet-vector +default-array-size+))))
+ (labels ((encode-value (array)
+ ;; regex string, null terminated
+ (add-octets (string-to-null-terminated-octet (regex value)) array)
+ ;; options string, null terminated
+ (add-octets (string-to-null-terminated-octet (options value) ) array)
+ ))
+ (call-next-method key value :array array :type +bson-data-regex+ :encoder #'encode-value))))
;
; The array type is the parent class of other types like string. So see if a type and encoder is
@@ -301,11 +315,3 @@ clashed with the encoding for booleans..
;(push (list key value) accum))))
(push value accum))))
(values (reverse accum) rest)))
-
-
-
-
-
-
-
-
View
51 src/db.lisp
@@ -25,25 +25,29 @@ Since the default value of the limit is one, db.find by default is the equivalan
mongo documentation.
"))
-(defmethod db.find ( (collection symbol) (kv t)
- &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
- (db.find (string-downcase collection) kv
- :mongo mongo :options options :skip skip :limit limit :selector selector ))
-
(defmethod db.find ( (collection string) (kv t)
&key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
(let ((mongo (or mongo (mongo))))
(labels ((query ()
(mongo-message mongo (mongo-query
(full-collection-name mongo collection) kv
- :limit limit :skip skip :selector selector :options options))))
+ :limit limit
+ :skip skip
+ :selector (bson-encode-container (expand-selector selector))
+ :options options))))
(multiple-value-bind (header docs) (mongo-reply (query) :finalize 'to-document)
(list (append header (list collection)) docs)))))
+(defmethod db.find ( (collection symbol) (kv t)
+ &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
+ (db.find (string-downcase collection) kv
+ :mongo mongo :options options :skip skip :limit limit :selector selector ))
+
+
(defmethod db.find ( (collection string) (kv (eql :all))
- &key (mongo nil) (options 0) (skip 0) (selector nil) )
- (db.find collection (bson-encode nil nil)
- :mongo mongo :options options :skip skip :limit 0 :selector selector ))
+ &key (mongo nil) (options 0) (skip 0) (limit 0) (selector nil) )
+ (db.find collection (bson-encode "query" (kv nil nil))
+ :mongo mongo :options options :skip skip :limit limit :selector selector ))
(defmethod db.find ( (collection string) (kv integer)
&key (mongo nil) (options 0) (skip 0) (selector nil) )
@@ -60,6 +64,23 @@ mongo documentation.
(db.find collection (bson-encode-container kv)
:mongo mongo :options options :skip skip :limit limit :selector selector ))
+(defmethod db.find ( (collection string) (kv kv-container)
+ &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
+ (db.find collection (bson-encode-container kv)
+ :mongo mongo :options options :skip skip :limit limit :selector selector ))
+
+(defmacro db.sort (collection query &rest args)
+ "sort macro : Takes the same arguments and keywords as db.find but converts the query
+ so it works as a sort. use the :field keyword to select the field to sort on.
+ Set :asc to nil to reverse the sort order"
+ (let ((kv-query (gensym)))
+ `(destructuring-bind (&key (selector nil) (mongo nil)
+ (limit 0) (skip 0) (options 0) (field nil) (asc t))
+ (list ,@args)
+ (let ((kv-query (or (and (eql ,query :all) (kv nil nil)) ,query)))
+ (db.find ,collection (kv (kv "query" kv-query) (kv "orderby" (kv field (if asc 1 -1) )))
+ :limit limit :mongo mongo :skip skip :selector selector :options options)))))
+
(defgeneric db.update ( collection selector new-document &key )
(:documentation "In a collection update the document(s) identified by the selector statement.
@@ -175,7 +196,8 @@ You can enter a list of documents. In that the server will be contacted to delet
It may be more efficient to run a delete script on he server side.
"))
-(defmethod db.delete ( (collection (eql nil)) (document (eql nil)) &key))
+(defmethod db.delete ( (collection t) (document (eql nil)) &key (mongo nil) ))
+
(defmethod db.delete ( (collection string) (document document) &key (mongo nil))
(let ((mongo (or mongo (mongo) )))
@@ -287,6 +309,10 @@ For most commands you can just uses the key-value shown in the mongo documentati
(assert (not (null collection)))
(db.find "$cmd" (kv->ht (kv (kv "deleteIndexes" collection) (kv "index" index))) :mongo mongo))
+(defmethod db.run-command ( (cmd (eql :drop) ) &key (mongo nil) (collection nil) (index "*") )
+ (assert (not (null collection)))
+ (db.find "$cmd" (kv->ht (kv "drop" collection) ) :mongo mongo))
+
#|
@@ -315,7 +341,7 @@ all the documents in the collection.
(db.find "$cmd" (kv (kv "count" collection) (kv "query" selector) (kv "fields" nil)) :mongo mongo :limit 1))
(defmethod db.count ( (collection t) (selector (eql :all) ) &key (mongo nil) )
- (call-next-method collection nil :mongo mongo))
+ (db.count collection nil :mongo mongo))
(defmethod db.count ( (collection t) (selector pair ) &key (mongo nil) )
(call-next-method collection (kv->ht selector) :mongo mongo))
@@ -357,4 +383,5 @@ all the documents in the collection.
(retval (get-element "ok" (car (docs (db.find "$cmd" request :limit 1 :mongo mongo))))))
(if retval t nil)))
-
+;;(db.find "$cmd" (kv (kv "count" "foo") (kv "query" (kv nil nil)) (kv "fields" (kv nil nil))))
+;;(db.find "foo" (kv (kv "query" (kv nil nil)) (kv "orderby" (kv "k" 1)) ) :limit 0)
View
36 src/document.lisp
@@ -99,42 +99,6 @@ is supplied.
doc)))
-(defgeneric bson-encode-container ( container &key )
- (:documentation "encode a container of key-value pairs.."))
-
-;;(defmethod bson-encode-container ( (container array) )
-;; container)
-(defmethod bson-encode-container ( (container pair) &key (array nil) (size 10) )
- (bson-encode-container (kv->ht container) :array array :size size))
-
-(defmethod bson-encode-container ( (container document) &key (array nil) (size 10) )
- (setf (gethash "_id" (elements container)) (_id container))
- (bson-encode-container (elements container) :array array :size size))
-
-(defmethod bson-encode-container ( (container hash-table) &key (array nil) (size nil) )
- (let* ((size (or size 10))
- (array (or array (make-octet-vector size))))
- (add-octets (int32-to-octet 0) array )
- (with-hash-table-iterator (iterator container)
- (dotimes (repeat (hash-table-count container))
- (multiple-value-bind (exists-p key value) (iterator)
- (if exists-p (add-octets (bson-encode key value) array :start 4 :from-end 1)))))
- (normalize-array array)))
-
-(defmethod bson-encode ( (key string) (value hash-table) &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type nil) (encoder nil))
- (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
- (ignore size-supplied-p) (ignore array-supplied-p) )
- (bson-encode key (bson-encode-container value :array (make-octet-vector (* (hash-table-count value) 12)))))
-
-(defmethod bson-encode ( (key string) (value document) &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type nil) (encoder nil))
- (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
- (ignore size-supplied-p) (ignore array-supplied-p) )
- (bson-encode key (bson-encode-container value )))
-
(defgeneric doc-elements (document) )
(defmethod doc-elements ( (document hash-table) )
View
92 src/mongo-syntax.lisp
@@ -0,0 +1,92 @@
+(in-package :cl-mongo)
+
+(defmacro construct-$+- (val arg &rest args)
+ (let ((kvc (gensym)))
+ `(let ((kvc (kv ,arg ,val)))
+ (dolist (el (list ,@args))
+ (setf kvc (kv kvc (kv el ,val))))
+ kvc)))
+
+(defmacro $- (arg &rest args)
+ `(construct-$+- 0 ,arg ,@args))
+
+(defmacro $+ (arg &rest args)
+ `(construct-$+- +1 ,arg ,@args))
+
+(defmacro expand-selector (&rest args)
+ `(let ((result ,@args))
+ (cond ( (typep result 'kv-container) result)
+ ( (typep result 'pair) result)
+ ( (null result) result)
+ ( t ($+ result)))))
+
+(defun op-split (lst &optional (accum ()))
+ (if (null (cdr lst))
+ (values (nreverse accum) (car lst))
+ (op-split (cdr lst) (cons (car lst) ))))
+
+(defun unwrap (lst)
+ (if (cdr lst)
+ lst
+ (unwrap (car lst))))
+
+(defmacro $op* (op &rest args)
+ (let ((keys (gensym))
+ (key (gensym))
+ (kvc (gensym))
+ (val (gensym)))
+ `(multiple-value-bind (keys val) (op-split (unwrap (list ,@args)))
+ (let ((kvc (kv (car keys) (kv ,op val))))
+ (dolist (key (cdr keys))
+ (setf kvc (kv kvc (kv key (kv ,op val)))))
+ kvc))))
+(defun map-reduce-op (op lst)
+ (reduce (lambda (x y) (kv x y) ) (mapcar (lambda (l) ($op* op l) ) lst)))
+
+(defmacro $op (op &rest args)
+ `(cond ( (consp (car ',args)) (map-reduce-op ,op ',args))
+ ( t ($op* ,op ',args))))
+
+(defmacro $> (&rest args)
+ `($op "$gt" ,@args))
+
+(defmacro $>= (&rest args)
+ `($op "$gte" ,@args))
+
+(defmacro $< (&rest args)
+ `($op "$lt" ,@args))
+
+(defmacro $<= (&rest args)
+ `($op "$lte" ,@args))
+
+(defmacro $!= (&rest args)
+ `($op "$ne" ,@args))
+
+(defmacro $in (&rest args)
+ `($op "$in" ,@args))
+
+(defmacro $!in (&rest args)
+ `($op "$nin" ,@args))
+
+(defmacro $mod (&rest args)
+ `($op "$mod" ,@args))
+
+(defmacro $all (&rest args)
+ `($op "$all" ,@args))
+
+(defmacro $exists (&rest args)
+ `($op "$exists" ,@args))
+
+(defun empty-str(str)
+ (if (and str (zerop (length str)))
+ (format nil "\"\"")
+ str))
+
+(defmacro $/ (regex options)
+ `(make-bson-regex (empty-str ,regex) ,options))
+
+
+
+;($op "$gte" "k" "l" 5)
+;($op "$gte" '("k" "l" 5))
+;($tbd op ("l" "m" 60) ("k" 3))
View
95 src/mongo.lisp
@@ -81,10 +81,11 @@ Each connection is a added to a global registry."))
(usocket:socket-stream (socket mongo)))
(defgeneric mongo (&key host port db name)
- (:documentation " This method returns the connection referred to by the name identifier from
-the connection registry. The connection name is unique.
-If no connection with that name exists, a new connection with the supplied or default host, port and db
-parameters will be created. The default host is localhost; the default port is 27017; the default db is admin."))
+ (:documentation " This method returns the connection referred to by
+the name identifier from the connection registry. The connection name is unique.
+If no connection with that name exists, a new connection with the supplied or default
+host, port and db parameters will be created. The default host is localhost;
+the default port is 27017; the default db is admin."))
(defmethod mongo ( &key (host *mongo-default-host*) (port *mongo-default-port*)
(db *mongo-default-db*) (name :default) )
@@ -100,8 +101,8 @@ parameters will be created. The default host is localhost; the default port is
(defgeneric mongo-close ( name )
(:documentation "Close the connection to the mongo database.
The name should uniquely identify the connection to close.
-This is either a mongo object or the name the object is bound to in the connection registry.
-To close all open connections use the special symbol 'all"))
+This is either a mongo object or the name the object is bound to
+in the connection registry. To close all open connections use the special symbol 'all"))
(defmethod mongo-close ( (mongo mongo) )
(let ((name (name mongo)))
@@ -127,7 +128,7 @@ To close all open connections use the special symbol 'all"))
(defgeneric mongo-swap (left right)
(:documentation "Swap the names of the left and right connections. Typical use would be
-`(swap-connection :default :alt)`. After the function call :default will refer to the connection
+`(mongo-swap :default :alt)`. After the function call :default will refer to the connection
previously referred to as :alt. A connection named :default is returned by `(mongo)` and is the default used in the api. The connections are returned in the order they were passed in (but with the names
swapped between them). To re-open a connection you can say
`(mongo-close (mongo-swap :default (mongo :host <newhost> :portid <portid> :name :temp)))`
@@ -162,12 +163,20 @@ and a new default connection is registered." ))
(defgeneric mongo-message (mongo message &key )
(:documentation "message to/from mongo.."))
-(defun test-for-readback (stream timeout)
- #+clisp (socket:socket-status stream timeout)
+(defun test-for-readback* (stream timeout)
(declare (ignore timeout))
- #-(or clisp) (listen stream))
+ (listen stream))
-(defmethod mongo-message ( (mongo mongo) (message array) &key (timeout 5) )
+#+clisp (defun test-for-readback-clisp (stream timeout)
+ (multiple-value-bind (direction status) (socket:socket-status (cons stream :INPUT) timeout)
+ (declare (ignore status))
+ (when direction t)))
+
+(defun test-for-readback (stream timeout)
+ #-(or clisp) (test-for-readback* stream timeout)
+ #+clisp (test-for-readback-clisp stream timeout))
+
+(defmethod mongo-message ( (mongo mongo) (message array) &key (timeout 5) )
(write-sequence message (mongo-stream mongo))
(force-output (mongo-stream mongo))
(usocket:wait-for-input (list (socket mongo) ) :timeout timeout)
@@ -182,11 +191,8 @@ and a new default connection is registered." ))
reply))
nil))
-
-
(defgeneric db.use ( db &key )
- (:documentation "
-Use a database on the mongo server. Opens a connection if one isn't already
+ (:documentation "Use a database on the mongo server. Opens a connection if one isn't already
established. (db.use -) can be used to go to a previosuly visited database,
similar to cd -. "))
@@ -223,3 +229,62 @@ similar to cd -. "))
(declare (ignore value))
(when exists-p (push key lst)))))
(nreverse lst)))
+
+(defun connection? (name)
+ (if (car (multiple-value-list (gethash name (mongo-registry)))) t nil))
+
+(defun default? ()
+ (connection? :default))
+
+(defun switch-default-connection (name &key (host "localhost") (db "test") (port +MONGO-PORT+) )
+ (if (default?)
+ (mongo-swap :default (make-mongo :host host :db db :port port :name name ))
+ (make-mongo :host host :db db :port port :name :default)))
+
+(defun restore-default-connection (name)
+ (if (connection? name)
+ (mongo-close (mongo-swap :default name))
+ (mongo-close :default)))
+
+#|
+(defmacro with-mongo-connection ( (var . args) &rest body)
+ "Creates a connection to a mongodb, binds it to var and evaluates the body form.
+ args is passed on to make-mongo when the connection is created.
+ Caller should reference var in the body form where appropriate.."
+ (let ((connection-name (gensym)))
+ `(let ((,connection-name (gensym)))
+ (unwind-protect
+ (multiple-value-prog1
+ (let ((,var (switch-default-connection ,connection-name ,@args)))
+ ,@body))
+ (restore-default-connection ,connection-name)))))
+|#
+
+(defmacro with-mongo-connection ( args &rest body)
+ "Creates a connection to a mongodb, makes it the default connection
+ and evaluates the body form.
+ args uses the same keyword set as mongo (:db. :localhost :port)
+ args is passed on to make-mongo when the connection is created."
+ (let ((connection-name (gensym)))
+ `(let ((,connection-name (gensym)))
+ (unwind-protect
+ (multiple-value-prog1
+ (progn (switch-default-connection ,connection-name ,@args)
+ ,@body))
+ (restore-default-connection ,connection-name)))))
+
+#|
+(with-mongo-connection (mongo :db "test")
+ (pp (iter (db.find "foo" :all :mongo mongo))))
+
+
+(with-mongo-connection (mongo)
+ (format t "-> mongo ~A~%" mongo))
+
+(with-mongo-connection (mongo)
+ (show :connections))
+
+(with-mongo-connection (mongo :db "test")
+ (pp (iter (db.find "foo" :all :mongo mongo) :mongo mongo)))
+
+|#
View
10 src/packages.lisp
@@ -1,7 +1,7 @@
(in-package #:cl-user)
(defpackage #:cl-mongo
- (:use #:common-lisp #:babel #:uuid #:usocket)
+ (:use #:common-lisp #:babel #:uuid #:usocket )
(:export
;;
@@ -22,7 +22,7 @@
:mongo-show
:mongo-close
:mongo-swap
-
+ :with-mongo-connection
:kv
:db.create-collection
@@ -31,6 +31,7 @@
:db.update
:db.save
:db.find
+ :db.sort
:db.next
:db.iter
:db.stop
@@ -56,8 +57,9 @@
:docs
:now
:show
-
- :exp-test
+ ;; syntax expansion
+ :$+
+ :$-
;; documentation generator
:generate-readme
View
123 src/pair.lisp
@@ -19,69 +19,91 @@
(:constructor pair (key value)))
key value)
-(defgeneric kv (a b &rest rest)
- (:documentation "
-This a helper function for key-value pairs and sets of key-value pairs.
+(defclass kv-container ()
+ ((container :initform (make-array 2 :fill-pointer 0 :adjustable t) :accessor container)))
+
+(defmethod print-object ( (kv-container kv-container) stream)
+ (format stream "kv-container : ~A " (container kv-container)))
+
+(defun make-kv-container ()
+ (make-instance 'kv-container ))
+
+(defgeneric kv-container-push (el cont))
+
+(defmethod kv-container-push ( (el t) (kv-container kv-container) )
+ (vector-push-extend el (container kv-container)))
+
+(defgeneric kv-container-pop (cont))
+
+(defmethod kv-container-pop ( (kv-container kv-container) )
+ (unless (eql 0 (fill-pointer (container kv-container))) (vector-pop (container kv-container))))
+
+(defgeneric kv-container-length (cont) )
+
+(defmethod kv-container-length ( (kv-container kv-container) )
+ (length (container kv-container)))
+
+(defgeneric kv-container-aref (cont index ))
+
+(defmethod kv-container-aref ( (index integer) (kv-container kv-container) )
+ (aref (container kv-container) index ))
+
+(defgeneric kv-container-kv (index cont))
+
+(defmethod kv-container-kv ((index integer) (kv-container kv-container) )
+ (let (( pair (kv-container-aref index kv-container)))
+ (values (pair-key pair) (pair-value pair))))
+
+(defgeneric kv-container-add (el container))
+
+(defmethod kv-container-add ( (el pair) (kv-container kv-container) )
+ (kv-container-push el kv-container)
+ kv-container)
+
+(defmethod kv-container-add ( (el kv-container) (kv-container kv-container) )
+ (labels ((add (contb)
+ (dotimes (index (kv-container-length contb ))
+ (let ((el (kv-container-aref index contb)))
+ (when el) (kv-container-push el kv-container)))
+ kv-container))
+ (add el)))
+
+(defgeneric kv (a &rest rest)
+ (:documentation " This a helper function for key-value pairs and sets of key-value pairs.
In a key-value pair like (kv key value) the key has to be a string and the
value something which is serializable.
key-value pairs can be combined using kv as well : (kv (kv key1 val1) (kv key2 val2)).
This combination of key-value pairs is equivalent to a document without a unique id.
The server will assign a unique is if a list of key-value pairs is saved."))
-(defmethod kv ( (a (eql nil) ) (b (eql nil)) &rest rest)
- (declare (ignore rest))
- (pair nil nil))
+(defmethod kv ( (a (eql nil) ) &rest rest)
+ (pair nil (car rest)))
;; basically b can be anything with
;; an encoder..
-(defmethod kv ( (a string) b &rest rest)
- (declare (ignore rest))
- (pair a b))
+(defmethod kv ( (a string) &rest rest)
+ (pair a (car rest)))
-(defmethod kv ( (a symbol) b &rest rest)
+(defmethod kv ( (a symbol) &rest rest)
(declare (ignore rest))
- (pair (string-downcase a) b))
-
-
-(defmethod kv ( (a pair) (b pair) &rest rest)
- (let ((ht (make-hash-table :test 'equal)))
- (setf (gethash (pair-key a) ht) (pair-value a))
- (setf (gethash (pair-key b) ht) (pair-value b))
- (dolist (el rest)
- (setf (gethash (pair-key el) ht) (pair-value el)))
- ht))
-
-;this allows for (kv (kv "a" b) nil ("l" k) ) where
-; the nil maybe the result of some test. it's skipped..
-(defmethod kv ( (a pair) (b pair) &rest rest)
- (let ((ht (make-hash-table :test 'equal)))
- (setf (gethash (pair-key a) ht) (pair-value a))
- (setf (gethash (pair-key b) ht) (pair-value b))
- (dolist (el rest)
- (when el (setf (gethash (pair-key el) ht) (pair-value el))))
- ht))
+ (pair (string-downcase a) (car rest)))
-;this adds more kv's to an existing container..
-;I don't check the type of the rest variables,
-;assuming they're all pairs..
-(defmethod kv ( (ht hash-table) (b pair) &rest rest )
- (setf (gethash (pair-key b) ht) (pair-value b))
+(defmethod kv ( (kv-container kv-container) &rest rest )
(dolist (el rest)
- (setf (gethash (pair-key el) ht) (pair-value el)))
- ht)
-
-(defun bson-encode-pair ( kv )
- (bson-encode (pair-key kv) (pair-value kv)))
+ (when el (kv-container-add el kv-container)))
+ kv-container)
-(defmethod bson-encode ( (key string) (value pair) &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type nil) (encoder nil))
- (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
- (ignore size-supplied-p) (ignore array-supplied-p) )
- (bson-encode key (bson-encode-pair value)))
+(defmethod kv ( (a pair) &rest rest)
+ (let ((kvc (make-kv-container) ))
+ (kv-container-add a kvc)
+ (dolist (el rest)
+ (when el (kv-container-add el kvc)))
+ kvc))
+
+;(kv (kv "query" (kv nil nil)) (kv "orderby" (kv "k" 1)))
(defgeneric kv->doc ( kv )
(:documentation "turn a pair of key/value pairs into a document"))
@@ -90,6 +112,12 @@ The server will assign a unique is if a list of key-value pairs is saved."))
(let ((doc (make-document)))
(add-element (pair-key kv) (pair-value kv) doc)))
+(defmethod kv->doc ( (kv-container kv-container) )
+ (let ((doc (make-document)))
+ (dotimes (index (kv-container-length kv-container))
+ (let ((kv (kv-container-aref index kv-container)))
+ (add-element (pair-key kv) (pair-value kv) doc)))))
+
(defmethod kv->doc ( (kv hash-table) )
(ht->document kv))
@@ -104,3 +132,6 @@ The server will assign a unique is if a list of key-value pairs is saved."))
(defmethod kv->ht ( (kv hash-table) )
kv)
+(defmethod kv->ht ( (kv-container kv-container) )
+ (elements (kv->doc kv-container)))
+
View
63 src/shell.lisp
@@ -5,33 +5,43 @@
|#
(defun docs ( result )
-"
-Stop the iterator (if any) and return the list of documents returned by the query.
-Typical ue would be in conjunction with db.find like so (docs (iter (db.find 'foo' 'll)))
-"
+ "Stop the iterator (if any) and return the list of documents returned by the query.
+Typical ue would be in conjunction with db.find like so (docs (iter (db.find 'foo' 'll)))"
(cadr (db.stop result)))
(defun iter ( result &key (mongo nil) (max-per-call 0) )
-"
-Exhaustively iterate through a query. The maximum number of responses
-per query can be specified using the max-per-call keyword.
-
-"
+"Exhaustively iterate through a query. The maximum number of responses
+per query can be specified using the max-per-call keyword."
(loop
(setf result (db.iter result :mongo mongo :limit max-per-call ) )
(when (zerop (db.iterator result) ) (return result) )))
-(defun rm (result &key (mongo nil) )
-"
-Delete all the documents returned by a query. This is not an efficient
+(defun rm* (result &key (mongo nil) )
+ "Delete all the documents returned by a query. This is not an efficient
way of deleting documents as it invloves multiple trips to the server.
Mongo allows for execution of java-script on the server side, which provides
an alternative. Typical use would be (rm (iter (db.find 'foo' (kv 'key' 1)))),
-which deletes all documents in foo, with field key equal to 1.
-"
+which deletes all documents in foo, with field key equal to 1."
(multiple-value-bind (iterator collection docs) (db.iterator result)
(db.stop iterator :mongo mongo)
(db.delete collection docs)))
+;;
+;; rm is is set up to handle insert/delete race conditions which may appear..
+;;
+(defun rm (collection query &key (mongo nil) )
+ "Delete all the documents returned by a query. This is not an efficient
+way of deleting documents as it invloves multiple trips to the server.
+Mongo allows for execution of java-script on the server side, which provides
+an alternative. Typical use would be (rm (iter (db.find 'foo' (kv 'key' 1)))),
+which deletes all documents in foo, with field key equal to 1."
+ (labels ((server-count()
+ (get-element "n" (car (docs (db.count collection :all :mongo mongo)))))
+ (delete-docs ()
+ (db.delete collection (docs (iter (db.find collection query :mongo mongo))) :mongo mongo)))
+ (do ((line (server-count)
+ (server-count)))
+ ((zerop line ))
+ (delete-docs))))
(defgeneric pp (result &key)
(:documentation "
@@ -170,6 +180,15 @@ the profile and more. Things is a keyword so (show 'users) will show all users."
(defmethod show :after ( (things (eql :databases)) &key)
(db.use -))
+(defmethod show ( (things (eql :buildinfo)) &key (order '("version" "sysInfo" "gitVersion" :rest)) )
+ (show (lambda () (db.run-command :buildinfo)) :order order :nl t))
+
+(defmethod show :before ( (things (eql :buildinfo)) &key)
+ (db.use "admin"))
+
+(defmethod show :after ( (things (eql :buildinfo)) &key)
+ (db.use -))
+
(defmethod show ( (things (eql :users)) &key (order '("user" "pwd") ))
(show (lambda () (db.find "system.users" 'all)) :order order))
@@ -179,14 +198,14 @@ the profile and more. Things is a keyword so (show 'users) will show all users."
(defmethod show ( (things (eql :assertinfo)) &key (order '(:rest)))
(show (lambda () (db.run-command things)) :order order :nl t))
-(defmethod show ( (things (eql :errors)) &key (order '(:rest)))
- (show (lambda () (db.run-command :getlasterror)) :order order :msg "last error : ")
- (show (lambda () (db.run-command :getpreverror)) :order order :msg "prev error : "))
-(defgeneric exp-test (arg))
+(defmethod show ( (things (eql :lasterror)) &key (order '(:rest)))
+ (show (lambda () (db.run-command :getlasterror)) :order order :msg "last error : "))
+
+(defmethod show ( (things (eql :preverror)) &key (order '(:rest)))
+ (show (lambda () (db.run-command :getpreverror)) :order order :msg "last error : "))
-(defmethod exp-test ( (arg (eql :hello)) )
- (format t "hello"))
+(defmethod show ( (things (eql :errors)) &key (order '(:rest)))
+ (show :lasterror)
+ (show :preverror))
-(defmethod exp-test ( (arg string) )
- (format t "hello : ~A" arg))
View
10 test/package.lisp
@@ -0,0 +1,10 @@
+(in-package #:cl-user)
+
+(defpackage #:cl-mongo-test
+ (:use #:common-lisp #:cl-mongo #:lisp-unit)
+ (:export
+
+ ;;
+ ;; TBD
+
+ ))
View
160 test/regression.lisp
@@ -0,0 +1,160 @@
+(in-package :cl-mongo-test)
+
+(defvar *test-collection* "foo" "name of the test collection")
+
+(defun force-single-float (n)
+ (coerce n 'single-float))
+
+(defun geometric-range* (base length accum factor)
+ (if (zerop length)
+ (mapcar #'floor (nreverse accum))
+ (geometric-range* base (decf length) (cons (* (* factor base) (car accum)) accum) factor)))
+
+(defun geometric-range (base length &optional (factor 1))
+ (geometric-range* base (decf length) (list base) factor))
+
+(defun reset-test-collection (collection size &optional (wait 0) )
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (rm collection :all)
+ (let ((count (length (docs (iter (db.find collection :all))))))
+ (assert-eql t (zerop count))))
+ (insert-lots collection size)
+ (sleep wait)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((count (length (docs (iter (db.find collection :all))))))
+ (assert-eql size count))))
+
+;--------------------------------------------------------------------------------------
+
+(defun count-documents ( &optional (collection *test-collection*) &key (size 5) )
+ (reset-test-collection collection size)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((client-count (length (docs (iter (db.find collection :all)))))
+ (server-count (get-element "n" (car (docs (db.count collection :all))))))
+ (format t "client count : ~A -- server count ~A ~%" client-count server-count)
+ (assert-eql (force-single-float client-count)
+ (force-single-float (float server-count))
+ "testing wether client and server count are equal")))
+ (reset-test-collection collection 0))
+
+(defun find-doc-by-field ( &optional (collection *test-collection*) &key (size 5))
+ (reset-test-collection collection size)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((found (length (docs (iter (db.find collection (kv "name" "simple")))))))
+ (format t "findOne is default : ~A ~%" found)
+ (assert-eql 1 found)))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((found (length (docs (iter (db.find collection (kv "name" "simple") :limit 0))))))
+ (format t "limit == 0 returns all : ~A ~%" found)
+ (assert-eql size found )))
+ (reset-test-collection collection 0))
+
+
+(defun delete-docs (&optional (collection *test-collection*) &key (size 5) )
+ (reset-test-collection collection size)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((cnt (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
+ (unless (> cnt 0) (insert-lots collection size)))
+ (rm collection :all)
+ (let ((cnt (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
+ (assert-eql 0.0 (force-single-float cnt) "deleting all documents" size)))
+ (reset-test-collection collection 0))
+
+(defun db.find-regression-all (&optional (collection *test-collection*) &key (size 5))
+ (reset-test-collection collection size 3)
+;;;test retrieval of all documents with an iterator..
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((all (length (docs (iter (db.find "foo" :all))))))
+ (assert-equal size all)))
+;;; get the first document (this is not indexed so index may fail ro be equal to 0...
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let* ((documents (docs (iter (db.find "foo" :all :limit 1))))
+ (index (get-element "index-this" (car documents))))
+ (assert-equal 1 (length documents))
+ (assert-equal 0 index "assuming first document has index 0")))
+;;; test of skip; skip the first (size - floor (* size 0.5))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let* ((documents (docs (iter (db.find "foo" :all :limit 0 :skip (floor (* 0.5 size))))))
+ (skip (floor (* 0.5 size)))
+ (first-index (get-element "index-this" (car documents)))
+ (last-index (get-element "index-this" (car (nreverse documents))))
+ (expected-count (- size skip))
+ (expected-last-index (decf size)))
+ (assert-equal expected-count (length documents))
+ (assert-equal skip first-index "assuming first document has index 0")
+ ;;(mapcar (lambda (d) (format t "~A;" (get-element "index-this" d))) (nreverse documents))
+ (assert-equal expected-last-index last-index "assuming first document has index 0")))
+ (reset-test-collection collection 0))
+
+(defun db-sort-regression (&optional (collection *test-collection*) &key (size 5))
+ (reset-test-collection collection size)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let* ((ret (docs (iter (db.sort collection :all :field "k" :selector "k" ))))
+ (elem (mapcar (lambda (d) (get-element "k" d)) ret)))
+ (format t "elem : ~A ~%" elem)
+ (reduce (lambda (x y) (progn (assert-eql t (< x y) x y ) y)) elem)))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let* ((ret (docs (iter (db.sort collection :all :field "k" :selector "k" :asc nil))))
+ (elem (mapcar (lambda (d) (get-element "k" d)) ret)))
+ (format t "elem : ~A ~%" elem)
+ (reduce (lambda (x y) (progn (assert-eql t (> x y) x y ) y)) elem)))
+ (reset-test-collection collection 0))
+
+(defun map-reduce-truth (tv l)
+ (reduce (lambda (x y) (and x y) ) (mapcar (lambda (x) (assert-eql tv (when x t) x)) l)))
+
+(defun db-find-selector-regression (&optional (collection *test-collection*) &key (size 5))
+ (reset-test-collection collection size)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let* ((ret (docs (iter (db.find collection :all :selector ($+ "k" "l") ))))
+ (ks (mapcar (lambda (d) (get-element "k" d)) ret))
+ (ls (mapcar (lambda (d) (get-element "l" d)) ret))
+ (excl (mapcar (lambda (d) (get-element "index-this" d)) ret)))
+ (format t "elem : ~A ~%" ks)
+ (assert-eql t (map-reduce-truth t ks))
+ (format t "elem : ~A ~%" ls)
+ (assert-eql t (map-reduce-truth t ls))
+ (format t "elem : ~A ~%" excl)
+ (assert-eql t (map-reduce-truth nil excl))))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let* ((ret (docs (iter (db.find collection :all :selector ($- "k" "l") ))))
+ (ks (mapcar (lambda (d) (get-element "k" d)) ret))
+ (ls (mapcar (lambda (d) (get-element "l" d)) ret))
+ (excl (mapcar (lambda (d) (get-element "index-this" d)) ret)))
+ (format t "elem : ~A ~%" ks)
+ (assert-eql t (map-reduce-truth nil ks))
+ (format t "elem : ~A ~%" ls)
+ (assert-eql t (map-reduce-truth nil ls))
+ (format t "elem : ~A ~%" excl)
+ (assert-eql t (map-reduce-truth t excl))))
+ (reset-test-collection collection 0))
+
+;;--------------------------------------------------------------------------
+
+(defun test-delete (&optional (collection *test-collection*))
+ (dolist (size (geometric-range 10 5 ))
+ (delete-docs collection :size size)))
+
+(defun test-query-field-selection (&optional (collection *test-collection*))
+ (dolist (size (geometric-range 5 5 ))
+ (find-doc-by-field *test-collection* :size size)))
+
+(defun test-document-count (&optional (collection *test-collection*))
+ (dolist (size (geometric-range 5 5 ))
+ (count-documents *test-collection* :size size)))
+
+(defun test-find-all (&optional (collection *test-collection*))
+ (dolist (size (geometric-range 2 4 5 ))
+ (db.find-regression-all collection :size size)))
+
+(defun test-sort (&optional (collection *test-collection*))
+ (dolist (size (geometric-range 2 4))
+ (db-sort-regression collection :size (* 10 size))))
+
+(defun test-find-selector (&optional (collection *test-collection*))
+ (dolist (size (geometric-range 2 4))
+ (db-find-selector-regression collection :size size)))
+
+;;;;;;;;;;;;;
+
+
View
58 test/test-utils.lisp
@@ -0,0 +1,58 @@
+(in-package :cl-mongo-test)
+
+(defun send-doc-in-doc-in-doc (collection)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((doc (make-document)))
+ (add-element "string" "hello world generated by test-document" doc)
+ (add-element "number89" 89 doc)
+ (add-element "numberbig" 89988787777887 doc)
+ (add-element "float 89.67" 89.67 doc)
+ (add-element "list-1" (list 1 2 3 4) doc)
+ (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
+ (let ((doc2 (make-document)))
+ (add-element "key-1" "doc in doc !!" doc2)
+ (add-element "key-2" 56.89 doc2)
+ (let ((doc3 (make-document)))
+ (add-element "array" (list (list (list "inside a nest!!"))) doc3)
+ (add-element "key56" 56 doc3)
+ (add-element "doc3" doc3 doc2)
+ (add-element "doc2" doc2 doc)
+ (db.insert collection doc ))))))
+
+
+(defun test-doc-simple (collection)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((doc (make-document)))
+ (add-element "string" "hello world generated by test-document" doc)
+ (add-element "1" 1 doc)
+ (add-element "2" 2 doc)
+ (add-element "3" 3 doc)
+ (add-element "4" 40 doc)
+ (add-element "5" 30 doc)
+ (db.insert collection doc ))))
+
+(defun send-test-document ( collection )
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((doc (make-document)))
+ (add-element "string" "hello world generated by test-document" doc)
+ (add-element "number89" 89 doc)
+ (add-element "numberbig" 89988787777887 doc)
+ (add-element "float 89.67" 89.67 doc)
+ (add-element "list-1" (list 1 2 3 4) doc)
+ (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
+ (db.insert collection doc ))))
+
+(defun insert-lots (collection n)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (dotimes (i n)
+ (let ((doc (make-document)))
+ (add-element (format nil "name") "simple" doc)
+ (add-element (format nil "~D" i) i doc)
+ (add-element (format nil "k") (+ 56.00 i) doc)
+ (add-element (format nil "l") (- i 9.00) doc)
+ (add-element (format nil "index-this") i doc)
+ (add-element (format nil "value-1") (* 78 i) doc)
+ (db.insert collection doc )))))
+
+
+
View
128 test/test.lisp
@@ -1,6 +1,6 @@
(in-package :cl-mongo-test)
-
+#|
(defun gtb ( loc )
(let ((res 255))
(dotimes (var loc)
@@ -23,9 +23,7 @@
(format t "value ~A ~%" value)
(octet-to-int64 (int64-to-octet value))))
-#|
-|#
(defun write-array(port array)
(let (( socket (usocket:socket-connect "localhost" port :element-type '(unsigned-byte 8))))
(write-sequence array (usocket:socket-stream socket))
@@ -181,15 +179,6 @@
(assert (eql docs (length elements)))
(assert (eql (total-length elements) (- tot-size offset)))))
-(defun send-test-document ( collection )
- (let ((doc (make-document)))
- ;(add-element "string" "hello world generated by test-document" doc)
- ;(add-element "number89" 89 doc)
- ;(add-element "numberbig" 89988787777887 doc)
- ;(add-element "float 89.67" 89.67 doc)
- ;(add-element "list-1" (list 1 2 3 4) doc)
- ;(add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
- (db.insert collection doc )))
(defun send-doc-in-doc ( collection )
(let ((doc (make-document)))
@@ -205,42 +194,91 @@
(add-element "doc2" doc2 doc)
(db.insert collection doc ))))
+
+|#
+
(defun send-doc-in-doc-in-doc (collection)
- (let ((doc (make-document)))
- (add-element "string" "hello world generated by test-document" doc)
- (add-element "number89" 89 doc)
- (add-element "numberbig" 89988787777887 doc)
- (add-element "float 89.67" 89.67 doc)
- (add-element "list-1" (list 1 2 3 4) doc)
- (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
- (let ((doc2 (make-document)))
- (add-element "key-1" "doc in doc !!" doc2)
- (add-element "key-2" 56.89 doc2)
- (let ((doc3 (make-document)))
- (add-element "array" (list (list (list "inside a nest!!"))) doc3)
- (add-element "key56" 56 doc3)
- (add-element "doc3" doc3 doc2)
- (add-element "doc2" doc2 doc)
- (db.insert collection doc )))))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((doc (make-document)))
+ (add-element "string" "hello world generated by test-document" doc)
+ (add-element "number89" 89 doc)
+ (add-element "numberbig" 89988787777887 doc)
+ (add-element "float 89.67" 89.67 doc)
+ (add-element "list-1" (list 1 2 3 4) doc)
+ (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
+ (let ((doc2 (make-document)))
+ (add-element "key-1" "doc in doc !!" doc2)
+ (add-element "key-2" 56.89 doc2)
+ (let ((doc3 (make-document)))
+ (add-element "array" (list (list (list "inside a nest!!"))) doc3)
+ (add-element "key56" 56 doc3)
+ (add-element "doc3" doc3 doc2)
+ (add-element "doc2" doc2 doc)
+ (db.insert collection doc ))))))
(defun test-doc-simple (collection)
- (let ((doc (make-document)))
- (add-element "string" "hello world generated by test-document" doc)
- (add-element "1" 1 doc)
- (add-element "2" 2 doc)
- (add-element "3" 3 doc)
- (add-element "4" 40 doc)
- (add-element "5" 30 doc)
- (db.insert collection doc)))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((doc (make-document)))
+ (add-element "string" "hello world generated by test-document" doc)
+ (add-element "1" 1 doc)
+ (add-element "2" 2 doc)
+ (add-element "3" 3 doc)
+ (add-element "4" 40 doc)
+ (add-element "5" 30 doc)
+ (db.insert collection doc ))))
+
+(defun send-test-document ( collection )
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((doc (make-document)))
+ (add-element "string" "hello world generated by test-document" doc)
+ (add-element "number89" 89 doc)
+ (add-element "numberbig" 89988787777887 doc)
+ (add-element "float 89.67" 89.67 doc)
+ (add-element "list-1" (list 1 2 3 4) doc)
+ (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
+ (db.insert collection doc ))))
(defun insert-lots (collection n)
- (dotimes (i n)
- (let ((doc (make-document)))
- (add-element (format nil "~D" i) i doc)
- (add-element (format nil "k") (+ 56.00 i) doc)
- (add-element (format nil "l") (- i 9.00) doc)
- (add-element (format nil "index-this") i doc)
- (add-element (format nil "value-1") (* 78 i) doc)
- (db.insert collection doc ))))
-
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (dotimes (i n)
+ (let ((doc (make-document)))
+ (add-element (format nil "name") "simple" doc)
+ (add-element (format nil "~D" i) i doc)
+ (add-element (format nil "k") (+ 56.00 i) doc)
+ (add-element (format nil "l") (- i 9.00) doc)
+ (add-element (format nil "index-this") i doc)
+ (add-element (format nil "value-1") (* 78 i) doc)
+ (db.insert collection doc )))))
+
+
+(defun count-documents ( collection )
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((client-count (* 1.0 (length (docs (iter (db.find collection :all))))))
+ (server-count (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
+ (format t "client count : ~A -- server count ~A ~%" client-count server-count)
+ (eql client-count server-count))))
+
+
+(defun delete-docs (collection &key (size 5) )
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((cnt (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
+ (unless (> cnt 0) (insert-lots collection size)))
+ (rm collection :all)
+ (let ((cnt (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
+ (format t "count : ~A ~%" cnt)
+ (eql 0.0 cnt))))
+
+
+(defun find-docs (collection &key (size 5))
+ (rm collection :all)
+ (insert-lots collection size)
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((found (length (docs (iter (db.find collection (kv "name" "simple")))))))
+ (format t "findOne is default : ~A ~%" found)
+ (eql found 1)))
+ (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
+ (let ((found (length (docs (iter (db.find collection (kv "name" "simple") :limit 0))))))
+ (format t "limit == 0 returns all : ~A ~%" found)
+ (eql found size))))
+

0 comments on commit 212cc69

Please sign in to comment.