Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

fixed decoder for empty lists; get-elemens support for . operator

  • Loading branch information...
commit 1df2e8664b99532a87d1f5e395e68e7699dae039 1 parent a89a7cc
@fons authored
View
25 src/bson-decode.lisp
@@ -7,13 +7,12 @@
(defun end-of-key (start array)
(let ((eol start))
- (do ( (pos start (+ pos 1) ) )
- ( (= (elt array pos) 0) )
+ (do ( (pos start (+ pos 1) ) )
+ ( (= (elt array pos) 0) )
(incf eol)
)
eol))
-
(defun bson-decode (totlen pos docs array &key (container #'ht->document.1 ) )
(block nil
(let ((lst () ) )
@@ -31,7 +30,6 @@
(epos (end-of-key pos array) )
(key (babel:octets-to-string array :start spos :end epos)))
(setf pos (+ 1 epos))
-
(cond
( (= type +bson-data-number+) (progn
(setf (gethash key ht) (decode-double-float-bits (octet-to-uint64.1 array pos)))
@@ -52,16 +50,25 @@
( (= type +bson-data-object+) (progn
(let* ((size (octet-to-int32.1 array pos ))
(eos (- (+ pos size) 1) ))
- (setf (gethash key ht) (car (bson-decode eos pos 1 array )))
- (setf pos (+ 1 eos))
- )
+ (progn
+ (if (> (elt array (+ pos 4)) 0)
+ (setf (gethash key ht) (car (bson-decode eos pos 1 array )))
+ (setf (gethash key ht) nil)
+ )
+ (setf pos (+ 1 eos))
+ ))
))
( (= type +bson-data-array+) (progn
(let* ((size (octet-to-int32.1 array pos ))
(eos (- (+ pos size) 1) ))
- (setf (gethash key ht) (car (bson-decode eos pos 1 array :container #'ht->list.1)))
- (setf pos (+ 1 eos))
+ (progn
+ (if (> (elt array (+ pos 4)) 0)
+ (setf (gethash key ht) (car (bson-decode eos pos 1 array :container #'ht->list.1)))
+ (setf (gethash key ht) nil)
+ )
+ (setf pos (+ 1 eos))
+ )
)
))
View
126 src/bson.lisp
@@ -15,10 +15,6 @@
(defconstant +bson-data-regex+ 11 "bson regex encoding")
(defconstant +bson-data-dbpointer+ 12 "bson db pointer encoding/deprecated")
(defconstant +bson-data-code+ 13 "bson code encoding")
-#|
-support for data-symbol was removed b/c in the current implementation it
-clashed with the encoding for booleans..
-|#
(defconstant +bson-data-symbol+ 14 "bson symbol encoding")
(defconstant +bson-data-code_w_s+ 15 "bson javascript with scope")
(defconstant +bson-data-int32+ 16 "bson 32 bit int encoding")
@@ -46,8 +42,7 @@ clashed with the encoding for booleans..
(defgeneric bson-encode(key value &key )
(:documentation "encode a bson data element"))
-(defmethod bson-encode( (key string) (value t) &key array type encoder)
- ;(format t "89here~%")
+(defun bson-encode-array ( key &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
@@ -57,6 +52,8 @@ clashed with the encoding for booleans..
(set-octets head (int32-to-octet (- (length array) head) ) array) ; set length
array))
+(defmethod bson-encode ( (key string) (value t) &key array type encoder)
+ (bson-encode-array key :array array :type type :encoder encoder))
;;; empty object
(defmethod bson-encode( (key (eql nil)) (value (eql nil)) &key (array nil))
@@ -70,16 +67,6 @@ clashed with the encoding for booleans..
;;
(defmethod bson-encode ( (key integer) value &key )
(bson-encode (format nil "~A" key) value))
-
-(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)
- (let ((enc-val (string-to-null-terminated-octet value)))
- ;; length of the value string
- (add-octets (int32-to-octet (length enc-val)) array)
- ;; value string, null terminated
- (add-octets enc-val array))))
- (call-next-method key value :array array :type type :encoder #'encode-value))))
(defmethod bson-encode ( (key string) (value bson-binary-base) &key (array nil) (type +bson-data-binary+) )
(let ((array (or array (make-octet-vector +default-array-size+))))
@@ -100,65 +87,73 @@ clashed with the encoding for booleans..
(add-octets (data value) array)))
(bson-encode key value :array array :type type :encoder #'encode-value))))
-(defmethod bson-encode ( (key string) (value bson-code) &key (array nil))
- (bson-encode key (code value) :array array :type +bson-data-code+))
+;
+; 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 (or type +bson-data-object+) :encoder (or encoder #'encode-value)))))
-(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))
+(defmethod bson-encode ( (key string) (value (eql t)) &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)
- (add-octets (int64-to-octet value ) array))) ; value converted to 64 bits
- (if (> 32 (integer-length value))
- (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) )
+ (labels ((encode-value (array)
+ (add-octets (byte-to-octet (bool-to-byte value)) array))) ; add value
+ (bson-encode-array key :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 (int64-to-octet (encode-double-float-bits value)) array))) ;convert float to octet
- (call-next-method key value :array array :type +bson-data-number+ :encoder #'encode-value))))
+ (labels ((encode-value (array)
+ array))
+ (bson-encode-array key :array array :type +bson-data-null+ :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))))
+ (bson-encode-array key :array array :type +bson-data-date+ :encoder #'encode-date))))
-(defmethod bson-encode-boolean( (key string) value &key (array nil) )
+(defmethod bson-encode ( (key string) (value bson-code) &key (array nil))
+ (bson-encode key (code value) :array array :type +bson-data-code+))
+
+(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 bson-oid) &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
- (bson-encode key value :array array :type +bson-data-boolean+ :encoder #'encode-value))))
+ (add-octets (_id value) array))) ; twelf byte oid
+ (bson-encode-array key :array array :type +bson-data-oid+ :encoder #'encode-value))))
-(defmethod bson-encode ( (key string) (value (eql t)) &key (array nil) )
+(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 (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 )
+ (let ((enc-val (string-to-null-terminated-octet value)))
+ ;; length of the value string
+ (add-octets (int32-to-octet (length enc-val)) array)
+ ;; value string, null terminated
+ (add-octets enc-val array))))
+ (bson-encode-array key :array array :type type :encoder #'encode-value))))
-;(defmethod bson-encode ( (key string) (value (eql 'void)) &key (array nil) )
+(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)
+ (add-octets (int64-to-octet value ) array))) ; value converted to 64 bits
+ (if (> 32 (integer-length value))
+ (bson-encode-array key :array array :type +bson-data-int32+ :encoder #'encode-value32)
+ (bson-encode-array key :array array :type +bson-data-long+ :encoder #'encode-value64)))))
-(defmethod bson-encode ( (key string) (value (eql nil)) &key (array nil) )
+(defmethod bson-encode ( (key string) (value float) &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))))
+ (labels ((encode-value(array)
+ (add-octets (int64-to-octet (encode-double-float-bits value)) array))) ;convert float to octet
+ (bson-encode-array key :array array :type +bson-data-number+ :encoder #'encode-value))))
(defmethod bson-encode ( (key string) (value bson-regex) &key (array nil) )
(let ((array (or array (make-octet-vector +default-array-size+))))
@@ -168,22 +163,5 @@ clashed with the encoding for booleans..
;; 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
-; 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 (or type +bson-data-object+)
- :encoder (or encoder #'encode-value)))))
-
-
-(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 +bson-data-oid+ :encoder #'encode-value))))
+ (bson-encode-array key :array array :type +bson-data-regex+ :encoder #'encode-value))))
View
50 src/document.lisp
@@ -41,11 +41,40 @@ the document was generated by the client (as opposed to having been read from th
(defgeneric get-element ( key document)
( :documentation "Get an element identified by key from the document." ) )
+
(defmethod get-element ( (key string) (document (eql nil) ) )
- (values nil nil))
+ (nil nil))
+(defun get-all-values (key list-of-docs)
+ (let ((lst ()))
+ (dolist (doc list-of-docs)
+ (multiple-value-bind (value exists-p) (gethash key (elements doc))
+ (when exists-p (push value lst))))
+ (values lst (not (null lst)))))
+
+(defmethod get-element ( (key-list cons) (document document) )
+ (let ((iter-doc document)
+ (exists-p nil))
+ (dolist (key key-list)
+ (typecase iter-doc
+ (document (multiple-value-bind (doc doc-exists-p) (gethash key (elements iter-doc))
+ (setf iter-doc doc exists-p doc-exists-p)))
+ (cons (multiple-value-bind (doc doc-exists-p) (get-all-values key iter-doc)
+ (setf iter-doc doc exists-p doc-exists-p)))
+ (t (setf exists-p nil))))
+ (values iter-doc exists-p)))
+
(defmethod get-element ( (key string) (document document) )
- (gethash key (elements document)))
+ (get-element (split-sequence:SPLIT-SEQUENCE #\. key) document))
+
+
+(defmethod get-element ( (key string) (document cons))
+ (let ((lst ())
+ (key-list (split-sequence:SPLIT-SEQUENCE #\. key)))
+ (dolist (doc document)
+ (multiple-value-bind (doc doc-exists-p) (get-element key-list doc)
+ (when doc-exists-p (push doc lst))))
+ lst))
(defgeneric rm-element (key document)
( :documentation "Remove element identified by key from a document" ) )
@@ -53,6 +82,17 @@ the document was generated by the client (as opposed to having been read from th
(defmethod rm-element ( (key string) (document document) )
(remhash key (elements document)))
+(defun collect-all-elements (key-list document-list)
+ (let ((collector nil))
+ (dolist (doc document-list)
+ (let ((lst nil))
+ (dolist (key key-list)
+ (multiple-value-bind (elem exists-p) (get-element key doc)
+ (declare (ignore exists-p))
+ (push elem lst)))
+ (unless (null lst) (push (nreverse lst) collector ))))
+ (nreverse collector )))
+
(defgeneric get-id (id) )
(defmethod get-id ( (id t) )
@@ -113,7 +153,11 @@ the document was generated by the client (as opposed to having been read from th
; suppress the printing of the object id if the objectis locally generated
;
-(defmethod describe-object ((document document) stream)
+(defmethod describe-object ((docs cons) &optional (stream t))
+ (dolist (document docs)
+ (describe-object document stream)))
+
+(defmethod describe-object ((document document) &optional (stream t))
(format stream "~%{ ~S ~%" (type-of document) )
(unless (slot-boundp document '_id) (format stream " _id not set"))
(unless (slot-boundp document '_local_id) (format stream " _local_id not set"))
View
0  test.lisp
No changes.
View
2  test/test-utils.lisp
@@ -124,6 +124,8 @@
(add-element "list-2" (list i (* i 2) (- i 3) (+ i 4)) doc)
(add-element (format nil "index-field") i doc)
(add-element (format nil "value-2-float") (* 7.8 i) doc)
+ (add-element (format nil "boolean true") t doc)
+ (add-element (format nil "boolean false") (not t) doc)
(db.insert collection doc )))))
(defun insert-doc-with-arrays (collection n &key (host "localhost" ) (port *mongo-default-port*) (db "test"))
Please sign in to comment.
Something went wrong with that request. Please try again.