Skip to content
This repository
Browse code

building tests; adding functionality

  • Loading branch information...
commit 212cc6923ff9aaecb9620c0e344689967e28b704 1 parent 8641124
fons authored
22 cl-mongo.asd
@@ -13,6 +13,7 @@
13 13 :depends-on (:uuid
14 14 :babel
15 15 :documentation-template
  16 + :lisp-unit
16 17 :usocket)
17 18 :serial t
18 19 :components
@@ -20,15 +21,18 @@
20 21 :serial t
21 22 :components ((:file "packages")
22 23 (:file "octets")
  24 + (:file "pair")
23 25 (:file "encode-float")
24 26 (:file "bson-oid")
25 27 (:file "bson-binary")
26 28 (:file "bson-time")
  29 + (:file "bson-regex")
27 30 (:file "bson-code")
28   - (:file "pair")
29 31 (:file "bson")
30 32 (:file "bson-array")
31 33 (:file "document")
  34 + (:file "mongo-syntax")
  35 + (:file "bson-encode-container")
32 36 (:file "protocol")
33 37 (:file "mongo")
34 38 (:file "db")
@@ -37,6 +41,22 @@
37 41 (:static-file "README.md")
38 42 (:static-file "COPYING")))
39 43
  44 +(asdf:defsystem cl-mongo-test
  45 + :name "cl-mongo"
  46 + :author "Fons Haffmans; fons.haffmans@gmail.com"
  47 + :version "0.0.1"
  48 + :licence "MIT"
  49 + :description "tesing cl-mongo"
  50 + :depends-on (:cl-mongo)
  51 + :serial t
  52 + :components
  53 + ((:module "test"
  54 + :serial t
  55 + :components ((:file "package")
  56 + (:file "test-utils")
  57 + (:file "regression")))))
  58 +
  59 +
40 60
41 61
42 62
50 src/bson-encode-container.lisp
... ... @@ -0,0 +1,50 @@
  1 +(in-package :cl-mongo)
  2 +
  3 +
  4 +(defgeneric bson-encode-container ( container &key )
  5 + (:documentation "encode a container of key-value pairs.."))
  6 +
  7 +(defmethod bson-encode-container ( (container pair) &key (array nil) (size 10) )
  8 + (bson-encode-container (kv->ht container) :array array :size size))
  9 +
  10 +(defmethod bson-encode-container ( (container (eql nil) ) &key (array nil) )
  11 + (bson-encode nil nil :array array))
  12 +
  13 +(defmethod bson-encode-container ( (container document) &key (array nil) (size 10) )
  14 + (setf (gethash "_id" (elements container)) (_id container))
  15 + (bson-encode-container (elements container) :array array :size size))
  16 +
  17 +(defmethod bson-encode-container ( (container hash-table) &key (array nil) (size nil) )
  18 + (let* ((size (or size 10))
  19 + (array (or array (make-octet-vector size))))
  20 + (add-octets (int32-to-octet 0) array )
  21 + (with-hash-table-iterator (iterator container)
  22 + (dotimes (repeat (hash-table-count container))
  23 + (multiple-value-bind (exists-p key value) (iterator)
  24 + (if exists-p (add-octets (bson-encode key value) array :start 4 :from-end 1)))))
  25 + (normalize-array array)))
  26 +
  27 +(defmethod bson-encode-container ( (kv-container kv-container) &key (array nil) (size nil) )
  28 + (let* ((size (or size 10))
  29 + (array (or array (make-octet-vector size))))
  30 + (add-octets (int32-to-octet 0) array )
  31 + (dotimes (index (kv-container-length kv-container))
  32 + (multiple-value-bind (key value) (kv-container-kv index kv-container)
  33 + (add-octets (bson-encode key value) array :start 4 :from-end 1)))
  34 + (normalize-array array)))
  35 +
  36 +(defmethod bson-encode-container ( (kv pair) &key )
  37 + (bson-encode (pair-key kv) (pair-value kv)))
  38 +
  39 +(defmethod bson-encode ( (key string) (value hash-table) &key )
  40 + (bson-encode key (bson-encode-container value :array (make-octet-vector (* (hash-table-count value) 12)))))
  41 +
  42 +(defmethod bson-encode ( (key string) (value document) &key )
  43 + (bson-encode key (bson-encode-container value )))
  44 +
  45 +(defmethod bson-encode ( (key string) (value kv-container) &key )
  46 + (bson-encode key (bson-encode-container value )))
  47 +
  48 +
  49 +(defmethod bson-encode ( (key string) (value pair) &key )
  50 + (bson-encode key (bson-encode-container value)))
