Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv16484

Modified Files: classindex.lisp package.lisp serializer.lisp serializer2.lisp Log Message: Support for struct serialization

--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/24 14:51:59 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/25 03:37:37 1.25 @@ -3,25 +3,28 @@ ;;; classindex.lisp -- use btree collections to track objects by slot values ;;; via metaclass options or accessor :after methods ;;; -;;; Initial version 1/24/2006 Ian Eslick -;;; eslick at alum mit edu +;;; Copyright (c) 2006,2007 Ian Eslick +;;; <ieslick at common-lisp.net> ;;; -;;; License: Lisp Limited General Public License -;;; http://www.franz.com/preamble.html +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Limited General Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;

(in-package "ELEPHANT")

(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1)))

+;; ================================= +;; LOW-LEVEL API SPECIFICATION +;; ================================= + ;; -;; User level class indexing control protocol +;; Operates against the current *store-controller* but many +;; accept a :sc keyword to change the controller. The specific +;; indices created can be specialized on the controller type. +;; See the internal implementor protocol below ;; -;; Operates against the current *store-controller* -;; but many accept a :sc keyword to change the controller -;; The specific indices created can be specialized on the -;; controller type. See the internal implementor protocol -;; below.

(defgeneric find-class-index (persistent-metaclass &rest rest) (:documentation "This method is the way to access the class index via @@ -60,50 +63,9 @@ (:documentation "Remove a derived index by providing the derived name used to name the derived index"))

- -;; =========================== -;; INDEX UPDATE ROUTINE -;; =========================== - -(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) - "Anything that side effects a persistent-object slot should call this to keep - the dependant indices in synch. Only classes with derived indices need to - update on writes to non-indexed slots. This is a side effect of user-managed - indices in Elephant - a necessity because we allow arbitrary lisp expressions to - determine index value so without bi-directional pointers, the indices cannot - automatically update a changed indexed value in derived slots" - (let ((slot-name (slot-definition-name slot-def)) - (oid (oid instance)) - (con (get-con instance))) - (declare (type fixnum oid)) - (if (no-indexing-needed? class instance slot-def oid) - (persistent-slot-writer con new-value instance slot-name) - (let ((class-idx (find-class-index class))) - (ensure-transaction (:store-controller con) - (when (get-value oid class-idx) - (remove-kv oid class-idx)) - (persistent-slot-writer con new-value instance slot-name) - (setf (get-value oid class-idx) instance)))))) - -(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((class-idx (find-class-index class)) - (oid (oid instance)) - (sc (get-con instance))) - (ensure-transaction (:store-controller sc) - (let ((obj (get-value oid class-idx))) - (remove-kv oid class-idx) - (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) - (setf (get-value oid class-idx) obj))))) - -(defun no-indexing-needed? (class instance slot-def oid) - (declare (ignore instance)) - (or (and (not (indexed slot-def)) ;; not indexed - (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes - (member oid *inhibit-indexing-list*))) ;; currently inhibited - -;; =========================== -;; CLASS INDEX INTERFACE -;; =========================== +;; ================================== +;; LOW-LEVEL CLASS INDEXING API +;; ==================================

(defmethod find-class-index ((class-name symbol) &key (sc *store-controller*) (errorp t)) (find-class-index (find-class class-name) :sc sc :errorp errorp)) @@ -148,7 +110,6 @@ :format-control "Class ~A is not enabled for indexing" :format-arguments (list (class-name class)))))

- (defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil)) (find-inverted-index (find-class class) slot :null-on-fail null-on-fail))

@@ -185,9 +146,49 @@ (t (e) (warn "Unable to clear class index caches ~A" e)))))

