[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Feb 25 03:37:39 UTC 2007
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))
More information about the Elephant-cvs
mailing list