Skip to content
Browse files

added more encoders; refactoring; updates

  • Loading branch information...
1 parent 2c905d3 commit 5ee42777e3bc763713faaf0e5df0049762624868 fons committed Jan 23, 2010
Showing with 238 additions and 117 deletions.
  1. +2 −1 cl-mongo.asd
  2. +1 −1 src/bson-array.lisp
  3. 0 src/{oid.lisp → bson-oid.lisp}
  4. +69 −0 src/bson-time.lisp
  5. +90 −79 src/bson.lisp
  6. +33 −9 src/db.lisp
  7. +2 −0 src/document.lisp
  8. +3 −0 src/octets.lisp
  9. +14 −1 src/packages.lisp
  10. +12 −19 src/pair.lisp
  11. +3 −3 src/protocol.lisp
  12. +6 −0 src/shell.lisp
  13. +3 −4 test/test.lisp
View
3 cl-mongo.asd
@@ -22,7 +22,8 @@
(:file "packages")
(:file "octets")
(:file "encode-float")
- (:file "oid")
+ (:file "bson-oid")
+ (:file "bson-time")
(:file "pair")
(:file "bson")
(:file "bson-array")
View
2 src/bson-array.lisp
@@ -95,7 +95,7 @@ A note of the bson-array design
(let* ((size (if size-supplied-p size 10))
(array (if array-supplied-p array (make-octet-vector size))))
(labels ((encode-value (array)
- (add-octets (array value) array))) ; add value
+ (add-octets (data-array value) array))) ; add value
(call-next-method key value :array array :type type :encoder (if encoder encoder #'encode-value)))))
(defun bson-encode-cons (list stack bson-array-stack)
View
0 src/oid.lisp → src/bson-oid.lisp
File renamed without changes.
View
69 src/bson-time.lisp
@@ -0,0 +1,69 @@
+(in-package :cl-mongo)
+
+(defconstant +java-script-epoch+ 2208988800 "(encode-universal-time 0 0 0 1 1 1970 0)" )
+(defconstant +milliseconds-multiplier+ 1000 "'convert' to milliseconds")
+
+; from the cl cookbook
+(defvar +bt-day-names+ '( "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
+(defvar +bt-months+ '( "xxx" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+
+(defvar *bt-time-zone* 5 "the current time zone; 5 -> EST")
+
+;;(decode-universal-time (floor (* (get-element "time" (car (docs (db.find "foo" 'all)))) 0.001)))
+
+#|
+ bson/mongo uses miliseconds since epoch (1/1/1970 0:0:0 GMT).
+ this encapsulates that concept
+|#
+
+(defun gmt-to-bson-time (gmt)
+ (* +milliseconds-multiplier+ (- gmt +java-script-epoch+)))
+
+(defclass bson-time()
+ ((raw :reader raw :initarg :raw)
+ (local :reader local :initarg :local))
+ (:default-initargs
+ :local t
+ :raw (gmt-to-bson-time (get-universal-time))))
+
+(defun make-bson-time ( &optional raw-time )
+ (if raw-time
+ (make-instance 'bson-time :raw raw-time :local nil)
+ (make-instance 'bson-time)))
+
+(defgeneric decode ( time )
+ (:documentation "decode the bson-time for human consumption"))
+
+(defmethod decode ( (bson-time bson-time) )
+ (decode-universal-time (floor (+ (/ (raw bson-time) +milliseconds-multiplier+) +java-script-epoch+))
+ *bt-time-zone*))
+
+(defgeneric fmt ( bson-time &optional stream)
+ (:documentation "format bson time to be in human readable form"))
+
+(defmethod fmt ( (bson-time bson-time) &optional (stream t))
+ (multiple-value-bind
+ (second minute hour date month year day-of-week dst-p tz) (decode bson-time)
+ (declare (ignore dst-p))
+ (format stream "~a ~a ~d ~d ~2,'0d:~2,'0d:~2,'0d (GMT~@d)"
+ (nth day-of-week +bt-day-names+)
+ (nth month +bt-months+)
+ date
+ year
+ (- hour 0)
+ minute
+ second
+ (- tz))))
+
+(defmethod print-object ((bson-time bson-time) stream)
+ (format stream "~S " (type-of bson-time) )
+ (if (slot-boundp bson-time 'raw)
+ (fmt bson-time stream)
+ "no time set.."))
+
+(defun time-zone ()
+ (setf *bt-time-zone* (car (last (multiple-value-list (get-decoded-time))))))
+
+
+
+
View
169 src/bson.lisp
@@ -1,23 +1,25 @@
(in-package :cl-mongo)
+(defconstant +default-array-size+ 100 "size of default array in the encoder")
+
(defconstant +bson-data-number+ 1 "bson number encoding")
(defconstant +bson-data-string+ 2 "bson string encoding")
(defconstant +bson-data-object+ 3 "bson data array; bson object")
(defconstant +bson-data-array+ 4 "bson array")
(defconstant +bson-data-oid+ 7 "bson oid encoding")
(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-symbol+ 14 "bson symbol encoding")
(defconstant +bson-data-int32+ 16 "bson 32 bit int encoding")
(defconstant +bson-data-long+ 18 "bson 64 bit int encoding")
-
#|
bson-encode encodes a complete bson object.
It includes the obj_size at the start and the terminating null at the end.
When creating composites these need to be skipped or removed..
|#
-(defgeneric bson-encode(key value &key array size type encoder)
- (:documentation "encode a bson data element"))
(defun set-array-length(array &key (start 0 start-supplied-p))
(let* ((head (if start-supplied-p start (fill-pointer array)))) ; save the stack pointer
@@ -26,8 +28,10 @@
(defun null-terminate-array(array)
(add-octets (byte-to-octet 0) array)) ; ending nul
-(defmethod bson-encode(key value &key array size type encoder)
- (declare (ignore size))
+(defgeneric bson-encode(key value &key )
+ (:documentation "encode a bson data element"))
+
+(defmethod bson-encode( (key string) (value t) &key array type encoder)
(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
@@ -37,36 +41,32 @@
(set-octets head (int32-to-octet (- (length array) head) ) array) ; set length
array))
-(defmethod bson-encode( (key (eql nil)) (value (eql nil)) &key (array nil array-supplied-p) size type encoder)
- (declare (ignore size) (ignore type) (ignore encoder) )
- (let ((array (if array-supplied-p array (make-octet-vector 5))))
+
+;;; empty object
+(defmethod bson-encode( (key (eql nil)) (value (eql nil)) &key (array nil))
+ (let ((array (or array (make-octet-vector +default-array-size+))))
(add-octets (int32-to-octet 0) array) ; length, set to zero
(add-octets (byte-to-octet 0) array) ; ending nul
(set-octets 0 (int32-to-octet (length array) ) array) ; set length
array))
-(defmethod bson-encode ( (key integer) value &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type +bson-data-array+) (encoder nil))
- (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
- (ignore size-supplied-p) (ignore array-supplied-p) )
+;;used in arrays, so you can just say (bson-encode 1 ...)
+;;
+(defmethod bson-encode ( (key integer) value &key )
(bson-encode (format nil "~A" key) value))
-(defmethod bson-encode( (key string) (value string) &key (array nil array-supplied-p) (size 10 size-supplied-p)
- (type +bson-data-string+) (encoder nil) )
- (declare (ignore encoder))
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(defmethod bson-encode ( (key string) (value string) &key (array nil) (type +bson-data-string+) )
+ (let ((array (or array (make-octet-vector +default-array-size+))))
(labels ((encode-value (array)
(add-octets (int32-to-octet (1+ (length value)) ) array) ; length of the value string
(add-octets (string-to-null-terminated-octet value) array))) ; value string, null terminated
(call-next-method key value :array array :type type :encoder #'encode-value))))
-(defmethod bson-encode( (key string) (value integer) &key (array nil array-supplied-p) (size 10 size-supplied-p)
- (type +bson-data-int32+) (encoder nil))
- (declare (ignore encoder) (ignore type))
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(defmethod bson-encode ( (key string) (value symbol) &key (array nil) )
+ (bson-encode key (string value) :array array :type +bson-data-symbol+ ))
+
+(defmethod bson-encode( (key string) (value integer) &key (array nil))
+ (let ((array (or array (make-octet-vector +default-array-size+))))
(labels ((encode-value32(array)
(add-octets (int32-to-octet value ) array)) ; value converted to 32 bits
(encode-value64(array)
@@ -75,96 +75,108 @@
(call-next-method key value :array array :type +bson-data-int32+ :encoder #'encode-value32)
(call-next-method key value :array array :type +bson-data-long+ :encoder #'encode-value64)))))
-(defmethod bson-encode( (key string) (value float) &key (array nil array-supplied-p) (size 10 size-supplied-p)
- (type +bson-data-number+) (encoder nil))
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(defmethod bson-encode( (key string) (value float) &key (array nil) )
+ (let ((array (or array (make-octet-vector +default-array-size+))))
(labels ((encode-value(array)
(add-octets (int64-to-octet (encode-double-float-bits value)) array))) ;convert float to octet
- (call-next-method key value :array array :type type :encoder (if encoder encoder #'encode-value)))))
+ (call-next-method key value :array array :type +bson-data-number+ :encoder #'encode-value))))
+(defmethod bson-encode( (key string) (value bson-time) &key (array nil))
+ (let ((array (or array (make-octet-vector +default-array-size+))))
+ (labels ((encode-date(array)
+ (add-octets (int64-to-octet (raw value) ) array))) ; value converted to 64 bits
+ (call-next-method key value :array array :type +bson-data-date+ :encoder #'encode-date))))
+
-(defmethod bson-encode( (key string) (value (eql t)) &key (array nil array-supplied-p) (size 10 size-supplied-p)
- (type +bson-data-boolean+) (encoder nil))
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(defmethod bson-encode-boolean( (key string) value &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 type :encoder (if encoder encoder #'encode-value)))))
-
+ (bson-encode key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
-(defmethod bson-encode( (key string) (value (eql nil)) &key (array nil array-supplied-p) (size 10 size-supplied-p)
- (type +bson-data-boolean+) (encoder nil))
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(defmethod bson-encode ( (key string) (value (eql t)) &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 type :encoder (if encoder encoder #'encode-value)))))
+ (call-next-method key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
+
-(defmethod bson-encode( (key string) (value array) &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type +bson-data-object+) (encoder nil))
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(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))))
+
+;
+; The array type is the parent class of other types like string. So see if a type and encoder is
+; passed in and pass it along..
+(defmethod bson-encode( (key string) (value array) &key (array nil) (type nil) (encoder nil) )
+ (let ((array (or array (make-octet-vector +default-array-size+))))
(labels ((encode-value (array)
(add-octets value array))) ; add value
- (call-next-method key value :array array :type type :encoder (if encoder encoder #'encode-value)))))
+ (call-next-method key value :array array :type (or type +bson-data-object+)
+ :encoder (or encoder #'encode-value)))))
-(defmethod bson-encode ( (key string) (value bson-oid) &key (array nil array-supplied-p) (size 10 size-supplied-p)
- (type +bson-data-oid+) (encoder nil) )
- (let* ((size (if size-supplied-p size 10))
- (array (if array-supplied-p array (make-octet-vector size))))
+(defmethod bson-encode ( (key string) (value bson-oid) &key (array nil) )
+ (let ((array (or array (make-octet-vector +default-array-size+))))
(labels ((encode-value (array)
(add-octets (_id value) array))) ; twelf byte oid
- (call-next-method key value :array array :type type :encoder (if encoder encoder #'encode-value)))))
+ (call-next-method key value :array array :type +bson-data-oid+ :encoder #'encode-value))))
-;;(defgeneric bson-encode-document (document)
-;; (:documentation "encode a document"))
-;;(defmethod bson-encode-document ( (document array) )
-;; document)
-
-;;(defmethod bson-encode-document ( (document document) )
-;; (setf (gethash "_id" (elements document)) (_id document))
-;; (bson-encode-ht (elements document) ))
-
-;; Something like this SHOULD be made to work !
-;; The issue is that bson-encode returns
-;; (bson-encode-ht (elements document) :array (bson-encode "_id" (_id document))))
-
-
-
-(defgeneric bson-type-extract (code array)
+(defgeneric bson-decode (code array)
(:documentation "return data and the remaining array"))
-(defmethod bson-type-extract (code array)
+(defmethod bson-decode ( (code t) (array t) )
(format t "~% code : ~A ~%" code)
(format t "~% array : ~A ~% " array)
(values array (make-octet-vector 1 :init-fill 1)))
-(defmethod bson-type-extract ( (code (eql +bson-data-number+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-number+)) array)
(values (decode-double-float-bits (octet-to-int64 (subseq array 0 8))) (subseq array 8)))
-(defmethod bson-type-extract ( (code (eql +bson-data-string+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-string+)) array)
(let* ((size (octet-to-int32 (subseq array 0 4)))
(str (null-terminated-octet-to-string (subseq array 4 (+ 4 size)) size))
(rest (subseq array (+ 4 size))))
(values str rest)))
-(defmethod bson-type-extract ( (code (eql +bson-data-oid+)) array)
+
+(defmethod bson-decode ( (code (eql +bson-data-symbol+)) array)
+ (multiple-value-bind (str rest) (bson-decode +bson-data-string+ array)
+ (values (intern str) rest)))
+
+(defmethod bson-decode ( (code (eql +bson-data-oid+)) array)
(values (make-bson-oid :oid (subseq array 0 12)) (subseq array 12)))
-(defmethod bson-type-extract ( (code (eql +bson-data-boolean+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-boolean+)) array)
(values (byte-to-bool (octet-to-byte (subseq array 0 1))) (subseq array 1)))
-(defmethod bson-type-extract ( (code (eql +bson-data-int32+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-int32+)) array)
(values (octet-to-int32 (subseq array 0 4)) (subseq array 4)))
-(defmethod bson-type-extract ( (code (eql +bson-data-long+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-long+)) array)
(values (octet-to-int64 (subseq array 0 8)) (subseq array 8)))
+(defmethod bson-decode ( (code (eql +bson-data-null+)) array)
+ (values nil array))
+
+(defmethod bson-decode ( (code (eql +bson-data-date+)) array)
+ (values (make-bson-time (octet-to-uint64 (subseq array 0 8))) (subseq array 8)))
+
+
#|
Compound Types : arrays, objects
This deals with the extraction of data objects, arrays and general replies
@@ -183,7 +195,7 @@
(eos (1+ (position 0 (subseq array 1))))
(key (null-terminated-octet-to-string (subseq array 1 (+ 1 eos)) eos))
(buffer (subseq array (+ 1 eos))))
- (multiple-value-bind (value rest) (bson-type-extract obj-type buffer)
+ (multiple-value-bind (value rest) (bson-decode obj-type buffer)
(extract-elements rest (cons (list obj-type key value ) accum)))))))
(defun to-element (array)
@@ -215,36 +227,35 @@
(rest (subseq array (+ 1 eos))))
(values obj-type key rest)))
-
(defun array@end (array)
(if (array@eoo array)
0
(length array)))
;;this is the same as the 'main' extraction routine to-elements above; so the two should merge..
-(defmethod bson-type-extract ( (code (eql +bson-data-object+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-object+)) array)
(let* ((accum ())
(array-size (octet-to-int32 (subseq array 0 4) ))
(array-buffer (subseq array 4 array-size))
(rest (subseq array array-size)))
(do () ((zerop (array@end array-buffer) ))
(multiple-value-bind (type key rest) (code-key-rest array-buffer)
- (multiple-value-bind (value remainder) (bson-type-extract type rest)
+ (multiple-value-bind (value remainder) (bson-decode type rest)
(setf array-buffer remainder)
(push (list type key value) accum))))
(let ((ht (make-hash-table :test 'equal)))
(mapcar (lambda (x) (setf (gethash (car x) ht) (cadr x))) (mapcar #'cdr accum))
(values (ht->document ht) rest))))
-(defmethod bson-type-extract ( (code (eql +bson-data-array+)) array)
+(defmethod bson-decode ( (code (eql +bson-data-array+)) array)
(let* ((accum ())
(array-size (octet-to-int32 (subseq array 0 4) ))
(array-buffer (subseq array 4 array-size))
(rest (subseq array array-size)))
(do () ((zerop (array@end array-buffer) ))
(multiple-value-bind (type key rest) (code-key-rest array-buffer)
(declare (ignore key))
- (multiple-value-bind (value remainder) (bson-type-extract type rest)
+ (multiple-value-bind (value remainder) (bson-decode type rest)
(setf array-buffer remainder)
;(push (list key value) accum))))
(push value accum))))
View
42 src/db.lisp
@@ -11,19 +11,20 @@
(defmethod db.insert ( (collection string) (document t) &key (mongo nil) )
(let ((mongo (or mongo (mongo))))
- (mongo-message mongo (mongo-insert (full-collection-name mongo collection) document) :timeout 0)))
+ (mongo-message mongo (mongo-insert (full-collection-name mongo collection)
+ (bson-encode-container document)) :timeout 0)))
-(defmethod db.insert ( (collection string) (document hash-table) &key (mongo nil) )
- (call-next-method collection (bson-encode-container document) :mongo mongo))
+;(defmethod db.insert ( (collection string) (document hash-table) &key (mongo nil) )
+; (call-next-method collection (bson-encode-container document) :mongo mongo))
-(defmethod db.insert ( (collection string) (document document) &key (mongo nil) )
- (call-next-method collection (bson-encode-container document) :mongo mongo))
+;(defmethod db.insert ( (collection string) (document document) &key (mongo nil) )
+; (call-next-method collection (bson-encode-container document) :mongo mongo))
-(defmethod db.insert ( (collection string) (kv pair) &key (mongo nil) )
- (call-next-method collection (bson-encode-container (kv->doc kv) ) :mongo mongo))
+;(defmethod db.insert ( (collection string) (kv pair) &key (mongo nil) )
+; (call-next-method collection (bson-encode-container kv ) :mongo mongo))
-(defmethod db.insert ( (collection string) (kv hash-table) &key (mongo nil) )
- (call-next-method collection (bson-encode-container kv) :mongo mongo))
+;(defmethod db.insert ( (collection string) (kv hash-table) &key (mongo nil) )
+; (call-next-method collection (bson-encode-container kv) :mongo mongo))
(defgeneric db.find (collection kv &key)
(:documentation "find a document in the db collection"))
@@ -63,6 +64,29 @@
(call-next-method collection (bson-encode-container kv)
:mongo mongo :options options :skip skip :limit limit :selector selector ))
+(defgeneric db.update ( collection selector new-document &key )
+ (:documentation "find a document and replace it with a new version"))
+
+(defmethod db.update ( (collection string) (selector t) (new-document t)
+ &key (mongo nil) (upsert nil) (multi nil) )
+ (let ((mongo (or mongo (mongo))))
+ (mongo-message mongo (mongo-update
+ (full-collection-name mongo collection)
+ (bson-encode-container selector)
+ (bson-encode-container new-document)
+ :options (update-options :upsert upsert :multi-update multi))
+ :timeout 0)))
+
+
+(defgeneric db.save ( collection document &key)
+ (:documentation "save a document; to insert if no _id is found"))
+
+(defmethod db.save ( (collection string) (document document) &key (mongo nil) )
+ (db.update collection (kv "_id" (_id document) ) document :mongo (or mongo (mongo) ) :upsert t))
+
+(defmethod db.save ( (collection string) (document hash-table) &key (mongo nil) )
+ (db.insert collection document :mongo (or mongo (mongo)) ))
+
(defun headerp (val)
(and (consp val) (= 1 (length val))))
View
2 src/document.lisp
@@ -94,6 +94,8 @@
;;(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))
View
3 src/octets.lisp
@@ -73,6 +73,9 @@
(defun octet-to-int64 (vec)
(to-signed-value (to-val vec 8) :size 63 :max-uint +max-uint64+))
+(defun octet-to-uint64 (vec)
+ (to-val vec 8) )
+
(defun octet-to-byte (vec)
(to-val vec 1))
View
15 src/packages.lisp
@@ -10,11 +10,21 @@
:serverstatus
:deleteindexes
+ ;; document
+ :document
+ :make-document
+ :add-element
+ :get-element
+ :rm-element
+ :ht->document
+
;;commands
:mongo
:kv
:db.use
:db.insert
+ :db.update
+ :db.save
:db.find
:db.next
:db.iter
@@ -26,7 +36,9 @@
:db.collections
:db.count
:close-all-connections
-
+ :time-zone
+ :date-time
+
;; shell commands
:nwd
:cwd
@@ -35,4 +47,5 @@
:nd
:rm
:docs
+ :now
))
View
31 src/pair.lisp
@@ -36,11 +36,7 @@
(declare (ignore rest))
(pair (string-downcase a) b))
-;
-;; TODO -> don't return a cons as that's basically an array,
-;; a compound query is a document/hash table.
-;; when returning a cons --> need to call kv->ht on the cons !!
-;; so you might as well incorporate that stright in here
+
(defmethod kv ( (a pair) (b pair) &rest rest)
(let ((ht (make-hash-table :test 'equal)))
(setf (gethash (pair-key a) ht) (pair-value a))
@@ -49,13 +45,6 @@
(setf (gethash (pair-key el) ht) (pair-value el)))
ht))
-(defmethod kv-alt ( (a pair) (b pair) &rest rest)
- (let ((lst (list b a)))
- (dolist (el rest)
- (push el lst))
- (nreverse lst)))
-
-
(defun bson-encode-pair ( kv )
(bson-encode (pair-key kv) (pair-value kv)))
@@ -74,13 +63,17 @@
(let ((doc (make-document)))
(add-element (pair-key kv) (pair-value kv) doc)))
-(defmethod kv->doc ( (kv cons) )
- (let ((doc (make-document)))
- (dolist (pair kv)
- (add-element (pair-key pair) (pair-value pair) doc))
- doc))
+(defmethod kv->doc ( (kv hash-table) )
+ (ht->document kv))
+(defgeneric kv->ht ( kv )
+ (:documentation "turn a pair of key/value pairs into a hash table"))
+
+(defmethod kv->ht ( (kv pair) )
+ (let ((ht (make-hash-table :test 'equal)))
+ (setf (gethash (pair-key kv) ht) (pair-value kv))
+ ht))
-(defmethod kv->ht ( (kv cons) )
- (elements (kv->doc kv)))
+(defmethod kv->ht ( (kv hash-table) )
+ kv)
View
6 src/protocol.lisp
@@ -11,10 +11,10 @@
(defgeneric mongo-update (collection selector document &key options)
(:documentation "insert function for mongo"))
-(defun update-options ( &key (upsert 0 upsert-p) (multi-update 0 multi-update-p) )
+(defun update-options ( &key (upsert nil) (multi-update nil) )
(let ((value 0))
- (when upsert-p (setf (ldb (byte 1 0) value) upsert))
- (when multi-update-p (setf (ldb (byte 1 1) value) multi-update))
+ (when upsert (setf (ldb (byte 1 0) value) 1))
+ (when multi-update (setf (ldb (byte 1 1) value) 1))
value))
(defmethod mongo-update ( (collection string) (selector array) (document array) &key (options 0) )
View
6 src/shell.lisp
@@ -75,6 +75,12 @@
(defun nd (result &key (stream t) )
(pp result :stream stream :nd t))
+(defun now()
+ (make-bson-time))
+
+(defun date-time (second minute hour day month year &optional (time-zone *bt-time-zone*) )
+ (make-bson-time (gmt-to-bson-time (encode-universal-time second minute hour day month year time-zone))))
+
;(defgeneric index ( collection name action &key )
; (:documentation "shell index managment"))
View
7 test/test.lisp
@@ -1,6 +1,5 @@
-(in-package :cl-mongo)
+(in-package :cl-mongo-test)
-(defconstant +TEST-PORT+ 9999)
(defun gtb ( loc )
(let ((res 255))
@@ -237,13 +236,13 @@
(add-element "5" 30 doc)
(test-insert-doc doc :port +MONGO-PORT+)))
-(defun insert-lots (n)
+(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)
- (test-insert-doc doc :port +MONGO-PORT+))))
+ (db.insert collection doc ))))

0 comments on commit 5ee4277

Please sign in to comment.
Something went wrong with that request. Please try again.