Update of /project/elephant/cvsroot/elephant/src/contrib/eslick In directory clnet:/tmp/cvs-serv10743/eslick

Added Files: metaclasses-new.lisp package-new.lisp Log Message: Some working files for a lisp backend and a port to close-to-mop to cleanup the MOP implementation

--- /project/elephant/cvsroot/elephant/src/contrib/eslick/metaclasses-new.lisp 2007/02/04 10:23:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/metaclasses-new.lisp 2007/02/04 10:23:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; metaclasses.lisp -- persistent objects via metaobjects ;;; ;;; Initial version 8/26/2004 by Andrew Blumberg ;;; ablumberg@common-lisp.net ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ablumberg@common-lisp.net blee@common-lisp.net ;;; (Some changes by Robert L. Read, 2006) ;;; ;;; 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 persistent () ((%oid :accessor oid :initarg :from-oid) (dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst)) (:documentation "Abstract superclass for all persistent classes (common to user-defined classes and collections.)"))

(defclass persistent-metaclass (standard-class) ((%persistent-slots :accessor %persistent-slots) (%indexed-slots :accessor %indexed-slots) (%index-cache :accessor %index-cache)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by default; use the :transient flag otherwise. Slots can also be indexed for by-value retrieval."))

;; ;; Top level defclass form - hide metaclass option ;;

(defmacro defpclass (cname parents slot-defs &rest class-opts) `(defclass ,cname ,parents ,slot-defs ,@(add-persistent-metaclass-argument class-opts)))

(defun add-persistent-metaclass-argument (class-opts) (when (assoc :metaclass class-opts) (error "User metaclass specification not allowed in defpclass")) (append class-opts (list (list :metaclass 'persistent-metaclass)))) ;; ;; Persistent slot maintenance ;;

(defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) nil))

(defmethod persistent-slots ((class standard-class)) nil)

(defmethod old-persistent-slots ((class persistent-metaclass)) (cdr (%persistent-slots class)))

(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list) ;; (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class))))) (setf (%persistent-slots class) (cons new-slot-list (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) nil) )))

(defclass persistent-slot-definition (standard-slot-definition) ((indexed :accessor indexed :initarg :index :initform nil :allocation :instance)))

(defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ())

(defclass persistent-effective-slot-definition (standard-effective-slot-definition persistent-slot-definition) ())

(defclass transient-slot-definition (standard-slot-definition) ((transient :initform t :initarg :transient :allocation :class)))

(defclass transient-direct-slot-definition (standard-direct-slot-definition transient-slot-definition) ())

(defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition) ())

(defgeneric transient (slot))

(defmethod transient ((slot standard-direct-slot-definition)) t)

(defmethod transient ((slot persistent-direct-slot-definition)) nil)

;; ;; Indexed slots maintenance ;;

;; This just encapsulates record keeping a bit (defclass indexing-record () ((class :accessor indexing-record-class :initarg :class :initform nil) (slots :accessor indexing-record-slots :initarg :slots :initform nil) (derived-count :accessor indexing-record-derived :initarg :derived :initform 0)))

(defmethod print-object ((obj indexing-record) stream) (format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>" (length (indexing-record-slots obj)) (length (indexing-record-derived obj))))

(defmethod indexed-record ((class standard-class)) nil)

(defmethod indexed-record ((class persistent-metaclass)) (when (slot-boundp class '%indexed-slots) (car (%indexed-slots class))))

(defmethod old-indexed-record ((class persistent-metaclass)) (when (slot-boundp class '%indexed-slots) (cdr (%indexed-slots class))))

(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list &key class-indexed) (let ((oldrec (if (slot-boundp class '%indexed-slots) (indexed-record class) nil))) (setf (%indexed-slots class) (cons (make-new-indexed-record new-slot-list oldrec class-indexed) (if oldrec oldrec nil)))))

(defmethod make-new-indexed-record (new-slot-list oldrec class-indexed) (make-instance 'indexing-record :class (or class-indexed (when oldrec (indexing-record-class oldrec))) :slots new-slot-list :derived (when oldrec (indexing-record-derived oldrec))))

(defmethod removed-indexing? ((class persistent-metaclass)) (and (not (indexed class)) (previously-indexed class)))

(defun indexed-slot-names-from-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions when (and (subtypep (type-of slot-definition) 'persistent-slot-definition) (indexed slot-definition)) collect (slot-definition-name slot-definition))))

(defmethod register-indexed-slot ((class persistent-metaclass) slot) "This method allows for post-definition update of indexed status of class slots. It changes the effective method so we can rely on generic function dispatch for differentated behavior" ;; update record (let ((record (indexed-record class))) (unless (member slot (car (%persistent-slots class))) (error "Tried to register slot ~A as index which isn't a persistent slot" slot)) (unless (member slot (indexing-record-slots record)) ;; This is a normal startup case, but during other cases we'd like ;; the duplicate warning ;; (warn "Tried to index slot ~A which is already indexed" slot)) (push slot (indexing-record-slots record)))) ;; change effective slot def (let ((slot-def (find-slot-def-by-name class slot))) (unless slot-def (error "Slot definition for slot ~A not found, inconsistent state in class ~A" slot (class-name class))) (setf (slot-value slot-def 'indexed) t)))

(defmethod unregister-indexed-slot (class slot) "Revert an indexed slot to it's original state" ;; update record (let ((record (indexed-record class))) (unless (member slot (indexing-record-slots record)) (error "Tried to unregister slot ~A which is not indexed" slot)) (setf (indexing-record-slots record) (remove slot (indexing-record-slots record)))) ;; change effective slot def status (let ((slot-def (find-slot-def-by-name class slot))) (unless slot-def (error "Slot definition for slot ~A not found, inconsistent state in class ~A" slot (class-name class))) (setf (slot-value slot-def 'indexed) nil)))

(defmethod register-derived-index (class name) "Tell the class that it has derived indices defined against it and keep a reference count" (let ((record (indexed-record class))) (push name (indexing-record-derived record))))

(defmethod unregister-derived-index (class name) (let ((record (indexed-record class))) (setf (indexing-record-derived record) (remove name (indexing-record-derived record)))))

(defmethod indexed ((class persistent-metaclass)) (and (slot-boundp class '%indexed-slots) (not (null (%indexed-slots class))) (or (indexing-record-class (indexed-record class)) (indexing-record-slots (indexed-record class)) (indexing-record-derived (indexed-record class)))))

(defmethod previously-indexed ((class persistent-metaclass)) (and (slot-boundp class '%indexed-slots) (not (null (%indexed-slots class))) (let ((old (old-indexed-record class))) (when (not (null old)) (or (indexing-record-class old) (indexing-record-slots old) (indexing-record-derived old))))))

(defmethod indexed ((slot standard-slot-definition)) nil) (defmethod indexed ((class standard-class)) nil)

(defvar *inhibit-indexing-list* nil "Use this to avoid updating an index inside low-level functions that update groups of slots at once. We may need to rethink this if we go to a cheaper form of update that doesn't batch update all indices")

(defun inhibit-indexing (uid) (pushnew uid *inhibit-indexing-list*))

(defun uninhibit-indexing (uid) (setf *inhibit-indexing-list* (delete uid *inhibit-indexing-list*)))

;; ;; Original support for persistent slot protocol ;;

(defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) :database)

(defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) "Checks for the transient tag (and the allocation type) and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient)) (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) (error "Persistent class slots are not supported, try :transient t.")) ((and indexed-p transient-p) (error "Cannot declare slots to be both transient and indexed")) (transient-p (find-class 'transient-direct-slot-definition)) (t (find-class 'persistent-direct-slot-definition)))))

(defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) "Persistent classes may inherit from ordinary classes." t)

(defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) "Ordinary classes may NOT inherit from persistent classes." nil)

(defgeneric persistent-p (class))

(defmethod persistent-p ((class t)) nil)

(defmethod persistent-p ((class persistent-metaclass)) t)

(defmethod persistent-p ((class persistent-slot-definition)) t)

(defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) "Chooses the persistent or transient effective slot definition class depending on the keyword." (let ((transient-p (getf initargs :transient)) (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and indexed-p transient-p) (error "Cannot declare a slot to be both indexed and transient")) (transient-p (find-class 'transient-effective-slot-definition)) (t (find-class 'persistent-effective-slot-definition)))))

(defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs)) (loop for slot-definition in slot-definitions always (transient slot-definition)))

(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) (let ((initargs (call-next-method))) (if (ensure-transient-chain slot-definitions initargs) (setf initargs (append initargs '(:transient t))) (setf (getf initargs :allocation) :database)) ;; Effective slots are indexed only if the most recent slot definition ;; is indexed. NOTE: Need to think more about inherited indexed slots (if (indexed (first slot-definitions)) (append initargs '(:index t)) initargs)))

(defun find-slot-def-by-name (class slot-name) (loop for slot-def in (class-slots class) when (eq (slot-definition-name slot-def) slot-name) do (return slot-def)))

(defun persistent-slot-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-def in slot-definitions when (subtypep (type-of slot-def) 'persistent-effective-slot-definition) collect slot-def)))

(defun transient-slot-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-def in slot-definitions unless (persistent-p slot-def) collect slot-def)))

(defun persistent-slot-names (class) (mapcar #'slot-definition-name (persistent-slot-defs class)))

(defun transient-slot-names (class) (mapcar #'slot-definition-name (transient-slot-defs class)))

--- /project/elephant/cvsroot/elephant/src/contrib/eslick/package-new.lisp 2007/02/04 10:23:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/package-new.lisp 2007/02/04 10:23:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; package.lisp -- package definition ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; blee@common-lisp.net ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ablumberg@common-lisp.net blee@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 :cl-user)

(defpackage elephant-btrees (:use :closer-common-lisp) (:export #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup #:cursor-set #:cursor-set-range #:cursor-get-both #:cursor-get-both-range #:cursor-delete #:cursor-put #:cursor-pcurrent #:cursor-pfirst #:cursor-plast #:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup #:cursor-pprev #:cursor-pprev-nodup #:cursor-pset #:cursor-pset-range #:cursor-pget-both #:cursor-pget-both-range))

(defpackage elephant (:use :closer-common-lisp :elephant-memutil :elephant-btrees) (:nicknames ele :ele) (:documentation "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") (:export #:*store-controller* #:*current-transaction* #:*auto-commit* #:*elephant-lib-path*

#:store-controller #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:flush-instance-cache #:optimize-storage

#:with-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction

#:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass

#:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree #:indexed-btree #:make-indexed-btree #:add-index #:get-index #:remove-index #:map-indices #:btree-index #:get-primary-key #:primary #:key-form #:key-fn

#:btree-differ #:migrate #:*inhibit-slot-copy*

#:run-elephant-thread

;; Class indexing management API

[28 lines skipped]