Permalink
Browse files

changes to improve performance of reads.

  • Loading branch information...
1 parent be2ae09 commit faa96b9fe31e26a5fd43493190217acec9f53430 alfons haffmans committed Sep 7, 2010
Showing with 914 additions and 273 deletions.
  1. +1 −0 cl-mongo.asd
  2. +5 −6 src/bson-array.lisp
  3. +1 −0 src/bson-binary.lisp
  4. +206 −0 src/bson-decode.lisp
  5. +25 −223 src/bson.lisp
  6. +8 −9 src/db.lisp
  7. +300 −0 src/depr/bson-decode-deprecated.lisp
  8. +303 −0 src/depr/perf-test.lisp
  9. +26 −1 src/document.lisp
  10. +1 −0 src/mongo.lisp
  11. +20 −0 src/octets.lisp
  12. +14 −31 src/protocol.lisp
  13. +4 −3 src/shell.lisp
View
@@ -30,6 +30,7 @@
(:file "bson-regex")
(:file "bson-code")
(:file "bson")
+ (:file "bson-decode")
(:file "bson-array")
(:file "document")
(:file "mongo-syntax")
View
@@ -19,6 +19,8 @@ A note of the bson-array design
|#
+(defun make-int-vector (sz &key (init-fill 0) )
+ (make-array sz :element-type 'integer :initial-element 0 :fill-pointer init-fill :adjustable t))
(defclass bson-array()
((array :initarg :data-array :accessor data-array)
@@ -27,6 +29,7 @@ A note of the bson-array design
;; terminate the bson array with a nul and
;; encode the length in the first for bytes..
+
(defun normalize-array(array)
(null-terminate-array array)
(set-array-length array :start 0))
@@ -37,7 +40,7 @@ A note of the bson-array design
(defun make-bson-array(&key (size 10))
(let ((array (make-instance 'bson-array
:data-array (add-octets (int32-to-octet 0) (make-octet-vector (+ size 4)))
- :index-array (make-octet-vector 5))))
+ :index-array (make-int-vector 5))))
(normalize-bson-array array)
array))
@@ -114,9 +117,5 @@ A note of the bson-array design
(car list) (cons (cdr list) stack) (cons (make-bson-array) bson-array-stack)))
( t (bson-encode-cons (cdr list) stack (encode-cons-helper-1 (car list) bson-array-stack))))))
-(defmethod bson-encode ( (key string) (value cons) &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) )
+(defmethod bson-encode ( (key string) (value cons) &key )
(bson-encode key (bson-encode-cons value () (list (make-bson-array :size (* (length value) 12))))))
View
@@ -1,5 +1,6 @@
(in-package :cl-mongo)
+(defconstant +bson-binary-generic+ #x00 "binary/generic")
(defconstant +bson-binary-function+ #x01 "function")
(defconstant +bson-binary+ #x02 "ordinary binary")
(defconstant +bson-binary-uuid+ #x03 "uuid")
View
@@ -0,0 +1,206 @@
+(in-package :cl-mongo)
+
+(defun ht->list.1 (ht)
+ (let ((lst ()))
+ (maphash (lambda (k v) (push v lst)) ht)
+ lst))
+
+(defun end-of-key (start array)
+ (let ((eol start))
+ (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 () ) )
+ (when (zerop docs) (return lst))
+ (tagbody
+ start-document
+ (progn
+ (let* ((ht (make-hash-table :test #'equal :size 10))
+ (end (+ (- pos 1) (octet-to-int32.1 array pos))))
+ (incf pos 4)
+ (tagbody
+ get-key-value
+ (let* ((type (elt array pos))
+ (spos (+ pos 1))
+ (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)))
+ (incf pos 8)
+ ))
+
+
+ ((= type +bson-data-string+) (progn
+ (let* ((size (octet-to-int32.1 array pos ))
+ (npos (+ 4 pos))
+ (eos (+ 3 pos size)) ;;do not include null
+ (value (babel:octets-to-string array :start npos :end eos )))
+ (setf (gethash key ht) value)
+ (setf pos (+ 1 eos))
+ )
+ ) )
+
+ ( (= 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))
+ )
+ ))
+
+ ( (= 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))
+ )
+ ))
+
+ ( (= type +bson-data-binary+) (progn
+ (let* ((binarysize (octet-to-int32.1 array pos))
+ (totalsize (+ 5 binarysize))
+ (type (elt array (+ 4 pos)))
+ (size (if (eql type #x02) (octet-to-int32.1 array (+ pos 5) ) (octet-to-int32.1 array pos)))
+ (offset (if (eql type #x02) 9 5))
+ (binary (bson-binary type (subseq array offset (+ offset size)))))
+ (setf (gethash key ht) binary)
+ (incf pos totalsize)
+ )
+ ))
+
+ ( (= type +bson-data-undefined+ ) (progn
+ (setf (gethash key ht) nil)
+ ))
+
+ ( (= type +bson-data-oid+ ) (progn
+ (let ((npos (+ pos 12)))
+ (setf (gethash key ht) (make-bson-oid :oid (subseq array pos npos)))
+ (setf pos npos)
+ )
+ ) )
+
+ ( (= type +bson-data-boolean+) (progn
+ ;;(values
+ (setf (gethash key ht) (byte-to-bool (elt array pos)))
+ (incf pos 1)
+ ))
+
+ ( (= type +bson-data-date+ ) (progn
+ (setf (gethash key ht) (make-bson-time (octet-to-uint64.1 array pos)))
+ (incf pos 8)
+ ))
+
+ ( (= type +bson-data-null+ ) (progn
+ (setf (gethash key ht) nil)
+ ))
+
+ ( (= type +bson-data-regex+ ) (progn
+ (let* ((eregex (end-of-key pos array) )
+ (regex (babel:octets-to-string array :start pos :end eregex))
+ (npos (+ 1 eregex))
+ (eopt (end-of-key npos array))
+ (options (babel:octets-to-string array :start npos :end eopt)) )
+ (setf (gethash key ht) (make-bson-regex regex options))
+ (setf pos (+ 1 eopt))
+ )
+ ))
+
+
+ ( (= type +bson-data-dbpointer+ ) (progn
+ (let ((npos (+ pos 12)))
+ (setf (gethash key ht) (subseq array pos npos))
+ (setf pos npos)
+ )
+ ) )
+
+
+ ((= type +bson-data-code+) (progn
+ (let* ((size (octet-to-int32.1 array pos ))
+ (npos (+ 4 pos))
+ (eos (+ 3 pos size)) ;;do not include null
+ (value (babel:octets-to-string array :start npos :end eos )))
+ (setf (gethash key ht) value)
+ (setf pos (+ 1 eos))
+ )
+ ) )
+
+ ((= type +bson-data-symbol+) (progn
+ (let* ((size (octet-to-int32.1 array pos ))
+ (npos (+ 4 pos))
+ (eos (+ 3 pos size)) ;;do not include null
+ (value (babel:octets-to-string array :start npos :end eos )))
+ (setf (gethash key ht) value)
+ (setf pos (+ 1 eos))
+ (intern value :cl-user)
+ )
+ ))
+
+ ((= type +bson-data-code_w_s+) (progn
+ (let* ((total-size (octet-to-int32.1 array pos ))
+ (npos (+ 4 pos))
+ (string-size (octet-to-int32.1 array npos ) )
+ (start-of-string (+ 4 npos))
+ (end-of-string (+ 3 npos string-size)) ;;do not include null
+ (javascript (babel:octets-to-string array :start start-of-string :end end-of-string ))
+ (eojs (+ 1 end-of-string))
+ (env (car (bson-decode (+ pos total-size) eojs 1 array ))) )
+ (setf (gethash key ht) (list javascript env))
+ (incf pos total-size)
+ )
+ ))
+
+ ( (= type +bson-data-int32+ ) (progn
+ (setf (gethash key ht) (octet-to-int32.1 array pos))
+ (incf pos 4)
+ ))
+
+ ( (= type +bson-data-timestamp+ ) (progn
+ (setf (gethash key ht) (octet-to-int64.1 array pos))
+ (incf pos 8)
+ ))
+
+ ( (= type +bson-data-long+ ) (progn
+ (setf (gethash key ht) (octet-to-int64.1 array pos))
+ (incf pos 8)
+ ))
+
+
+ ( (= type +bson-data-min-key+ ) (progn
+ (setf (gethash key ht) nil)
+ ))
+
+ ( (= type +bson-data-max-key+ ) (progn
+ (setf (gethash key ht) nil)
+ ))
+
+ ( t (error "error : unable to process this type : ~A " type))
+
+ ) ;; end of condition on type
+ (when (< pos end) (go get-key-value))) )
+ (incf pos)
+ (push (funcall container ht) lst) ))
+ (decf docs)
+ (when (= totlen pos) (return lst))
+ (when (zerop docs) (return lst))
+ (go start-document)) )))
+
+
+
+;;--------------------------------------------------------------------------
+
+
+
+
+
+
+
+
Oops, something went wrong.

0 comments on commit faa96b9

Please sign in to comment.