-;; ============================= -;; INDEXING INTERFACE -;; ============================= +;; ============================ +;; METACLASS PROTOCOL HOOKS +;; ============================ + +(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-indexed slots. This is a side effect of user-managed + indices in Elephant - a necessity because we allow arbitrary lisp expressions to + determine index value so without bi-directional pointers, the indices cannot + automatically update a changed indexed value in derived slots" + (let ((slot-name (slot-definition-name slot-def)) + (oid (oid instance)) + (con (get-con instance))) + (declare (type fixnum oid)) + (if (no-indexing-needed? class instance slot-def oid) + (persistent-slot-writer con new-value instance slot-name) + (let ((class-idx (find-class-index class))) + (ensure-transaction (:store-controller con) + (when (get-value oid class-idx) + (remove-kv oid class-idx)) + (persistent-slot-writer con new-value instance slot-name) + (setf (get-value oid class-idx) instance)))))) + +(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) + (let ((class-idx (find-class-index class)) + (oid (oid instance)) + (sc (get-con instance))) + (ensure-transaction (:store-controller sc) + (let ((obj (get-value oid class-idx))) + (remove-kv oid class-idx) + (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) + (setf (get-value oid class-idx) obj))))) + +(defun no-indexing-needed? (class instance slot-def oid) + (declare (ignore instance)) + (or (and (not (indexed slot-def)) ;; not indexed + (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes + (member oid *inhibit-indexing-list*))) ;; currently inhibited + +;; ============================ +;; EXPLICIT INDEX MGMT API +;; ============================

(defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) (let ((croot (controller-class-root sc))) @@ -321,9 +322,9 @@ (warn "Derived index ~A does not exist in ~A" name (class-name class)) nil)))

-;; ========================= -;; Low level cursor API -;; ========================= +;; =================== +;; USER CURSOR API +;; ===================

(defgeneric make-inverted-cursor (persistent-metaclass name) (:documentation "Define a cursor on the inverted (slot or derived) index")) @@ -331,13 +332,6 @@ (defgeneric make-class-cursor (persistent-metaclass) (:documentation "Define a cursor over all class instances"))

-;; TODO! -;;(defgeneric make-join-cursor ((class persistent-metaclass) &rest specification) -;; (:documentation "Make a join cursor using the slot-value pairs in -;; the specification assoc-list. Support for complex queries -;; requiring new access to db-functions and a new cursor type")) - -;; implementation (defmethod make-inverted-cursor ((class persistent-metaclass) name) (make-cursor (find-inverted-index class name)))

@@ -355,9 +349,9 @@ (cursor-close ,var))))

-;; ==================================== -;; Low Level Mapping API -;; ==================================== +;; ====================== +;; USER MAPPING API +;; ======================

