[elephant-cvs] CVS elephant/src/db-clsql
ieslick
ieslick at common-lisp.net
Sun Feb 19 04:53:00 UTC 2006
Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory common-lisp:/tmp/cvs-serv7130/src/db-clsql
Added Files:
sql-collections.lisp sql-controller.lisp sql-transaction.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; sql-controller.lisp -- Interface to a CLSQL based object store.
;;;
;;; Initial version 10/12/2005 by Robert L. Read
;;; <read at robertlread.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2005 by Robert L. Read
;;; <rread at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package "ELEPHANT")
(defclass sql-btree-index (btree-index sql-btree)
()
(:metaclass persistent-metaclass)
(:documentation "A SQL-based BTree supports secondary indices."))
(defmethod get-value (key (bt sql-btree-index))
"Get the value in the primary DB from a secondary key."
(declare (optimize (speed 3)))
;; Below, the take the oid and add it to the key, then look
;; thing up--- where?
;; Somehow I suspect that what I am getting back here
;; is actually the main key...
(let* ((sc (get-con bt))
(con (controller-db sc)))
(let ((pk (sql-get-from-clcn (oid bt) key sc con)))
(if pk
(sql-get-from-clcn (oid (primary bt)) pk sc con))
)))
(defmethod get-primary-key (key (bt sql-btree-index))
(declare (optimize (speed 3)))
(let* ((sc (get-con bt))
(con (controller-db sc))
)
(sql-get-from-clcn (oid bt) key sc con)))
;; My basic strategy is to keep track of a current key
;; and to store all keys in memory so that we can sort them
;; to implement the cursor semantics. Clearly, passing
;; in a different ordering is a nice feature to have here.
(defclass sql-cursor (cursor)
((keys :accessor :sql-crsr-ks :initarg :sql-cursor-keys :initform '())
(curkey :accessor :sql-crsr-ck :initarg :sql-cursor-curkey :initform -1 :type integer))
(:documentation "A SQL cursor for traversing (primary) BTrees."))
(defmethod make-cursor ((bt sql-btree))
"Make a cursor from a btree."
(declare (optimize (speed 3)))
(make-instance 'sql-cursor
:btree bt
:oid (oid bt)))
(defmethod cursor-close ((cursor sql-cursor))
(setf (:sql-crsr-ck cursor) nil)
(setf (cursor-initialized-p cursor) nil))
;; Maybe this will still work?
;; I'm not sure what cursor-duplicate is meant to do, and if
;; the other state needs to be copied or now. Probably soo...
(defmethod cursor-duplicate ((cursor sql-cursor))
(declare (optimize (speed 3)))
(make-instance (type-of cursor)
:initialized-p (cursor-initialized-p cursor)
:oid (cursor-oid cursor)
;; Do we need to so some kind of copy on this collection?
:keys (:sql-crsr-ks cursor)
:curkey (:sql-crsr-ck cursor)
:handle (db-cursor-duplicate
(cursor-handle cursor)
:position (cursor-initialized-p cursor))))
(defmethod cursor-current ((cursor sql-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(has-key-value cursor)))
;; Only for use within an operation...
(defun my-generic-less-than (a b)
(cond
((and (typep a 'persistent) (typep b 'persistent))
(< (oid a) (oid b))
)
((and (numberp a ) (numberp b))
(< a b))
((and (stringp a) (stringp b))
(string< a b))
(t
(string< (format nil "~A" a) (format nil "~A" b)))
))
(defmethod cursor-un-init ((cursor sql-cursor) &key (returnpk nil))
(setf (cursor-initialized-p cursor) nil)
(if returnpk
(values nil nil nil nil)
(values nil nil nil)))
(clsql::locally-enable-sql-reader-syntax)
(defmethod cursor-init ((cursor sql-cursor))
(let* ((sc (get-con (cursor-btree cursor)))
(con (controller-db sc))
(tuples
(clsql:select [key]
:from [keyvalue]
:where [= [clctn_id] (oid (cursor-btree cursor))]
:database con
))
(len (length tuples)))
;; now we somehow have to load the keys into the array...
;; actually, this should be an adjustable vector...
(setf (:sql-crsr-ks cursor) (make-array (length tuples)))
(do ((i 0 (1+ i))
(tup tuples (cdr tup)))
((= i len) nil)
(setf (aref (:sql-crsr-ks cursor) i)
(deserialize-from-base64-string (caar tup) :sc sc)))
(sort (:sql-crsr-ks cursor) #'my-generic-less-than)
(setf (:sql-crsr-ck cursor) 0)
(setf (cursor-initialized-p cursor) t)
))
(clsql::restore-sql-reader-syntax-state)
;; we're assuming here that nil is not a legitimate key.
(defmethod get-current-key ((cursor sql-cursor))
(let ((x (:sql-crsr-ck cursor)))
(if (and (>= x 0) (< x (length (:sql-crsr-ks cursor))))
(svref (:sql-crsr-ks cursor) x)
'()
))
)
(defmethod get-current-value ((cursor sql-cursor))
(let ((key (get-current-key cursor)))
(if key
(get-value key (cursor-btree cursor))
'())))
(defmethod has-key-value ((cursor sql-cursor))
(let ((key (get-current-key cursor)))
(if key
(values t key (get-value key (cursor-btree cursor)))
(cursor-un-init cursor))))
(defmethod cursor-first ((cursor sql-cursor))
(declare (optimize (speed 3)))
;; Read all of the keys...
;; We need to get the contoller db from the btree somehow...
(cursor-init cursor)
(has-key-value cursor)
)
;;A bit of a hack.....
;; If you run off the end, this can set cursor-initalized-p to nil.
(defmethod cursor-last ((cursor sql-cursor) )
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(setf (:sql-crsr-ck cursor)
(- (length (:sql-crsr-ks cursor)) 1))
(setf (cursor-initialized-p cursor) t)
(has-key-value cursor))
(defmethod cursor-next ((cursor sql-cursor))
(if (cursor-initialized-p cursor)
(progn
(incf (:sql-crsr-ck cursor))
(has-key-value cursor))
(cursor-first cursor)))
(defmethod cursor-prev ((cursor sql-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(progn
(decf (:sql-crsr-ck cursor))
(has-key-value cursor))
(cursor-last cursor)))
(defmethod cursor-set ((cursor sql-cursor) key)
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(let ((p (position key (:sql-crsr-ks cursor) :test #'equal)))
(if p
(progn
(setf (:sql-crsr-ck cursor) p)
(setf (cursor-initialized-p cursor) t)
(has-key-value cursor)
)
(setf (cursor-initialized-p cursor) nil)))
(progn
(cursor-init cursor)
(let ((p (position key (:sql-crsr-ks cursor) :test #'equal)))
(if p
(progn
(setf (:sql-crsr-ck cursor) p)
(has-key-value cursor)
)
(setf (cursor-initialized-p cursor) nil))))
))
(defmethod cursor-set-range ((cursor sql-cursor) key)
(declare (optimize (speed 3)))
;; I'm a little fuzzy on when I should leave a cursor in
;; the initialized state...
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(let ((len (length (:sql-crsr-ks cursor)))
(vs '()))
(do ((i 0 (1+ i)))
((or (= i len)
vs)
vs)
(progn
(multiple-value-bind (h k v)
(cursor-next cursor)
(when (my-generic-less-than key k)
(setf vs t))
)
))
(if vs
(cursor-current cursor)
(cursor-un-init cursor))))
(defmethod cursor-get-both ((cursor sql-cursor) key value)
(declare (optimize (speed 3)))
(let* ((bt (cursor-btree cursor))
(v (get-value key bt)))
(if (equal v value)
;; We need to leave this cursor properly posistioned....
;; For a secondary cursor it's harder, but for this, it's simple
(cursor-set cursor key)
(cursor-un-init cursor))))
;; This needs to be rewritten!
(defmethod cursor-get-both-range ((cursor sql-cursor) key value)
(declare (optimize (speed 3)))
(let* ((bt (cursor-btree cursor))
(v (get-value key bt)))
;; Since we don't allow duplicates in primary cursors, I
;; guess this is all that needs to be done!
;; If there were a test to cover this, the semantics would be clearer...
(if (equal v value)
(cursor-set cursor key)
(cursor-un-init cursor))))
(defmethod cursor-delete ((cursor sql-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(multiple-value-bind
(has k v)
(cursor-current cursor)
(declare (ignore has v))
;; Now I need to suck the value out of the cursor, somehow....
(remove-kv k (cursor-btree cursor)))
(error "Can't delete with uninitialized cursor!")))
;; This needs to be changed!
(defmethod cursor-put ((cursor sql-cursor) value &key (key nil key-specified-p))
"Put by cursor. Not particularly useful since primaries
don't support duplicates. Currently doesn't properly move
the cursor."
(declare (optimize (speed 3)))
(error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!"))
;; Secondary Cursors
(defclass sql-secondary-cursor (sql-cursor)
(
(dup-number :accessor :dp-nmbr :initarg :dup-number :initform 0 :type integer)
)
(:documentation "Cursor for traversing bdb secondary indices."))
(defmethod make-cursor ((bt sql-btree-index))
"Make a secondary-cursor from a secondary index."
(declare (optimize (speed 3)))
(make-instance 'sql-secondary-cursor
:btree bt
:oid (oid bt)))
(defmethod has-key-value-scnd ((cursor sql-secondary-cursor) &key (returnpk nil))
(let ((ck (:sql-crsr-ck cursor)))
(if (and (>= ck 0) (< ck (length (:sql-crsr-ks cursor))))
(let* ((cur-pk (aref (:sql-crsr-ks cursor)
(:sql-crsr-ck cursor)))
(sc (get-con (cursor-btree cursor)))
(con (controller-db sc))
(indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk
sc con
(:dp-nmbr cursor))))
(if indexed-pk
(let ((v (get-value indexed-pk (primary (cursor-btree cursor)))))
(if v
(if returnpk
(values t cur-pk v indexed-pk)
(values t cur-pk v))
(cursor-un-init cursor :returnpk returnpk)))
(cursor-un-init cursor :returnpk returnpk)))
(progn
(cursor-un-init cursor :returnpk returnpk)))))
(defmethod cursor-current ((cursor sql-secondary-cursor) )
(cursor-current-x cursor))
(defmethod cursor-current-x ((cursor sql-secondary-cursor) &key (returnpk nil))
(has-key-value-scnd cursor :returnpk returnpk)
)
(defmethod cursor-pcurrent ((cursor sql-secondary-cursor))
(cursor-current-x cursor :returnpk t))
(defmethod cursor-pfirst ((cursor sql-secondary-cursor))
(cursor-first-x cursor :returnpk t))
(defmethod cursor-plast ((cursor sql-secondary-cursor))
(cursor-last-x cursor :returnpk t))
(defmethod cursor-pnext ((cursor sql-secondary-cursor))
(cursor-next-x cursor :returnpk t))
(defmethod cursor-pprev ((cursor sql-secondary-cursor))
(cursor-prev-x cursor :returnpk t))
(defmethod cursor-pset ((cursor sql-secondary-cursor) key)
(declare (optimize (speed 3)))
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(let ((idx (position key (:sql-crsr-ks cursor))))
(if idx
(progn
(setf (:sql-crsr-ck cursor) idx)
(setf (:dp-nmbr cursor) 0)
(cursor-current-x cursor :returnpk t))
(cursor-un-init cursor)
)))
(defun array-index-if (p a)
(do ((i 0 (1+ i)))
((or (not (array-in-bounds-p a i))
(funcall p (aref a i)))
(if (funcall p (aref a i))
i
-1)))
)
(defmethod cursor-pset-range ((cursor sql-secondary-cursor) key)
(declare (optimize (speed 3)))
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(let ((idx (array-index-if #'(lambda (x) (my-generic-less-than key x)) (:sql-crsr-ks cursor))))
(if (<= 0 idx)
(progn
(setf (:sql-crsr-ck cursor) idx)
(setf (:dp-nmbr cursor) 0)
(cursor-current-x cursor :returnpk t)
)
(cursor-un-init cursor :returnpk t)
)))
;; Moves the cursor to a the first secondary key / primary key pair,
;; with secondary key equal to the key argument, and primary key greater or equal to the pkey argument.
;; Returns has-tuple / secondary key / value / primary key.
(defmethod cursor-pget-both ((cursor sql-secondary-cursor) key pkey)
(declare (optimize (speed 3)))
;; It's better to get the value by the primary key,
;; as that is unique..
(let* ((bt (primary (cursor-btree cursor)))
(v (get-value pkey bt)))
;; Now, bascially we set the cursor to the key and
;; andvance it until we get the value that we want...
(if v
[217 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 1.1
[826 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 1.1
[869 lines skipped]
More information about the Elephant-cvs
mailing list