commit 6e943ad7636b7b1d0ba300a5091790a9e9e049cd
parent 21d61b90e19c0b8ed2bc79215d08149d4f73a17a
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 14 Aug 2011 22:26:57 +0200
introduced mop and instance cache
Diffstat:
3 files changed, 102 insertions(+), 22 deletions(-)
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -17,6 +17,7 @@
;;#+sqlite :sqlite
:cl-postgres
:sqlite
+ :closer-mop
)
:serial t
:components ((:file "packages")
diff --git a/orm.lisp b/orm.lisp
@@ -67,9 +67,6 @@
(defgeneric ptype-macroexpand (type))
-(defgeneric pclassp (class-name)
- (:method (a)))
-
(defun lisp-type-to-ptype (type) ;; TODO more types
(if (atom type)
(case type
@@ -82,7 +79,7 @@
(octet-vector '(q:blob-type))
(t
(cond
- ((pclassp type) (lisp-type-to-ptype 'oid))
+ ((subtypep type 'persistent-object) (lisp-type-to-ptype 'oid))
(t (let ((x (ptype-macroexpand type)))
(assert (not (eq x type)))
(lisp-type-to-ptype x))))))
@@ -120,13 +117,75 @@
(defgeneric list-pslots (class-name))
+;; http://users.encs.concordia.ca/~haarslev/publications/jvlc92/node6.html
+;; http://objectmix.com/lisp/725624-help-creating-clos-meta-classes.html
+;; http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-71.htm
+;; http://paste.lisp.org/display/123125
+;; http://www.cliki.net/MOP%20design%20patterns
+;; http://bc.tech.coop/blog/040412.html
+
+(defclass persistent-class (standard-class)
+ ())
+
+(defmethod c2mop:validate-superclass ((class persistent-class)
+ (superclass standard-class))
+ t)
+
+(defclass persistent-object (standard-object)
+ ()
+ (:metaclass persistent-class))
+
+(defparameter *instance-cache* nil)
+
+(defmacro with-instance-cache (args &body body)
+ (declare (ignore args))
+ `(let ((*instance-cache* (make-hash-table)))
+ ,@body))
+
+(defun check-cached-instance (a)
+ (unless *initializing-instance*
+ (assert (eq a (gethash (oid a) *instance-cache*)))))
+
+(defmethod c2mop:slot-value-using-class :before ((class persistent-class)
+ (a persistent-object)
+ slotd)
+ (unless (eq 'oid (c2mop:slot-definition-name slotd))
+ ;;(describe slotd)
+ (check-cached-instance a)))
+
+(defparameter *initializing-instance* nil)
+
+(defmethod c2mop::shared-initialize :around ((object persistent-object)
+ slot-names
+ &rest initargs
+ &key &allow-other-keys)
+ (declare (ignore initargs))
+ (let ((*initializing-instance* t))
+ (call-next-method)))
+
+(defmethod (setf c2mop:slot-value-using-class) :before (value
+ (class persistent-class)
+ (a persistent-object)
+ slotd)
+ (unless (eq 'oid (c2mop:slot-definition-name slotd))
+ ;;(describe slotd)
+ (check-cached-instance a)))
+
+#+nil
+(defpclass bar ()
+ ((slot1 :initarg :slot1 :accessor slot1)
+ (slot2 :initarg :slot2 :accessor slot2)))
+
+;;(slot2 (make-instance 'bar :slot2 2))
+;;(setf (slot2 (make-instance 'bar :slot2 2)) 3)
+;;(slot-value (make-instance 'bar :slot2 2) 'slot2)
+;;(setf (slot-value (make-instance 'bar :slot2 2) 'slot2) 3)
+
(defmacro defpclass (name direct-superclasses direct-slots &rest options)
`(progn
- (defclass ,name ,direct-superclasses
+ (defclass ,name ,(cons 'persistent-object direct-superclasses)
,(cons '(oid :type oid :initarg :oid :accessor oid) direct-slots)
- ,@options)
- (defmethod pclassp ((class-name (eql ',name)))
- t)
+ ,@(cons '(:metaclass persistent-class) options))
(defmethod cl-postgres:to-sql-string ((a ,name))
(cl-postgres:to-sql-string (oid a)))
(let ((cache nil))
@@ -182,6 +241,21 @@
(q:returning ,returning-cols))))
(defun assert-type (value type)
+ (print (list :assert-type1 value type (type-of value)))
+ (unless (typep value type)
+ (cond ;; TODO more cases
+ ((typep value 'string)
+ (setq value (coerce value 'simple-string)))
+ ((typep value 'simple-date:timestamp)
+ (setq value (multiple-value-bind (y m d hh mm ss ms)
+ (simple-date:decode-timestamp value)
+ (make-ptimestamp-with-timezone
+ :date (make-pdate :y y :m m :d d)
+ :time (make-ptime :hh hh :mm mm :ss ss :ms ms)
+ :timezone nil))))
+ ((subtypep type 'persistent-object)
+ (error "TODO assert-type persistent-object"))))
+ (print (list :assert-type2 value type (type-of value)))
(assert (typep value type))
value)
@@ -197,18 +271,20 @@
else collect (list name initarg ltype) into unknown
finally (return (values known unknown)))
;; TODO cache eql oid->instance
- (apply #'make-instance class-name
- (nconc
- (loop
- for (v name initarg ltype) in known
- appending (list initarg (assert-type v ltype)))
- (loop
- for (name initarg ltype) in (cons (list 'oid :oid 'oid) unknown)
- for v in (car
- (insert-into class-name (mapcar #'cadr known)
- (mapcar #'car known)
- (cons 'oid (mapcar #'car unknown))))
- appending (list initarg (assert-type v ltype)))))))
+ (let ((x (apply #'make-instance class-name
+ (nconc
+ (loop
+ for (v name initarg ltype) in known
+ appending (list initarg (assert-type v ltype)))
+ (loop
+ for (name initarg ltype) in (cons (list 'oid :oid 'oid) unknown)
+ for v in (car
+ (insert-into class-name (mapcar #'cadr known)
+ (mapcar #'car known)
+ (cons 'oid (mapcar #'car unknown))))
+ appending (list initarg (assert-type v ltype)))))))
+ (assert (not (gethash (oid x) *instance-cache*)))
+ (setf (gethash (oid x) *instance-cache*) x))))
(defparameter *instance-collector-cache* nil) ;; equal form->fn
@@ -251,6 +327,9 @@
(args (loop
for x in pslots
appending (list (pslot-initarg x) (pop row))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
+ (or (gethash oid *instance-cache*)
+ (apply #'make-pinstance tab :oid oid args)) ;; TODO test this case
+ #+nil
(unless (eq :null oid)
;; TODO uniq oid->instance cache
(apply #'make-instance tab :oid oid args))) ;; TODO fix values from rdbms backend to lisp, e.g. :null :true :false pclasp
@@ -281,4 +360,4 @@
(unwind-protect ,(rec (cdr x))
(2sql:query () '(q:drop-sequence ,(car x) t))))
`(progn ,@body))))
- (rec names)))
-\ No newline at end of file
+ (rec names)))
diff --git a/packages.lisp b/packages.lisp
@@ -45,6 +45,7 @@
#:defptype
#:defpclass
#:setup-pclass
+ #:with-instance-cache
#:make-pinstance
#:with-pinstance-collector-cache
#:query