(defun map-class (fn class) "Perform a map operation across all instances of class. Takes a @@ -386,9 +380,9 @@ (map-index #'wrapper index :start start :end end))))

-;; =============================== -;; User-level LIST-oriented API -;; =============================== +;; ================= +;; USER SET API +;; =================

(defgeneric get-instances-by-class (persistent-metaclass)) (defgeneric get-instance-by-value (persistent-metaclass slot-name value)) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/24 14:51:59 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 03:37:37 1.19 @@ -62,6 +62,8 @@ #:btree-index #:get-primary-key #:primary #:key-form #:key-fn

+ #:struct-constructor + #:migrate #:*inhibit-slot-copy* #:add-symbol-conversion #:add-package-conversion #:*always-convert* @@ -121,6 +123,7 @@

;; Utilities #:slots-and-values + #:struct-slots-and-values ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/04 04:34:57 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 03:37:37 1.22 @@ -29,6 +29,20 @@ (funcall (symbol-function (controller-deserialize sc)) bs sc))

;; +;; Special structure support +;; + +(defgeneric struct-constructor (class) + (:documentation "Called to get the constructor name for a struct class. Users + should overload this when they want to serialize non-standard + constructor names. The default constructor make-xxx will work by + default. The argument is an eql style type: i.e. of type (eql 'my-struct)")) + +(defmethod struct-constructor ((class t)) + (symbol-function (intern (concatenate 'string "MAKE-" (symbol-name class)) + (symbol-package class)))) + +;; ;; SQL encoding support ;;

@@ -167,10 +181,8 @@ ;;;; Common utilities ;;;;

-;; slot names and values for ordinary objects - (defun slots-and-values (o) - (declare (optimize (speed 3) (safety 0))) + "List of slot names followed by values for object" (loop for sd in (compute-slots (class-of o)) for slot-name = (slot-definition-name sd) with ret = () @@ -182,6 +194,25 @@ (push slot-name ret)) finally (return ret)))

+(defun struct-slots-and-values (object) + "List of slot names followed by values for structure object" + (let ((result nil) + (slots + #+openmcl + (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%)) + (slots (if sd (ccl::sd-slots sd)))) + (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) + #+cmu + (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) + #+lispworks + (structure:structure-class-slot-names (class-of object)) + #+allegro + (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))) + (loop for slot in slots do + (push (slot-value object slot) result) + (push slot result)) + result)) + ;; array type tags

(declaim (type hash-table array-type-to-byte byte-to-array-type)) @@ -229,8 +260,7 @@ (defun int-byte-spec (position) "Shared byte-spec peformance hack; not thread safe so removed from use for serializer2" - (declare (optimize (speed 3) (safety 0)) - (type (unsigned-byte 24) position)) + (declare (type (unsigned-byte 24) position)) #+(or cmu sbcl allegro) (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) *resourced-byte-spec*) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/24 14:51:59 1.27 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:37:37 1.28 @@ -218,7 +218,6 @@ (setf (gethash frob circularity-hash) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) - (declare (dynamic-extent svs)) (%serialize (/ (length svs) 2)) (loop for item in svs do (%serialize item))))))) @@ -261,21 +260,8 @@ (loop for key being the hash-key of frob using (hash-value value) do - (%serialize key) - (%serialize value)))))) - ;; (structure-object - ;; (buffer-write-byte +struct+ bs) - ;; (let ((idp (gethash frob circularity-hash))) - ;; (if idp (buffer-write-int32 idp bs) - ;; (progn - ;; (buffer-write-int32 (incf lisp-obj-id) bs) - ;; (setf (gethash frbo circularity-hash) lisp-obj-id) - ;; (%serialize (type-of frob)) - ;; (let ((svs (slots-and-values frob))) - ;; (declare (dynamic-extent svs)) - ;; (%serialize (/ (length svs) 2)) - ;; (loop for item in svs - ;; do (%serialize item))))))) + (%serialize key) + (%serialize value)))))) (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob circularity-hash))) @@ -300,6 +286,18 @@ (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) + (structure-object + (buffer-write-byte +struct+ bs) + (let ((idp (gethash frob circularity-hash))) + (if idp (buffer-write-int32 idp bs) + (progn + (buffer-write-int32 (incf lisp-obj-id) bs) + (setf (gethash frob circularity-hash) lisp-obj-id) + (%serialize (type-of frob)) + (let ((svs (struct-slots-and-values frob))) + (%serialize (/ (length svs) 2)) + (loop for item in svs + do (%serialize item))))))) (t (format t "Can't serialize a object: ~A of type ~A~%" frob (type-of frob)))))) (%serialize frob) (release-circularity-hash circularity-hash) @@ -515,6 +513,24 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) + ((= tag +struct+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-o (lookup-id id))) + (if maybe-o maybe-o + (let ((typedesig (%deserialize bs))) + (let ((o (or (handler-case + (funcall (struct-constructor (find-class typedesig))) + (error (v) (format t "got typedesig error for struct: ~A ~A ~%" v typedesig) + (list 'caught-error v typedesig))) + (list 'uninstantiable-object-of-type typedesig)))) + (if (listp o) o + (progn + (add-object o) + (loop for i fixnum from 0 below (%deserialize bs) do + (let ((name (%deserialize bs)) + (value (%deserialize bs))) + (setf (slot-value o name) value))) + o))))))) (t (error (format nil "deserialize of object tagged with ~A failed" tag))))))) (etypecase buf-str (null (return-from deserialize nil))