Browse files

making cl-mongo work with clozure, allegro,clisp

  • Loading branch information...
1 parent e91077e commit f581afc6d0ffdff0258e76ac841bf3219b27b3cf fons committed Mar 13, 2010
Showing with 20 additions and 156 deletions.
  1. +3 −0 .gitignore
  2. +8 −8 src/db.lisp
  3. +0 −144 src/document.lisp
  4. +8 −3 src/mongo.lisp
  5. +1 −1 src/packages.lisp
View
3 .gitignore
@@ -1,3 +1,6 @@
*~
*#
.#*
+*.abcl
+*.lx64fsl
+*.fasl
View
16 src/db.lisp
@@ -42,22 +42,22 @@ mongo documentation.
(defmethod db.find ( (collection string) (kv (eql :all))
&key (mongo nil) (options 0) (skip 0) (selector nil) )
- (call-next-method collection (bson-encode nil nil)
+ (db.find collection (bson-encode nil nil)
:mongo mongo :options options :skip skip :limit 0 :selector selector ))
(defmethod db.find ( (collection string) (kv integer)
&key (mongo nil) (options 0) (skip 0) (selector nil) )
- (call-next-method collection (bson-encode nil nil)
- :mongo mongo :options options :skip skip :limit kv :selector selector ))
+ (db.find collection (bson-encode nil nil)
+ :mongo mongo :options options :skip skip :limit kv :selector selector ))
(defmethod db.find ( (collection string) (kv pair)
&key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
- (call-next-method collection (bson-encode (pair-key kv) (pair-value kv))
- :mongo mongo :options options :skip skip :limit limit :selector selector ))
+ (db.find collection (bson-encode (pair-key kv) (pair-value kv))
+ :mongo mongo :options options :skip skip :limit limit :selector selector ))
(defmethod db.find ( (collection string) (kv hash-table)
&key (mongo nil) (options 0) (skip 0) (limit 1) (selector nil) )
- (call-next-method collection (bson-encode-container kv)
+ (db.find collection (bson-encode-container kv)
:mongo mongo :options options :skip skip :limit limit :selector selector ))
@@ -298,7 +298,7 @@ For most commands you can just uses the key-value shown in the mongo documentati
(defmethod db.indexes (&key (mongo nil) )
"Return all indexes in the database."
- (db.find "system.indexes" 'all :mongo mongo))
+ (db.find "system.indexes" :all :mongo mongo))
(defmethod db.collections (&key (mongo nil) )
"Show all the collections in the current database."
@@ -307,7 +307,7 @@ For most commands you can just uses the key-value shown in the mongo documentati
(defgeneric db.count ( collection selector &key )
(:documentation "
Count all the collections satifying the criterion set by the selector.
-'all can be used to return a count of
+:all can be used to return a count of
all the documents in the collection.
"))
View
144 src/document.lisp
@@ -1,144 +0,0 @@
-(in-package :cl-mongo)
-
-#|
- Document is a collection of key/value pairs
-|#
-
-(defclass document()
- ((elements :initform (make-hash-table :test #'equal) :accessor elements)
- (_local_id :initarg :local :reader _local)
- (_id :initarg :oid :reader _id))
- (:default-initargs
- :local t
- :oid (make-bson-oid))
- (:documentation "document
-Document class. A document consists of key/value pairs stored in a internal hash table plus
-an internally generated unique id.
-Accessors are : 'elements' which returns the internal hash table;
-'_id' which returns the unique id and '_local_id' which if true means that
-the document was generated by the client (as opposed to having been read from the server)."))
-
-(defun make-document ( &key (oid nil) )
-"
-Constructor. key ':oid' is a user supplied unique id. An internal id will be generated if none
-is supplied.
-"
- (if oid
- (make-instance 'document :oid oid :local nil)
- (make-instance 'document)))
-
-(defgeneric add-element ( key value document)
- ( :documentation "add element with key and value to a document" ) )
-
-(defmethod add-element (key value document)
- document)
-
-(defmethod add-element ( (key string) value (document document) )
- (setf (gethash key (elements document)) value)
- (call-next-method))
-
-(defgeneric get-element ( key document)
- ( :documentation "Get an element identified by key from the document." ) )
-
-(defmethod get-element ( (key string) (document document) )
- (gethash key (elements document)))
-
-(defgeneric rm-element (key document)
- ( :documentation "Remove element identified by key from a document" ) )
-
-(defmethod rm-element ( (key string) (document document) )
- (remhash key (elements document)))
-
-(defun doc-elements ( doc )
- (let ((lst))
- (with-hash-table-iterator (iterator (elements doc) )
- (dotimes (repeat (hash-table-count (elements doc)))
- (multiple-value-bind (exists-p key value) (iterator)
- (declare (ignore value))
- (when exists-p (push key lst)))))
- (nreverse lst)))
-
-;;
-;; When the to-hash-able finalizer is used, embedded docs/tables in the response aren't converted
-;; to hash tables but to documents. When print-hash is used we want to see hash table like output
-;; so that's what this tries to do..
-;;
-(defun print-hash (ht stream)
- (labels ((prdocs (docs)
- (dolist (doc docs)
- (if (typep doc 'document)
- (print-hash (elements doc) stream)
- (format stream " ~A ~%" doc))))
- (vpr (v)
- (cond ( (typep v 'cons) (prdocs v) )
- ( (typep v 'document) (prdocs (list v)) )
- ( t v))))
- (format stream "~%{~%")
- (with-hash-table-iterator (iterator ht)
- (dotimes (repeat (hash-table-count ht))
- (multiple-value-bind (exists-p key value) (iterator)
- (if exists-p (format stream " ~A -> ~A ~%" key (vpr value) )))))
- (format stream "}~%")))
-
-;
-; suppress the printing of the object id if the objectis locally generated
-;
-
-(defmethod print-object ((document document) stream)
- (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"))
- (when (and (slot-boundp document '_local_id) (slot-boundp document '_id) )
- (unless (_local document) (format stream " _id : ~A~%" (_id document))))
- (if (slot-boundp document 'elements)
- (print-hash (elements document) stream)
- "no elements set..")
- (format stream "}~%"))
-
-(defun ht->document (ht)
-"Convert a hash-table to a document."
- (multiple-value-bind (oid oid-supplied) (gethash "_id" ht)
- (let ((doc (make-document :oid (if oid-supplied oid nil))))
- (when oid-supplied (remhash "_id" ht))
- (with-hash-table-iterator (iterator ht)
- (dotimes (repeat (hash-table-count ht))
- (multiple-value-bind (exists-p key value) (iterator)
- (if exists-p (add-element key value doc)))))
- doc)))
-
-
-(defgeneric bson-encode-container ( container &key )
- (:documentation "encode a container of key-value pairs.."))
-
-;;(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))
- (bson-encode-container (elements container) :array array :size size))
-
-(defmethod bson-encode-container ( (container hash-table) &key (array nil) (size nil) )
- (let* ((size (or size 10))
- (array (or array (make-octet-vector size))))
- (add-octets (int32-to-octet 0) array )
- (with-hash-table-iterator (iterator container)
- (dotimes (repeat (hash-table-count container))
- (multiple-value-bind (exists-p key value) (iterator)
- (if exists-p (add-octets (bson-encode key value) array :start 4 :from-end 1)))))
- (normalize-array array)))
-
-(defmethod bson-encode ( (key string) (value hash-table) &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type nil) (encoder nil))
- (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
- (ignore size-supplied-p) (ignore array-supplied-p) )
- (bson-encode key (bson-encode-container value :array (make-octet-vector (* (hash-table-count value) 12)))))
-
-(defmethod bson-encode ( (key string) (value document) &key (array nil array-supplied-p)
- (size 10 size-supplied-p)
- (type nil) (encoder nil))
- (declare (ignore encoder) (ignore array) (ignore type) (ignore size)
- (ignore size-supplied-p) (ignore array-supplied-p) )
- (bson-encode key (bson-encode-container value )))
View
11 src/mongo.lisp
@@ -4,8 +4,6 @@
Connection...
|#
-
-
(defconstant +MONGO-PORT+ 27017)
@@ -164,11 +162,16 @@ and a new default connection is registered." ))
(defgeneric mongo-message (mongo message &key )
(:documentation "message to/from mongo.."))
+(defun test-for-readback (stream timeout)
+ #+clisp (socket:socket-status stream timeout)
+ (declare (ignore timeout))
+ #-(or clisp) (listen stream))
+
(defmethod mongo-message ( (mongo mongo) (message array) &key (timeout 5) )
(write-sequence message (mongo-stream mongo))
(force-output (mongo-stream mongo))
(usocket:wait-for-input (list (socket mongo) ) :timeout timeout)
- (if (listen (mongo-stream mongo))
+ (if (test-for-readback (mongo-stream mongo) timeout)
(progn
(let* ((reply (make-octet-vector 1000 :init-fill 4 ))
(cursor (read-sequence reply (mongo-stream mongo) :start 0 :end 4))
@@ -180,6 +183,7 @@ and a new default connection is registered." ))
nil))
+
(defgeneric db.use ( db &key )
(:documentation "
Use a database on the mongo server. Opens a connection if one isn't already
@@ -206,6 +210,7 @@ similar to cd -. "))
"Show the current database."
(db (or mongo (mongo))))
+
(defun nwd ()
" Show the database set by the `(db.use -)` command"
(cadr *db.use-history*))
View
2 src/packages.lisp
@@ -48,7 +48,7 @@
;; shell commands
:nwd
- :cwd
+ #+(or sbcl clisp allegro abcl) :cwd
:pp
:iter
:nd

0 comments on commit f581afc

Please sign in to comment.