Permalink
Browse files

20100117

  • Loading branch information...
1 parent 5782db8 commit 5f1a9f4cb91c7066a94a25286f5b4f5ca57ccda3 fons committed Jan 17, 2010
Showing with 1,543 additions and 442 deletions.
  1. +40 −0 cl-mongo.asd
  2. +122 −0 src/bson-array.lisp
  3. +17 −442 src/bson.lisp
  4. +18 −0 src/container.lisp
  5. +55 −0 src/containerlisp
  6. +223 −0 src/db.lisp
  7. +31 −0 src/depr.lisp
  8. +79 −0 src/document.lisp
  9. +2 −0 src/encode-float.lisp
  10. +117 −0 src/mongo.lisp
  11. +98 −0 src/octets.lisp
  12. +32 −0 src/oid.lisp
  13. +19 −0 src/packages.lisp
  14. +86 −0 src/pair.lisp
  15. +184 −0 src/protocol.lisp
  16. +90 −0 src/save-document.lisp
  17. +81 −0 src/shell.lisp
  18. +249 −0 test/test.lisp
View
@@ -0,0 +1,40 @@
+(in-package #:cl-user)
+
+(defpackage #:cl-mongo-system (:use #:cl #:asdf))
+
+(in-package #:cl-mongo-system)
+
+(asdf:defsystem cl-mongo
+ :name "cl-mongo"
+ :author "Fons Haffmans"
+ :version "0.0.1"
+ :licence "FSF"
+ :description "lisp system to interact with mongo, a no-sql db"
+ :depends-on (:uuid
+ :babel
+ :usocket)
+ :serial t
+ :components
+ ((:module "src"
+ :serial t
+ :components ((:file "packages")
+ (:file "octets")
+ (:file "encode-float")
+ (:file "oid")
+ (:file "pair")
+ (:file "bson")
+ (:file "bson-array")
+ (:file "document")
+ (:file "protocol")
+ (:file "mongo")
+ (:file "db")
+ (:file "shell")
+ ))))
+
+
+
+
+
+
+
+
View
@@ -0,0 +1,122 @@
+(in-package :cl-mongo)
+
+#|
+A note of the bson-array design
+
+1. The encoders add the length of the element to the head of the byte stream
+ and null terminate the byte stream.
+
+2. The array format from what I can tell is this :
+ <array length> [0 or more <bson-encoding minus header and null terminator>] <null terminator>
+
+3. That means I need to keep add/update the header with the array length and add a null terminator each
+ time the array is changed.
+
+4. I remove the header (which is a size) and the null terminator returned from the bson-encoding. As an
+ alternative I could change bson-encoding to not add these if this is an array element !
+
+5. Make instance should produce a recognizable empty array.
+
+|#
+
+
+(defclass bson-array()
+ ((array :initarg :data-array :accessor data-array)
+ (index-array :initarg :index-array :accessor index-array)))
+
+;; 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))
+
+(defun normalize-bson-array(array)
+ (normalize-array (data-array array)))
+
+(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))))
+ (normalize-bson-array array)
+ array))
+
+(defun pop-from-array(arr)
+ (when (positive (fill-pointer arr)) (vector-pop arr)))
+
+(defgeneric bson-array-push (element array)
+ (:documentation "push element to arrray"))
+
+(defmethod bson-array-push (element (array bson-array))
+ (let ((key (format nil "~D" (fill-pointer (index-array array)))))
+ (pop-from-array (data-array array)) ; remove terminating null
+ (vector-push-extend (fill-pointer (data-array array)) (index-array array))
+ ; this skips the first four bytes returned from the encoding which
+ ; has the size of encoded object as well as the terminating nul
+ ; (which does get added on by normalize !)
+ (add-octets (bson-encode key element) (data-array array) :start 4 :from-end 1)
+ (normalize-bson-array array)
+ array))
+
+(defgeneric bson-array-pop (array)
+ (:documentation "pop element from arrray"))
+
+(defmethod bson-array-pop-element ((array bson-array))
+ (let* ((retval (copy-seq (subseq (data-array array) (vector-pop (index-array array)))))
+ (newfill (- (fill-pointer (data-array array)) (length retval))))
+ (setf (fill-pointer (data-array array)) newfill)
+ (normalize-bson-array array)
+ retval))
+
+(defmethod bson-array-pop ((array bson-array))
+ (if (zerop (fill-pointer (index-array array)))
+ (values nil nil)
+ (values (bson-array-pop-element array) (fill-pointer (index-array array)))))
+
+(defgeneric bson-array-reset (array))
+
+(defmethod bson-array-reset ((array bson-array))
+ (setf (fill-pointer (data-array array)) 0)
+ (setf (fill-pointer (index-array array)) 0) )
+
+(defmethod print-object ((arr bson-array) stream)
+ (format stream "~% ~S [~A] ~A" (type-of arr)
+ (if (slot-boundp arr 'index-array)
+ (index-array arr)
+ "no index array set..")
+ (if (slot-boundp arr 'array)
+ (data-array arr)
+ "no array set..")))
+
+
+(defmethod bson-encode( (key string) (value bson-array) &key (array nil array-supplied-p)
+ (size 10 size-supplied-p)
+ (type +bson-data-array+) (encoder nil))
+ (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
+ (call-next-method key value :array array :type type :encoder (if encoder encoder #'encode-value)))))
+
+(defun bson-encode-cons (list stack bson-array-stack)
+ (labels ((encode-cons-helper-1 (element bson-array-stack)
+ (bson-array-push element (car bson-array-stack))
+ bson-array-stack)
+ (encode-cons-helper-2 (bson-array-stack)
+ (bson-array-push (car bson-array-stack) (cadr bson-array-stack))
+ (cdr bson-array-stack))
+ (encode-cons-done (list stack)
+ (and (zerop (length list)) (zerop (length stack)))))
+ (cond ( (encode-cons-done list stack) (car bson-array-stack))
+ ( (zerop (length list)) (bson-encode-cons (car stack) (cdr stack)
+ (encode-cons-helper-2 bson-array-stack)))
+ ( (consp (car list)) (bson-encode-cons
+ (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) )
+ (bson-encode key (bson-encode-cons value () (list (make-bson-array :size (* (length value) 12))))))
Oops, something went wrong.

0 comments on commit 5f1a9f4

Please sign in to comment.