19 src/bson-regex.lisp
... ... @@ -0,0 +1,19 @@
  1 +(in-package :cl-mongo)
  2 +
  3 +(defclass bson-regex()
  4 + ((regex :reader regex :initarg :regex)
  5 + (options :reader options :initarg :options)))
  6 +
  7 +(defun make-bson-regex (regex options)
  8 + (make-instance 'bson-regex :regex regex :options options))
  9 +
  10 +(defmethod print-object ((bson-regex bson-regex) stream)
  11 + (format stream "~S [/~A/~A] ~%" (type-of bson-regex)
  12 + (if (slot-boundp bson-regex 'regex)
  13 + (regex bson-regex)
  14 + "regex not set..")
  15 + (if (slot-boundp bson-regex 'options)
  16 + (options bson-regex)
  17 + "options not set..")))
  18 +
  19 +
42 src/bson.lisp
@@ -11,6 +11,7 @@
11 11 (defconstant +bson-data-boolean+ 8 "bson boolean encoding")
12 12 (defconstant +bson-data-date+ 9 "bson date encoding")
13 13 (defconstant +bson-data-null+ 10 "bson null encoding")
  14 +(defconstant +bson-data-regex+ 11 "bson regex encoding")
14 15 (defconstant +bson-data-code+ 13 "bson code encoding")
15 16 (defconstant +bson-data-int32+ 16 "bson 32 bit int encoding")
16 17 (defconstant +bson-data-long+ 18 "bson 64 bit int encoding")
@@ -42,11 +43,12 @@ clashed with the encoding for booleans..
42 43 (:documentation "encode a bson data element"))
43 44
44 45 (defmethod bson-encode( (key string) (value t) &key array type encoder)
  46 + ;(format t "89here~%")
45 47 (let* ((head (fill-pointer array))) ; save the stack pointer
46 48 (add-octets (int32-to-octet 0) array) ; length, set to zero
47 49 (add-octets (byte-to-octet type) array) ; data element code
48 50 (add-octets (string-to-null-terminated-octet key) array) ; key
49   - (funcall encoder array) ; call type sepcifi encoder
  51 + (funcall encoder array) ; call type specific encoder
50 52 (add-octets (byte-to-octet 0) array) ; ending nul
51 53 (set-octets head (int32-to-octet (- (length array) head) ) array) ; set length
52 54 array))
@@ -136,21 +138,33 @@ clashed with the encoding for booleans..
136 138 (call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
137 139
138 140
139   -(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
140   - (let ((array (or array (make-octet-vector +default-array-size+))))
141   - (labels ((encode-value (array)
142   - (add-octets (byte-to-octet (bool-to-byte value)) array))) ; add value
143   - (call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
  141 +;(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
  142 +; (let ((array (or array (make-octet-vector +default-array-size+))))
  143 +; (labels ((encode-value (array)
  144 +; (add-octets (byte-to-octet (bool-to-byte value)) array))) ; add value
  145 +; (call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
144 146
145 147 ;
146 148 ; nil is the opposite of t, and is already mapped as a boolean. Also, there a seperate encoder
147 149 ; for symbols, so something like the below won't work (and propably doesn't need to )
148 150
149 151 ;(defmethod bson-encode ( (key string) (value (eql 'void)) &key (array nil) )
150   -; (let ((array (or array (make-octet-vector +default-array-size+))))
151   -; (labels ((encode-value (array)
152   -; array))
153   -; (call-next-method key value :array array :type +bson-data-null+ :encoder #'encode-value))))
  152 +
  153 +(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
  154 + (let ((array (or array (make-octet-vector +default-array-size+))))
  155 + (labels ((encode-value (array)
  156 + array))
  157 + (call-next-method key value :array array :type +bson-data-null+ :encoder #'encode-value))))
  158 +
  159 +(defmethod bson-encode ( (key string) (value bson-regex) &key (array nil) (type +bson-data-regex+) )
  160 + (let ((array (or array (make-octet-vector +default-array-size+))))
  161 + (labels ((encode-value (array)
  162 + ;; regex string, null terminated
  163 + (add-octets (string-to-null-terminated-octet (regex value)) array)
  164 + ;; options string, null terminated
  165 + (add-octets (string-to-null-terminated-octet (options value) ) array)
  166 + ))
  167 + (call-next-method key value :array array :type +bson-data-regex+ :encoder #'encode-value))))
154 168
155 169 ;
156 170 ; 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..
301 315 ;(push (list key value) accum))))
302 316 (push value accum))))
303 317 (values (reverse accum) rest)))
304   -
305   -
306   -
307   -
308   -
309   -
310   -
311   -
51 src/db.lisp
@@ -25,25 +25,29 @@ Since the default value of the limit is one, db.find by default is the equivalan
25 25 mongo documentation.
26 26 "))
27 27
28   -(defmethod db.find ( (collection symbol) (kv t)
29   - &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
30   - (db.find (string-downcase collection) kv
31   - :mongo mongo :options options :skip skip :limit limit :selector selector ))
32   -
33 28 (defmethod db.find ( (collection string) (kv t)
34 29 &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
35 30 (let ((mongo (or mongo (mongo))))
36 31 (labels ((query ()
37 32 (mongo-message mongo (mongo-query
38 33 (full-collection-name mongo collection) kv
39   - :limit limit :skip skip :selector selector :options options))))
  34 + :limit limit
  35 + :skip skip
  36 + :selector (bson-encode-container (expand-selector selector))
  37 + :options options))))
40 38 (multiple-value-bind (header docs) (mongo-reply (query) :finalize 'to-document)
41 39 (list (append header (list collection)) docs)))))
42 40
  41 +(defmethod db.find ( (collection symbol) (kv t)
  42 + &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
  43 + (db.find (string-downcase collection) kv
  44 + :mongo mongo :options options :skip skip :limit limit :selector selector ))
  45 +
  46 +
43 47 (defmethod db.find ( (collection string) (kv (eql :all))
44   - &key (mongo nil) (options 0) (skip 0) (selector nil) )
45   - (db.find collection (bson-encode nil nil)
46   - :mongo mongo :options options :skip skip :limit 0 :selector selector ))
  48 + &key (mongo nil) (options 0) (skip 0) (limit 0) (selector nil) )
  49 + (db.find collection (bson-encode "query" (kv nil nil))
  50 + :mongo mongo :options options :skip skip :limit limit :selector selector ))
47 51
48 52 (defmethod db.find ( (collection string) (kv integer)
49 53 &key (mongo nil) (options 0) (skip 0) (selector nil) )
@@ -60,6 +64,23 @@ mongo documentation.
60 64 (db.find collection (bson-encode-container kv)
61 65 :mongo mongo :options options :skip skip :limit limit :selector selector ))
62 66
  67 +(defmethod db.find ( (collection string) (kv kv-container)
  68 + &key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
  69 + (db.find collection (bson-encode-container kv)
  70 + :mongo mongo :options options :skip skip :limit limit :selector selector ))
  71 +
  72 +(defmacro db.sort (collection query &rest args)
  73 + "sort macro : Takes the same arguments and keywords as db.find but converts the query
  74 + so it works as a sort. use the :field keyword to select the field to sort on.
  75 + Set :asc to nil to reverse the sort order"
  76 + (let ((kv-query (gensym)))
  77 + `(destructuring-bind (&key (selector nil) (mongo nil)
  78 + (limit 0) (skip 0) (options 0) (field nil) (asc t))
  79 + (list ,@args)
  80 + (let ((kv-query (or (and (eql ,query :all) (kv nil nil)) ,query)))
  81 + (db.find ,collection (kv (kv "query" kv-query) (kv "orderby" (kv field (if asc 1 -1) )))
  82 + :limit limit :mongo mongo :skip skip :selector selector :options options)))))
  83 +
63 84
64 85 (defgeneric db.update ( collection selector new-document &key )
65 86 (: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
175 196 It may be more efficient to run a delete script on he server side.
176 197 "))
177 198
178   -(defmethod db.delete ( (collection (eql nil)) (document (eql nil)) &key))
  199 +(defmethod db.delete ( (collection t) (document (eql nil)) &key (mongo nil) ))
  200 +
179 201
180 202 (defmethod db.delete ( (collection string) (document document) &key (mongo nil))
181 203 (let ((mongo (or mongo (mongo) )))
@@ -287,6 +309,10 @@ For most commands you can just uses the key-value shown in the mongo documentati
287 309 (assert (not (null collection)))
288 310 (db.find "$cmd" (kv->ht (kv (kv "deleteIndexes" collection) (kv "index" index))) :mongo mongo))
289 311
  312 +(defmethod db.run-command ( (cmd (eql :drop) ) &key (mongo nil) (collection nil) (index "*") )
  313 + (assert (not (null collection)))
  314 + (db.find "$cmd" (kv->ht (kv "drop" collection) ) :mongo mongo))
  315 +
290 316
291 317 #|
292 318
@@ -315,7 +341,7 @@ all the documents in the collection.
315 341 (db.find "$cmd" (kv (kv "count" collection) (kv "query" selector) (kv "fields" nil)) :mongo mongo :limit 1))
316 342
317 343 (defmethod db.count ( (collection t) (selector (eql :all) ) &key (mongo nil) )
318   - (call-next-method collection nil :mongo mongo))
  344 + (db.count collection nil :mongo mongo))
319 345
320 346 (defmethod db.count ( (collection t) (selector pair ) &key (mongo nil) )
321 347 (call-next-method collection (kv->ht selector) :mongo mongo))
@@ -357,4 +383,5 @@ all the documents in the collection.
357 383 (retval (get-element "ok" (car (docs (db.find "$cmd" request :limit 1 :mongo mongo))))))
358 384 (if retval t nil)))
359 385
360   -
  386 +;;(db.find "$cmd" (kv (kv "count" "foo") (kv "query" (kv nil nil)) (kv "fields" (kv nil nil))))
  387 +;;(db.find "foo" (kv (kv "query" (kv nil nil)) (kv "orderby" (kv "k" 1)) ) :limit 0)
36 src/document.lisp
@@ -99,42 +99,6 @@ is supplied.
99 99 doc)))
100 100
101 101
102   -(defgeneric bson-encode-container ( container &key )
103   - (:documentation "encode a container of key-value pairs.."))
104   -
105   -;;(defmethod bson-encode-container ( (container array) )
106   -;; container)
107   -(defmethod bson-encode-container ( (container pair) &key (array nil) (size 10) )
108   - (bson-encode-container (kv->ht container) :array array :size size))
109   -
110   -(defmethod bson-encode-container ( (container document) &key (array nil) (size 10) )
111   - (setf (gethash "_id" (elements container)) (_id container))
112   - (bson-encode-container (elements container) :array array :size size))
113   -
114   -(defmethod bson-encode-container ( (container hash-table) &key (array nil) (size nil) )
115   - (let* ((size (or size 10))
116   - (array (or array (make-octet-vector size))))
117   - (add-octets (int32-to-octet 0) array )
118   - (with-hash-table-iterator (iterator container)
119   - (dotimes (repeat (hash-table-count container))
120   - (multiple-value-bind (exists-p key value) (iterator)
121   - (if exists-p (add-octets (bson-encode key value) array :start 4 :from-end 1)))))
122   - (normalize-array array)))
123   -
124   -(defmethod bson-encode ( (key string) (value hash-table) &key (array nil array-supplied-p)
125   - (size 10 size-supplied-p)
126   - (type nil) (encoder nil))
127   - (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
128   - (ignore size-supplied-p) (ignore array-supplied-p) )
129   - (bson-encode key (bson-encode-container value :array (make-octet-vector (* (hash-table-count value) 12)))))
130   -
131   -(defmethod bson-encode ( (key string) (value document) &key (array nil array-supplied-p)
132   - (size 10 size-supplied-p)
133   - (type nil) (encoder nil))
134   - (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
135   - (ignore size-supplied-p) (ignore array-supplied-p) )
136   - (bson-encode key (bson-encode-container value )))
137   -
138 102 (defgeneric doc-elements (document) )
139 103
140 104 (defmethod doc-elements ( (document hash-table) )
92 src/mongo-syntax.lisp
... ... @@ -0,0 +1,92 @@
  1 +(in-package :cl-mongo)
  2 +
  3 +(defmacro construct-$+- (val arg &rest args)
  4 + (let ((kvc (gensym)))
  5 + `(let ((kvc (kv ,arg ,val)))
  6 + (dolist (el (list ,@args))
  7 + (setf kvc (kv kvc (kv el ,val))))
  8 + kvc)))
  9 +
  10 +(defmacro $- (arg &rest args)
  11 + `(construct-$+- 0 ,arg ,@args))
  12 +
  13 +(defmacro $+ (arg &rest args)
  14 + `(construct-$+- +1 ,arg ,@args))
  15 +
  16 +(defmacro expand-selector (&rest args)
  17 + `(let ((result ,@args))
  18 + (cond ( (typep result 'kv-container) result)
  19 + ( (typep result 'pair) result)
  20 + ( (null result) result)
  21 + ( t ($+ result)))))
  22 +
  23 +(defun op-split (lst &optional (accum ()))
  24 + (if (null (cdr lst))
  25 + (values (nreverse accum) (car lst))
  26 + (op-split (cdr lst) (cons (car lst) ))))
  27 +
  28 +(defun unwrap (lst)
  29 + (if (cdr lst)
  30 + lst
  31 + (unwrap (car lst))))
  32 +
  33 +(defmacro $op* (op &rest args)
  34 + (let ((keys (gensym))
  35 + (key (gensym))
  36 + (kvc (gensym))
  37 + (val (gensym)))
  38 + `(multiple-value-bind (keys val) (op-split (unwrap (list ,@args)))
  39 + (let ((kvc (kv (car keys) (kv ,op val))))
  40 + (dolist (key (cdr keys))
  41 + (setf kvc (kv kvc (kv key (kv ,op val)))))
  42 + kvc))))
  43 +(defun map-reduce-op (op lst)
  44 + (reduce (lambda (x y) (kv x y) ) (mapcar (lambda (l) ($op* op l) ) lst)))
  45 +
  46 +(defmacro $op (op &rest args)
  47 + `(cond ( (consp (car ',args)) (map-reduce-op ,op ',args))
  48 + ( t ($op* ,op ',args))))
  49 +
  50 +(defmacro $> (&rest args)
  51 + `($op "$gt" ,@args))
  52 +
  53 +(defmacro $>= (&rest args)
  54 + `($op "$gte" ,@args))
  55 +
  56 +(defmacro $< (&rest args)
  57 + `($op "$lt" ,@args))
  58 +
  59 +(defmacro $<= (&rest args)
  60 + `($op "$lte" ,@args))
  61 +
  62 +(defmacro $!= (&rest args)
  63 + `($op "$ne" ,@args))
  64 +
  65 +(defmacro $in (&rest args)
  66 + `($op "$in" ,@args))
  67 +
  68 +(defmacro $!in (&rest args)
  69 + `($op "$nin" ,@args))
  70 +
  71 +(defmacro $mod (&rest args)
  72 + `($op "$mod" ,@args))
  73 +
  74 +(defmacro $all (&rest args)
  75 + `($op "$all" ,@args))
  76 +
  77 +(defmacro $exists (&rest args)
  78 + `($op "$exists" ,@args))
  79 +
  80 +(defun empty-str(str)
  81 + (if (and str (zerop (length str)))
  82 + (format nil "\"\"")
  83 + str))
  84 +
  85 +(defmacro $/ (regex options)
  86 + `(make-bson-regex (empty-str ,regex) ,options))
  87 +
  88 +
  89 +
  90 +;($op "$gte" "k" "l" 5)
  91 +;($op "$gte" '("k" "l" 5))
  92 +;($tbd op ("l" "m" 60) ("k" 3))
95 src/mongo.lisp
@@ -81,10 +81,11 @@ Each connection is a added to a global registry."))
81 81 (usocket:socket-stream (socket mongo)))
82 82
83 83 (defgeneric mongo (&key host port db name)
84   - (:documentation " This method returns the connection referred to by the name identifier from
85   -the connection registry. The connection name is unique.
86   -If no connection with that name exists, a new connection with the supplied or default host, port and db
87   -parameters will be created. The default host is localhost; the default port is 27017; the default db is admin."))
  84 + (:documentation " This method returns the connection referred to by
  85 +the name identifier from the connection registry. The connection name is unique.
  86 +If no connection with that name exists, a new connection with the supplied or default
  87 +host, port and db parameters will be created. The default host is localhost;
  88 +the default port is 27017; the default db is admin."))
88 89
89 90 (defmethod mongo ( &key (host *mongo-default-host*) (port *mongo-default-port*)
90 91 (db *mongo-default-db*) (name :default) )
@@ -100,8 +101,8 @@ parameters will be created. The default host is localhost; the default port is
100 101 (defgeneric mongo-close ( name )
101 102 (:documentation "Close the connection to the mongo database.
102 103 The name should uniquely identify the connection to close.
103   -This is either a mongo object or the name the object is bound to in the connection registry.
104   -To close all open connections use the special symbol 'all"))
  104 +This is either a mongo object or the name the object is bound to
  105 +in the connection registry. To close all open connections use the special symbol 'all"))
105 106
106 107 (defmethod mongo-close ( (mongo mongo) )
107 108 (let ((name (name mongo)))
@@ -127,7 +128,7 @@ To close all open connections use the special symbol 'all"))
127 128
128 129 (defgeneric mongo-swap (left right)
129 130 (:documentation "Swap the names of the left and right connections. Typical use would be
130   -`(swap-connection :default :alt)`. After the function call :default will refer to the connection
  131 +`(mongo-swap :default :alt)`. After the function call :default will refer to the connection
131 132 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
132 133 swapped between them). To re-open a connection you can say
133 134 `(mongo-close (mongo-swap :default (mongo :host <newhost> :portid <portid> :name :temp)))`
@@ -162,12 +163,20 @@ and a new default connection is registered." ))
162 163 (defgeneric mongo-message (mongo message &key )
163 164 (:documentation "message to/from mongo.."))
164 165
165   -(defun test-for-readback (stream timeout)
166   - #+clisp (socket:socket-status stream timeout)
  166 +(defun test-for-readback* (stream timeout)
167 167 (declare (ignore timeout))
168   - #-(or clisp) (listen stream))
  168 + (listen stream))
169 169
170   -(defmethod mongo-message ( (mongo mongo) (message array) &key (timeout 5) )
  170 +#+clisp (defun test-for-readback-clisp (stream timeout)
  171 + (multiple-value-bind (direction status) (socket:socket-status (cons stream :INPUT) timeout)
  172 + (declare (ignore status))
  173 + (when direction t)))
  174 +
  175 +(defun test-for-readback (stream timeout)
  176 + #-(or clisp) (test-for-readback* stream timeout)
  177 + #+clisp (test-for-readback-clisp stream timeout))
  178 +
  179 +(defmethod mongo-message ( (mongo mongo) (message array) &key (timeout 5) )
171 180 (write-sequence message (mongo-stream mongo))
172 181 (force-output (mongo-stream mongo))
173 182 (usocket:wait-for-input (list (socket mongo) ) :timeout timeout)
@@ -182,11 +191,8 @@ and a new default connection is registered." ))
182 191 reply))
183 192 nil))
184 193
185   -
186   -
187 194 (defgeneric db.use ( db &key )
188   - (:documentation "
189   -Use a database on the mongo server. Opens a connection if one isn't already
  195 + (:documentation "Use a database on the mongo server. Opens a connection if one isn't already
190 196 established. (db.use -) can be used to go to a previosuly visited database,
191 197 similar to cd -. "))
192 198
@@ -223,3 +229,62 @@ similar to cd -. "))
223 229 (declare (ignore value))
224 230 (when exists-p (push key lst)))))
225 231 (nreverse lst)))
  232 +
  233 +(defun connection? (name)
  234 + (if (car (multiple-value-list (gethash name (mongo-registry)))) t nil))
  235 +
  236 +(defun default? ()
  237 + (connection? :default))
  238 +
  239 +(defun switch-default-connection (name &key (host "localhost") (db "test") (port +MONGO-PORT+) )
  240 + (if (default?)
  241 + (mongo-swap :default (make-mongo :host host :db db :port port :name name ))
  242 + (make-mongo :host host :db db :port port :name :default)))
  243 +
  244 +(defun restore-default-connection (name)
  245 + (if (connection? name)
  246 + (mongo-close (mongo-swap :default name))
  247 + (mongo-close :default)))
  248 +
  249 +#|
  250 +(defmacro with-mongo-connection ( (var . args) &rest body)
  251 + "Creates a connection to a mongodb, binds it to var and evaluates the body form.
  252 + args is passed on to make-mongo when the connection is created.
  253 + Caller should reference var in the body form where appropriate.."
  254 + (let ((connection-name (gensym)))
  255 + `(let ((,connection-name (gensym)))
  256 + (unwind-protect
  257 + (multiple-value-prog1
  258 + (let ((,var (switch-default-connection ,connection-name ,@args)))
  259 + ,@body))
  260 + (restore-default-connection ,connection-name)))))
  261 +|#
  262 +
  263 +(defmacro with-mongo-connection ( args &rest body)
  264 + "Creates a connection to a mongodb, makes it the default connection
  265 + and evaluates the body form.
  266 + args uses the same keyword set as mongo (:db. :localhost :port)
  267 + args is passed on to make-mongo when the connection is created."
  268 + (let ((connection-name (gensym)))
  269 + `(let ((,connection-name (gensym)))
  270 + (unwind-protect
  271 + (multiple-value-prog1
  272 + (progn (switch-default-connection ,connection-name ,@args)
  273 + ,@body))
  274 + (restore-default-connection ,connection-name)))))
  275 +
  276 +#|
  277 +(with-mongo-connection (mongo :db "test")
  278 + (pp (iter (db.find "foo" :all :mongo mongo))))
  279 +
  280 +
  281 +(with-mongo-connection (mongo)
  282 + (format t "-> mongo ~A~%" mongo))
  283 +
  284 +(with-mongo-connection (mongo)
  285 + (show :connections))
  286 +
  287 +(with-mongo-connection (mongo :db "test")
  288 + (pp (iter (db.find "foo" :all :mongo mongo) :mongo mongo)))
  289 +
  290 +|#
10 src/packages.lisp
... ... @@ -1,7 +1,7 @@
1 1 (in-package #:cl-user)
2 2
3 3 (defpackage #:cl-mongo
4   - (:use #:common-lisp #:babel #:uuid #:usocket)
  4 + (:use #:common-lisp #:babel #:uuid #:usocket )
5 5 (:export
6 6
7 7 ;;
@@ -22,7 +22,7 @@
22 22 :mongo-show
23 23 :mongo-close
24 24 :mongo-swap
25   -
  25 + :with-mongo-connection
26 26 :kv
27 27
28 28 :db.create-collection
@@ -31,6 +31,7 @@
31 31 :db.update
32 32 :db.save
33 33 :db.find
  34 + :db.sort
34 35 :db.next
35 36 :db.iter
36 37 :db.stop
@@ -56,8 +57,9 @@
56 57 :docs
57 58 :now
58 59 :show
59   -
60   - :exp-test
  60 + ;; syntax expansion
  61 + :$+
  62 + :$-
61 63
62 64 ;; documentation generator
63 65 :generate-readme
123 src/pair.lisp
@@ -19,9 +19,57 @@
19 19 (:constructor pair (key value)))
20 20 key value)
21 21
22   -(defgeneric kv (a b &rest rest)
23   - (:documentation "
24   -This a helper function for key-value pairs and sets of key-value pairs.
  22 +(defclass kv-container ()
  23 + ((container :initform (make-array 2 :fill-pointer 0 :adjustable t) :accessor container)))
  24 +
  25 +(defmethod print-object ( (kv-container kv-container) stream)
  26 + (format stream "kv-container : ~A " (container kv-container)))
  27 +
  28 +(defun make-kv-container ()
  29 + (make-instance 'kv-container ))
  30 +
  31 +(defgeneric kv-container-push (el cont))
  32 +
  33 +(defmethod kv-container-push ( (el t) (kv-container kv-container) )
  34 + (vector-push-extend el (container kv-container)))
  35 +
  36 +(defgeneric kv-container-pop (cont))
  37 +
  38 +(defmethod kv-container-pop ( (kv-container kv-container) )
  39 + (unless (eql 0 (fill-pointer (container kv-container))) (vector-pop (container kv-container))))
  40 +
  41 +(defgeneric kv-container-length (cont) )
  42 +
  43 +(defmethod kv-container-length ( (kv-container kv-container) )
  44 + (length (container kv-container)))
  45 +
  46 +(defgeneric kv-container-aref (cont index ))
  47 +
  48 +(defmethod kv-container-aref ( (index integer) (kv-container kv-container) )
  49 + (aref (container kv-container) index ))
  50 +
  51 +(defgeneric kv-container-kv (index cont))
  52 +
  53 +(defmethod kv-container-kv ((index integer) (kv-container kv-container) )
  54 + (let (( pair (kv-container-aref index kv-container)))
  55 + (values (pair-key pair) (pair-value pair))))
  56 +
  57 +(defgeneric kv-container-add (el container))
  58 +
  59 +(defmethod kv-container-add ( (el pair) (kv-container kv-container) )
  60 + (kv-container-push el kv-container)
  61 + kv-container)
  62 +
  63 +(defmethod kv-container-add ( (el kv-container) (kv-container kv-container) )
  64 + (labels ((add (contb)
  65 + (dotimes (index (kv-container-length contb ))
  66 + (let ((el (kv-container-aref index contb)))
  67 + (when el) (kv-container-push el kv-container)))
  68 + kv-container))
  69 + (add el)))
  70 +
  71 +(defgeneric kv (a &rest rest)
  72 + (:documentation " This a helper function for key-value pairs and sets of key-value pairs.
25 73 In a key-value pair like (kv key value) the key has to be a string and the
26 74 value something which is serializable.
27 75 key-value pairs can be combined using kv as well : (kv (kv key1 val1) (kv key2 val2)).
@@ -29,59 +77,33 @@ This combination of key-value pairs is equivalent to a document without a unique
29 77 The server will assign a unique is if a list of key-value pairs is saved."))
30 78
31 79
32   -(defmethod kv ( (a (eql nil) ) (b (eql nil)) &rest rest)
33   - (declare (ignore rest))
34   - (pair nil nil))
  80 +(defmethod kv ( (a (eql nil) ) &rest rest)
  81 + (pair nil (car rest)))
35 82
36 83 ;; basically b can be anything with
37 84 ;; an encoder..
38 85
39   -(defmethod kv ( (a string) b &rest rest)
40   - (declare (ignore rest))
41   - (pair a b))
  86 +(defmethod kv ( (a string) &rest rest)
  87 + (pair a (car rest)))
42 88
43   -(defmethod kv ( (a symbol) b &rest rest)
  89 +(defmethod kv ( (a symbol) &rest rest)
44 90 (declare (ignore rest))
45   - (pair (string-downcase a) b))
46   -
47   -
48   -(defmethod kv ( (a pair) (b pair) &rest rest)
49   - (let ((ht (make-hash-table :test 'equal)))
50   - (setf (gethash (pair-key a) ht) (pair-value a))
51   - (setf (gethash (pair-key b) ht) (pair-value b))
52   - (dolist (el rest)
53   - (setf (gethash (pair-key el) ht) (pair-value el)))
54   - ht))
55   -
56   -;this allows for (kv (kv "a" b) nil ("l" k) ) where
57   -; the nil maybe the result of some test. it's skipped..
58   -(defmethod kv ( (a pair) (b pair) &rest rest)
59   - (let ((ht (make-hash-table :test 'equal)))
60   - (setf (gethash (pair-key a) ht) (pair-value a))
61   - (setf (gethash (pair-key b) ht) (pair-value b))
62   - (dolist (el rest)
63   - (when el (setf (gethash (pair-key el) ht) (pair-value el))))
64   - ht))
  91 + (pair (string-downcase a) (car rest)))
65 92
66   -;this adds more kv's to an existing container..
67   -;I don't check the type of the rest variables,
68   -;assuming they're all pairs..
69   -(defmethod kv ( (ht hash-table) (b pair) &rest rest )
70   - (setf (gethash (pair-key b) ht) (pair-value b))
  93 +(defmethod kv ( (kv-container kv-container) &rest rest )
71 94 (dolist (el rest)
72   - (setf (gethash (pair-key el) ht) (pair-value el)))
73   - ht)
74   -
75   -(defun bson-encode-pair ( kv )
76   - (bson-encode (pair-key kv) (pair-value kv)))
  95 + (when el (kv-container-add el kv-container)))
  96 + kv-container)
77 97
78   -(defmethod bson-encode ( (key string) (value pair) &key (array nil array-supplied-p)
79   - (size 10 size-supplied-p)
80   - (type nil) (encoder nil))
81   - (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
82   - (ignore size-supplied-p) (ignore array-supplied-p) )
83   - (bson-encode key (bson-encode-pair value)))
  98 +(defmethod kv ( (a pair) &rest rest)
  99 + (let ((kvc (make-kv-container) ))
  100 + (kv-container-add a kvc)
  101 + (dolist (el rest)
  102 + (when el (kv-container-add el kvc)))
  103 + kvc))
  104 +
84 105
  106 +;(kv (kv "query" (kv nil nil)) (kv "orderby" (kv "k" 1)))
85 107
86 108 (defgeneric kv->doc ( kv )
87 109 (: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."))
90 112 (let ((doc (make-document)))
91 113 (add-element (pair-key kv) (pair-value kv) doc)))
92 114
  115 +(defmethod kv->doc ( (kv-container kv-container) )
  116 + (let ((doc (make-document)))
  117 + (dotimes (index (kv-container-length kv-container))
  118 + (let ((kv (kv-container-aref index kv-container)))
  119 + (add-element (pair-key kv) (pair-value kv) doc)))))
  120 +
93 121 (defmethod kv->doc ( (kv hash-table) )
94 122 (ht->document kv))
95 123
@@ -104,3 +132,6 @@ The server will assign a unique is if a list of key-value pairs is saved."))
104 132 (defmethod kv->ht ( (kv hash-table) )
105 133 kv)
106 134
  135 +(defmethod kv->ht ( (kv-container kv-container) )
  136 + (elements (kv->doc kv-container)))
  137 +
63 src/shell.lisp
@@ -5,33 +5,43 @@
5 5 |#
6 6
7 7 (defun docs ( result )
8   -"
9   -Stop the iterator (if any) and return the list of documents returned by the query.
10   -Typical ue would be in conjunction with db.find like so (docs (iter (db.find 'foo' 'll)))
11   -"
  8 + "Stop the iterator (if any) and return the list of documents returned by the query.
  9 +Typical ue would be in conjunction with db.find like so (docs (iter (db.find 'foo' 'll)))"
12 10 (cadr (db.stop result)))
13 11
14 12 (defun iter ( result &key (mongo nil) (max-per-call 0) )
15   -"
16   -Exhaustively iterate through a query. The maximum number of responses
17   -per query can be specified using the max-per-call keyword.
18   -
19   -"
  13 +"Exhaustively iterate through a query. The maximum number of responses
  14 +per query can be specified using the max-per-call keyword."
20 15 (loop
21 16 (setf result (db.iter result :mongo mongo :limit max-per-call ) )
22 17 (when (zerop (db.iterator result) ) (return result) )))
23 18
24   -(defun rm (result &key (mongo nil) )
25   -"
26   -Delete all the documents returned by a query. This is not an efficient
  19 +(defun rm* (result &key (mongo nil) )
  20 + "Delete all the documents returned by a query. This is not an efficient
27 21 way of deleting documents as it invloves multiple trips to the server.
28 22 Mongo allows for execution of java-script on the server side, which provides
29 23 an alternative. Typical use would be (rm (iter (db.find 'foo' (kv 'key' 1)))),
30   -which deletes all documents in foo, with field key equal to 1.
31   -"
  24 +which deletes all documents in foo, with field key equal to 1."
32 25 (multiple-value-bind (iterator collection docs) (db.iterator result)
33 26 (db.stop iterator :mongo mongo)
34 27 (db.delete collection docs)))
  28 +;;
  29 +;; rm is is set up to handle insert/delete race conditions which may appear..
  30 +;;
  31 +(defun rm (collection query &key (mongo nil) )
  32 + "Delete all the documents returned by a query. This is not an efficient
  33 +way of deleting documents as it invloves multiple trips to the server.
  34 +Mongo allows for execution of java-script on the server side, which provides
  35 +an alternative. Typical use would be (rm (iter (db.find 'foo' (kv 'key' 1)))),
  36 +which deletes all documents in foo, with field key equal to 1."
  37 + (labels ((server-count()
  38 + (get-element "n" (car (docs (db.count collection :all :mongo mongo)))))
  39 + (delete-docs ()
  40 + (db.delete collection (docs (iter (db.find collection query :mongo mongo))) :mongo mongo)))
  41 + (do ((line (server-count)
  42 + (server-count)))
  43 + ((zerop line ))
  44 + (delete-docs))))
35 45
36 46 (defgeneric pp (result &key)
37 47 (:documentation "
@@ -170,6 +180,15 @@ the profile and more. Things is a keyword so (show 'users) will show all users."
170 180 (defmethod show :after ( (things (eql :databases)) &key)
171 181 (db.use -))
172 182
  183 +(defmethod show ( (things (eql :buildinfo)) &key (order '("version" "sysInfo" "gitVersion" :rest)) )
  184 + (show (lambda () (db.run-command :buildinfo)) :order order :nl t))
  185 +
  186 +(defmethod show :before ( (things (eql :buildinfo)) &key)
  187 + (db.use "admin"))
  188 +
  189 +(defmethod show :after ( (things (eql :buildinfo)) &key)
  190 + (db.use -))
  191 +
173 192 (defmethod show ( (things (eql :users)) &key (order '("user" "pwd") ))
174 193 (show (lambda () (db.find "system.users" 'all)) :order order))
175 194
@@ -179,14 +198,14 @@ the profile and more. Things is a keyword so (show 'users) will show all users."
179 198 (defmethod show ( (things (eql :assertinfo)) &key (order '(:rest)))
180 199 (show (lambda () (db.run-command things)) :order order :nl t))
181 200
182   -(defmethod show ( (things (eql :errors)) &key (order '(:rest)))
183   - (show (lambda () (db.run-command :getlasterror)) :order order :msg "last error : ")
184   - (show (lambda () (db.run-command :getpreverror)) :order order :msg "prev error : "))
185 201
186   -(defgeneric exp-test (arg))
  202 +(defmethod show ( (things (eql :lasterror)) &key (order '(:rest)))
  203 + (show (lambda () (db.run-command :getlasterror)) :order order :msg "last error : "))
  204 +
  205 +(defmethod show ( (things (eql :preverror)) &key (order '(:rest)))
  206 + (show (lambda () (db.run-command :getpreverror)) :order order :msg "last error : "))
187 207
188   -(defmethod exp-test ( (arg (eql :hello)) )
189   - (format t "hello"))
  208 +(defmethod show ( (things (eql :errors)) &key (order '(:rest)))
  209 + (show :lasterror)
  210 + (show :preverror))
190 211
191   -(defmethod exp-test ( (arg string) )
192   - (format t "hello : ~A" arg))
10 test/package.lisp
... ... @@ -0,0 +1,10 @@
  1 +(in-package #:cl-user)
  2 +
  3 +(defpackage #:cl-mongo-test
  4 + (:use #:common-lisp #:cl-mongo #:lisp-unit)
  5 + (:export
  6 +
  7 + ;;
  8 + ;; TBD
  9 +
  10 + ))
160 test/regression.lisp
... ... @@ -0,0 +1,160 @@
  1 +(in-package :cl-mongo-test)
  2 +
  3 +(defvar *test-collection* "foo" "name of the test collection")
  4 +
  5 +(defun force-single-float (n)
  6 + (coerce n 'single-float))
  7 +
  8 +(defun geometric-range* (base length accum factor)
  9 + (if (zerop length)
  10 + (mapcar #'floor (nreverse accum))
  11 + (geometric-range* base (decf length) (cons (* (* factor base) (car accum)) accum) factor)))
  12 +
  13 +(defun geometric-range (base length &optional (factor 1))
  14 + (geometric-range* base (decf length) (list base) factor))
  15 +
  16 +(defun reset-test-collection (collection size &optional (wait 0) )
  17 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  18 + (rm collection :all)
  19 + (let ((count (length (docs (iter (db.find collection :all))))))
  20 + (assert-eql t (zerop count))))
  21 + (insert-lots collection size)
  22 + (sleep wait)
  23 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  24 + (let ((count (length (docs (iter (db.find collection :all))))))
  25 + (assert-eql size count))))
  26 +
  27 +;--------------------------------------------------------------------------------------
  28 +
  29 +(defun count-documents ( &optional (collection *test-collection*) &key (size 5) )
  30 + (reset-test-collection collection size)
  31 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  32 + (let ((client-count (length (docs (iter (db.find collection :all)))))
  33 + (server-count (get-element "n" (car (docs (db.count collection :all))))))
  34 + (format t "client count : ~A -- server count ~A ~%" client-count server-count)
  35 + (assert-eql (force-single-float client-count)
  36 + (force-single-float (float server-count))
  37 + "testing wether client and server count are equal")))
  38 + (reset-test-collection collection 0))
  39 +
  40 +(defun find-doc-by-field ( &optional (collection *test-collection*) &key (size 5))
  41 + (reset-test-collection collection size)
  42 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  43 + (let ((found (length (docs (iter (db.find collection (kv "name" "simple")))))))
  44 + (format t "findOne is default : ~A ~%" found)
  45 + (assert-eql 1 found)))
  46 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  47 + (let ((found (length (docs (iter (db.find collection (kv "name" "simple") :limit 0))))))
  48 + (format t "limit == 0 returns all : ~A ~%" found)
  49 + (assert-eql size found )))
  50 + (reset-test-collection collection 0))
  51 +
  52 +
  53 +(defun delete-docs (&optional (collection *test-collection*) &key (size 5) )
  54 + (reset-test-collection collection size)
  55 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  56 + (let ((cnt (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
  57 + (unless (> cnt 0) (insert-lots collection size)))
  58 + (rm collection :all)
  59 + (let ((cnt (* 1.0 (get-element "n" (car (docs (db.count collection :all)))))))
  60 + (assert-eql 0.0 (force-single-float cnt) "deleting all documents" size)))
  61 + (reset-test-collection collection 0))
  62 +
  63 +(defun db.find-regression-all (&optional (collection *test-collection*) &key (size 5))
  64 + (reset-test-collection collection size 3)
  65 +;;;test retrieval of all documents with an iterator..
  66 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  67 + (let ((all (length (docs (iter (db.find "foo" :all))))))
  68 + (assert-equal size all)))
  69 +;;; get the first document (this is not indexed so index may fail ro be equal to 0...
  70 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  71 + (let* ((documents (docs (iter (db.find "foo" :all :limit 1))))
  72 + (index (get-element "index-this" (car documents))))
  73 + (assert-equal 1 (length documents))
  74 + (assert-equal 0 index "assuming first document has index 0")))
  75 +;;; test of skip; skip the first (size - floor (* size 0.5))
  76 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  77 + (let* ((documents (docs (iter (db.find "foo" :all :limit 0 :skip (floor (* 0.5 size))))))
  78 + (skip (floor (* 0.5 size)))
  79 + (first-index (get-element "index-this" (car documents)))
  80 + (last-index (get-element "index-this" (car (nreverse documents))))
  81 + (expected-count (- size skip))
  82 + (expected-last-index (decf size)))
  83 + (assert-equal expected-count (length documents))
  84 + (assert-equal skip first-index "assuming first document has index 0")
  85 + ;;(mapcar (lambda (d) (format t "~A;" (get-element "index-this" d))) (nreverse documents))
  86 + (assert-equal expected-last-index last-index "assuming first document has index 0")))
  87 + (reset-test-collection collection 0))
  88 +
  89 +(defun db-sort-regression (&optional (collection *test-collection*) &key (size 5))
  90 + (reset-test-collection collection size)
  91 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  92 + (let* ((ret (docs (iter (db.sort collection :all :field "k" :selector "k" ))))
  93 + (elem (mapcar (lambda (d) (get-element "k" d)) ret)))
  94 + (format t "elem : ~A ~%" elem)
  95 + (reduce (lambda (x y) (progn (assert-eql t (< x y) x y ) y)) elem)))
  96 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  97 + (let* ((ret (docs (iter (db.sort collection :all :field "k" :selector "k" :asc nil))))
  98 + (elem (mapcar (lambda (d) (get-element "k" d)) ret)))
  99 + (format t "elem : ~A ~%" elem)
  100 + (reduce (lambda (x y) (progn (assert-eql t (> x y) x y ) y)) elem)))
  101 + (reset-test-collection collection 0))
  102 +
  103 +(defun map-reduce-truth (tv l)
  104 + (reduce (lambda (x y) (and x y) ) (mapcar (lambda (x) (assert-eql tv (when x t) x)) l)))
  105 +
  106 +(defun db-find-selector-regression (&optional (collection *test-collection*) &key (size 5))
  107 + (reset-test-collection collection size)
  108 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  109 + (let* ((ret (docs (iter (db.find collection :all :selector ($+ "k" "l") ))))
  110 + (ks (mapcar (lambda (d) (get-element "k" d)) ret))
  111 + (ls (mapcar (lambda (d) (get-element "l" d)) ret))
  112 + (excl (mapcar (lambda (d) (get-element "index-this" d)) ret)))
  113 + (format t "elem : ~A ~%" ks)
  114 + (assert-eql t (map-reduce-truth t ks))
  115 + (format t "elem : ~A ~%" ls)
  116 + (assert-eql t (map-reduce-truth t ls))
  117 + (format t "elem : ~A ~%" excl)
  118 + (assert-eql t (map-reduce-truth nil excl))))
  119 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  120 + (let* ((ret (docs (iter (db.find collection :all :selector ($- "k" "l") ))))
  121 + (ks (mapcar (lambda (d) (get-element "k" d)) ret))
  122 + (ls (mapcar (lambda (d) (get-element "l" d)) ret))
  123 + (excl (mapcar (lambda (d) (get-element "index-this" d)) ret)))
  124 + (format t "elem : ~A ~%" ks)
  125 + (assert-eql t (map-reduce-truth nil ks))
  126 + (format t "elem : ~A ~%" ls)
  127 + (assert-eql t (map-reduce-truth nil ls))
  128 + (format t "elem : ~A ~%" excl)
  129 + (assert-eql t (map-reduce-truth t excl))))
  130 + (reset-test-collection collection 0))
  131 +
  132 +;;--------------------------------------------------------------------------
  133 +
  134 +(defun test-delete (&optional (collection *test-collection*))
  135 + (dolist (size (geometric-range 10 5 ))
  136 + (delete-docs collection :size size)))
  137 +
  138 +(defun test-query-field-selection (&optional (collection *test-collection*))
  139 + (dolist (size (geometric-range 5 5 ))
  140 + (find-doc-by-field *test-collection* :size size)))
  141 +
  142 +(defun test-document-count (&optional (collection *test-collection*))
  143 + (dolist (size (geometric-range 5 5 ))
  144 + (count-documents *test-collection* :size size)))
  145 +
  146 +(defun test-find-all (&optional (collection *test-collection*))
  147 + (dolist (size (geometric-range 2 4 5 ))
  148 + (db.find-regression-all collection :size size)))
  149 +
  150 +(defun test-sort (&optional (collection *test-collection*))
  151 + (dolist (size (geometric-range 2 4))
  152 + (db-sort-regression collection :size (* 10 size))))
  153 +
  154 +(defun test-find-selector (&optional (collection *test-collection*))
  155 + (dolist (size (geometric-range 2 4))
  156 + (db-find-selector-regression collection :size size)))
  157 +
  158 +;;;;;;;;;;;;;
  159 +
  160 +
58 test/test-utils.lisp
... ... @@ -0,0 +1,58 @@
  1 +(in-package :cl-mongo-test)
  2 +
  3 +(defun send-doc-in-doc-in-doc (collection)
  4 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  5 + (let ((doc (make-document)))
  6 + (add-element "string" "hello world generated by test-document" doc)
  7 + (add-element "number89" 89 doc)
  8 + (add-element "numberbig" 89988787777887 doc)
  9 + (add-element "float 89.67" 89.67 doc)
  10 + (add-element "list-1" (list 1 2 3 4) doc)
  11 + (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
  12 + (let ((doc2 (make-document)))
  13 + (add-element "key-1" "doc in doc !!" doc2)
  14 + (add-element "key-2" 56.89 doc2)
  15 + (let ((doc3 (make-document)))
  16 + (add-element "array" (list (list (list "inside a nest!!"))) doc3)
  17 + (add-element "key56" 56 doc3)
  18 + (add-element "doc3" doc3 doc2)
  19 + (add-element "doc2" doc2 doc)
  20 + (db.insert collection doc ))))))
  21 +
  22 +
  23 +(defun test-doc-simple (collection)
  24 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  25 + (let ((doc (make-document)))
  26 + (add-element "string" "hello world generated by test-document" doc)
  27 + (add-element "1" 1 doc)
  28 + (add-element "2" 2 doc)
  29 + (add-element "3" 3 doc)
  30 + (add-element "4" 40 doc)
  31 + (add-element "5" 30 doc)
  32 + (db.insert collection doc ))))
  33 +
  34 +(defun send-test-document ( collection )
  35 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  36 + (let ((doc (make-document)))
  37 + (add-element "string" "hello world generated by test-document" doc)
  38 + (add-element "number89" 89 doc)
  39 + (add-element "numberbig" 89988787777887 doc)
  40 + (add-element "float 89.67" 89.67 doc)
  41 + (add-element "list-1" (list 1 2 3 4) doc)
  42 + (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
  43 + (db.insert collection doc ))))
  44 +
  45 +(defun insert-lots (collection n)
  46 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  47 + (dotimes (i n)
  48 + (let ((doc (make-document)))
  49 + (add-element (format nil "name") "simple" doc)
  50 + (add-element (format nil "~D" i) i doc)
  51 + (add-element (format nil "k") (+ 56.00 i) doc)
  52 + (add-element (format nil "l") (- i 9.00) doc)
  53 + (add-element (format nil "index-this") i doc)
  54 + (add-element (format nil "value-1") (* 78 i) doc)
  55 + (db.insert collection doc )))))
  56 +
  57 +
  58 +
128 test/test.lisp
... ... @@ -1,6 +1,6 @@
1 1 (in-package :cl-mongo-test)
2 2
3   -
  3 +#|
4 4 (defun gtb ( loc )
5 5 (let ((res 255))
6 6 (dotimes (var loc)
@@ -23,9 +23,7 @@
23 23 (format t "value ~A ~%" value)
24 24 (octet-to-int64 (int64-to-octet value))))
25 25
26   -#|
27 26
28   -|#
29 27 (defun write-array(port array)
30 28 (let (( socket (usocket:socket-connect "localhost" port :element-type '(unsigned-byte 8))))
31 29 (write-sequence array (usocket:socket-stream socket))
@@ -181,15 +179,6 @@
181 179 (assert (eql docs (length elements)))
182 180 (assert (eql (total-length elements) (- tot-size offset)))))
183 181
184   -(defun send-test-document ( collection )
185   - (let ((doc (make-document)))
186   - ;(add-element "string" "hello world generated by test-document" doc)
187   - ;(add-element "number89" 89 doc)
188   - ;(add-element "numberbig" 89988787777887 doc)
189   - ;(add-element "float 89.67" 89.67 doc)
190   - ;(add-element "list-1" (list 1 2 3 4) doc)
191   - ;(add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
192   - (db.insert collection doc )))
193 182
194 183 (defun send-doc-in-doc ( collection )
195 184 (let ((doc (make-document)))
@@ -205,42 +194,91 @@
205 194 (add-element "doc2" doc2 doc)
206 195 (db.insert collection doc ))))
207 196
  197 +
  198 +|#
  199 +
208 200 (defun send-doc-in-doc-in-doc (collection)
209   - (let ((doc (make-document)))
210   - (add-element "string" "hello world generated by test-document" doc)
211   - (add-element "number89" 89 doc)
212   - (add-element "numberbig" 89988787777887 doc)
213   - (add-element "float 89.67" 89.67 doc)
214   - (add-element "list-1" (list 1 2 3 4) doc)
215   - (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
216   - (let ((doc2 (make-document)))
217   - (add-element "key-1" "doc in doc !!" doc2)
218   - (add-element "key-2" 56.89 doc2)
219   - (let ((doc3 (make-document)))
220   - (add-element "array" (list (list (list "inside a nest!!"))) doc3)
221   - (add-element "key56" 56 doc3)
222   - (add-element "doc3" doc3 doc2)
223   - (add-element "doc2" doc2 doc)
224   - (db.insert collection doc )))))
  201 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  202 + (let ((doc (make-document)))
  203 + (add-element "string" "hello world generated by test-document" doc)
  204 + (add-element "number89" 89 doc)
  205 + (add-element "numberbig" 89988787777887 doc)
  206 + (add-element "float 89.67" 89.67 doc)
  207 + (add-element "list-1" (list 1 2 3 4) doc)
  208 + (add-element "list-2" (list 1 (list "inside" 3 4 "list" ) "the end") doc)
  209 + (let ((doc2 (make-document)))
  210 + (add-element "key-1" "doc in doc !!" doc2)
  211 + (add-element "key-2" 56.89 doc2)
  212 + (let ((doc3 (make-document)))
  213 + (add-element "array" (list (list (list "inside a nest!!"))) doc3)
  214 + (add-element "key56" 56 doc3)
  215 + (add-element "doc3" doc3 doc2)
  216 + (add-element "doc2" doc2 doc)
  217 + (db.insert collection doc ))))))
225 218
226 219
227 220 (defun test-doc-simple (collection)
228   - (let ((doc (make-document)))
229   - (add-element "string" "hello world generated by test-document" doc)
230   - (add-element "1" 1 doc)
231   - (add-element "2" 2 doc)
232   - (add-element "3" 3 doc)
233   - (add-element "4" 40 doc)
234   - (add-element "5" 30 doc)
235   - (db.insert collection doc)))
  221 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  222 + (let ((doc (make-document)))
  223 + (add-element "string" "hello world generated by test-document" doc)
  224 + (add-element "1" 1 doc)
  225 + (add-element "2" 2 doc)
  226 + (add-element "3" 3 doc)
  227 + (add-element "4" 40 doc)
  228 + (add-element "5" 30 doc)
  229 + (db.insert collection doc ))))
  230 +
  231 +(defun send-test-document ( collection )
  232 + (with-mongo-connection (:host "localhost" :port *mongo-default-port* :db "test" )
  233 + (let ((doc (make-document)))
  234 + (add-element "string" "hello world generated by test-document" doc)
  235 + (add-element "number89" 89 doc)
  236 + (add-element "numberbig" 89988787777887 doc)
  237 + (add-element "float 89.67" 89.67 doc)
  238 + (add-element "list-1" (list 1 2 3 4) doc)