commit e4d2a2229d9c7222319b78fbe1fc842c1348e84f
parent 6e943ad7636b7b1d0ba300a5091790a9e9e049cd
Author: Tomas Hlavaty <tom@logand.com>
Date: Fri, 19 Aug 2011 02:29:28 +0200
replace some orm macros with mop magic
Diffstat:
| M | cl-2sql.asd | | | 1 | + |
| A | mop.lisp | | | 268 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | orm.lisp | | | 110 | ++++++++++--------------------------------------------------------------------- |
3 files changed, 283 insertions(+), 96 deletions(-)
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -26,4 +26,5 @@
(:file "macros")
;;#+(or postgresql sqlite) (:file "backend")
(:file "backend")
+ (:file "mop")
(:file "orm")))
diff --git a/mop.lisp b/mop.lisp
@@ -0,0 +1,267 @@
+(in-package :2sql-orm)
+
+(defparameter *instance-cache* nil)
+
+(defmacro with-instance-cache (args &body body)
+ (declare (ignore args))
+ `(let ((*instance-cache* (make-hash-table)))
+ ,@body))
+
+;; 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 (#+nil standard-object)
+ ((oid :type oid :initarg :oid :accessor oid))
+ (:metaclass persistent-class))
+
+;; http://www.cliki.net/MOP%20design%20patterns
+#+nil ;; TODO add persistent-object superclass automatically
+(defmacro init-instance ()
+ `(call-next-method)
+ #+nil
+ `(if (or #+nil(eq 'persistent-class (class-name class))
+ (loop
+ for x in direct-superclasses
+ thereis (subtypep x (find-class 'persistent-object))))
+ ;; already one of the (indirect) superclasses
+ (call-next-method)
+ ;; not one of the superclasses, so we have to add it
+ (apply #'call-next-method class
+ :direct-superclasses (append direct-superclasses
+ (list (find-class 'persistent-object)))
+ initargs)))
+
+;; http://www.cliki.net/MOP%20design%20patterns
+#+nil ;; TODO add persistent-object superclass automatically
+(defmethod initialize-instance :around ((class persistent-class) &rest initargs
+ &key direct-superclasses)
+ (declare (dynamic-extent initargs))
+ (init-instance))
+
+;; http://www.cliki.net/MOP%20design%20patterns
+#+nil ;; TODO add persistent-object superclass automatically
+(defmethod reinitialize-instance :around
+ ((class persistent-class) &rest initargs
+ &key (direct-superclasses '() direct-superclasses-p))
+ (declare (dynamic-extent initargs))
+ (if direct-superclasses-p
+ ;; if direct superclasses are explicitly passed this is exactly
+ ;; like above
+ (init-instance)
+ ;; if direct superclasses are not explicitly passed we _must_
+ ;; not change anything
+ (call-next-method)))
+
+(defparameter *initializing-instance* nil)
+
+(defun check-cached-instance (a)
+ (unless *initializing-instance*
+ (assert (eq a (gethash (oid a) *instance-cache*)))))
+
+(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 c2mop:slot-value-using-class :before ((class persistent-class)
+ (a persistent-object)
+ slotd)
+ (unless (eq 'oid (c2mop:slot-definition-name slotd))
+ (check-cached-instance a)))
+
+(defmethod (setf c2mop:slot-value-using-class) :before (value
+ (class persistent-class)
+ (a persistent-object)
+ slotd)
+ (unless (eq 'oid (c2mop:slot-definition-name slotd))
+ (check-cached-instance a)))
+
+(defstruct proxy oid)
+
+(defmethod c2mop:slot-value-using-class :around ((class persistent-class)
+ (a persistent-object)
+ slotd)
+ (let ((a (call-next-method)))
+ a
+ #+nil ;; TODO only for proxy slots
+ (etypecase a
+ (proxy (error "TODO maybe-dereference-proxy ~s" a))
+ (persistent-object a))))
+
+(defmethod (setf c2mop:slot-value-using-class) :around (value
+ (class persistent-class)
+ (a persistent-object)
+ slotd)
+ (call-next-method)
+ #+nil(error "TODO (setf c2mop:slot-value-using-class) :around"))
+
+;;; persistent slots
+
+(defclass persistent-slot-definition ()
+ (#+nil(transient :type boolean :initarg :transient :initform nil :accessor transient)
+ #+nil(ptype :initarg :ptype :accessor ptype)
+ #+nil(nullable :initarg :nullable :accessor nullable)))
+
+(defclass persistent-direct-slot-definition
+ (persistent-slot-definition c2mop:standard-direct-slot-definition)
+ ())
+
+(defclass persistent-effective-slot-definition
+ (persistent-slot-definition c2mop:standard-effective-slot-definition)
+ ())
+
+(defmethod c2mop:direct-slot-definition-class :around
+ ((class persistent-class) &rest initargs)
+ ;;(print (list :@@@-direct-slot-definition-class initargs))
+ (find-class 'persistent-direct-slot-definition))
+
+(defmethod c2mop:effective-slot-definition-class
+ ((class persistent-class) &rest initargs)
+ ;;(format t "getting eff class. initargs=~s~%" initargs)
+ (find-class 'persistent-effective-slot-definition))
+
+(defmethod c2mop:compute-effective-slot-definition
+ ((class persistent-class) slot-name direct-slots)
+ #+nil
+ (format t "computing slot definition: class=~s name=~s slots=~s~%"
+ class slot-name direct-slots)
+ (let ((result (call-next-method)))
+ ;;(break "~s" result)
+ #+nil
+ (format t " result: ~s~%" result)
+ result))
+
+#+nil
+(defmethod c2mop:compute-effective-slot-definition :around
+ ((class persistent-effective-slot-definition) name direct-slot-definitions)
+ (make-instance (c2mop:effective-slot-definition-class class)))
+
+#+nil
+(defmethod initialize-instance :around
+ ((class persistent-effective-slot-definition) &rest initargs
+ &key direct-superclasses)
+ (declare (ignore direct-superclasses))
+ (print (list :@@@@ initargs))
+ (call-next-method))
+
+
+#+nil
+(defclass foo ()
+ ((hi :initarg :hi)))
+
+;;(c2mop:class-slots (find-class 'foo))
+
+#+nil
+(defclass person (#+nil persistent-object foo)
+ ((name :type string :initarg :name #+nil :transient #+nil t)
+ (age :type natural0 :initarg :age))
+ (:metaclass persistent-class))
+
+;;(slot-value (make-instance 'person :age 12) 'age)
+
+;;(c2mop:class-slots (find-class 'person))
+
+#+nil
+(let ((x (make-instance 'person :hi "cus" :name "John" :age 12)))
+ (dolist (s (c2mop:class-slots (class-of x)))
+ (format t "slot ~s = ~s~%"
+ (c2mop:slot-definition-name s)
+ (slot-value x (c2mop:slot-definition-name s)))))
+
+#+nil
+(defun persistent-slot-p (slot)
+ (when (typep slot 'persistent-slot)
+ (transient slot)))
+
+#+nil
+(defun list-pslots2 (class)
+ (c2mop:class-slots class)
+ #+nil
+ (remove-if 'transient (c2mop:class-slots class)))
+
+;;(list-pslots (find-class 'person))
+;;(list-pslots (class-of (make-instance 'person :hi "cus" :name "John" :age 12)))
+
+
+
+(defun list-pslots (class)
+ (c2mop:class-slots (if (symbolp class) (find-class class) class)))
+
+(defun pslot-name (a)
+ (c2mop:slot-definition-name a))
+
+(defun pslot-ltype (a)
+ (c2mop:slot-definition-type a))
+
+(defun pslot-initargs (a)
+ (c2mop:slot-definition-initargs a))
+
+(defun pslot-initform (a)
+ (c2mop:slot-definition-initform a))
+
+(defun pslot-ptype (a)
+ (lisp-type-to-ptype (pslot-ltype a)))
+
+(defun pslot-nullable (a)
+ (let ((type (pslot-ltype a)))
+ (unless (eql 'boolean type)
+ (typep nil type))))
+
+;; (pslot-ptype (cadr (list-pslots (find-class 'person))))
+
+#+nil
+(defpclass bar ()
+ ((slot1 :initarg :slot1 :accessor slot1)
+ (slot2 :initarg :slot2 :accessor slot2)))
+
+;;(with-instance-cache () (slot2 (make-pinstance 'bar :oid 123 :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)
+
+#+nil
+(defpclass person ()
+ ((name :type string :initarg :name)
+ (age :type natural0 :initarg :age))
+ #+nil
+ (:metaclass persistent-class))
+
+#+nil
+(defpclass person ()
+ ((name :type string :initarg :name)
+ (birth-date :type pdate :initarg :birth-date))
+ #+nil
+ (:metaclass persistent-class))
+
+
+
+;;; http://www.b9.com/blog/archives/000084.html
+;;
+;; Also, special thanks to Christophe Rhodes, frequent contributor to
+;; SBCL's MOP, for his excellent suggestion in response to a question
+;; for improving CLSQL's MOP internals: CLSQL object definitions use
+;; custom slot types. For example, a CLSQL slot may have :type
+;; (varchar 10) specified which gets translated to a lisp type of (or
+;; null string). Rather than parsing and then re-storing the type
+;; atrribute of a slot in compute-effective-slot-definiton, Christophe
+;; suggested performing the type parsing in initialize-instance
+;; :around of the CLSQL direct-slot-definition object. Then, the real
+;; type attribute is stored in the both the direct and effective slot
+;; definition from the beginning.This is more AMOP complaint since
+;; AMOP doesn't specify that one may change the type attribute of a
+;; slot. This is clearly seen since CLSQL no longer needs to modify
+;; OpenMCL's ccl:type-predicate slot attribute after the type was
+;; changed in compute-effective-slot-definition.
+\ No newline at end of file
diff --git a/orm.lisp b/orm.lisp
@@ -113,97 +113,8 @@
(defptype oid () 'natural1)
-(defstruct pslot name ltype ptype nullable initarg initform)
-
-(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 ,(cons 'persistent-object direct-superclasses)
- ,(cons '(oid :type oid :initarg :oid :accessor oid) direct-slots)
- ,@(cons '(:metaclass persistent-class) options))
- (defmethod cl-postgres:to-sql-string ((a ,name))
- (cl-postgres:to-sql-string (oid a)))
- (let ((cache nil))
- (defmethod list-pslots ((class-name (eql ',name)))
- (or cache
- (setq cache
- (list
- ,@(loop
- for x in direct-slots
- for type = (cadr (member :type x))
- collect `(make-pslot
- :name ',(car x)
- :ltype ',type
- :ptype ',(lisp-type-to-ptype type)
- :nullable ', (unless (eql 'boolean type)
- (typep nil type))
- :initarg ',(cadr (member :initarg x))
- :initform ',(cadr (member :initform x)))))))))))
+(defmethod cl-postgres:to-sql-string ((a persistent-object))
+ (cl-postgres:to-sql-string (oid a)))
(defconstant +class-id-bit-size+ 16)
@@ -219,6 +130,11 @@
:crc32 (babel:string-to-octets (symbol-name class-name) :encoding :utf-8)))
(expt 2 +class-id-bit-size+)))
+(defmacro defpclass (name superclasses slots)
+ `(defclass ,name ,(cons 'persistent-object superclasses)
+ ,slots
+ (:metaclass persistent-class)))
+
(defun setup-pclass (class-name)
(2sql:query ()
`(q:create-table
@@ -228,6 +144,7 @@
(oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
,@(loop
for x in (list-pslots class-name)
+ unless (eq 'oid (pslot-name x))
collect `(q:column ,(pslot-name x)
,(pslot-ptype x)
,(pslot-nullable x)
@@ -264,7 +181,7 @@
(loop
for x in (list-pslots class-name)
for name = (pslot-name x)
- for initarg = (pslot-initarg x)
+ for initarg = (car (pslot-initargs x))
for ltype = (pslot-ltype x)
for c = (member initarg args)
if c collect (list (cadr c) name initarg ltype) into known
@@ -277,11 +194,11 @@
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 (name initarg ltype) in unknown
for v in (car
(insert-into class-name (mapcar #'cadr known)
(mapcar #'car known)
- (cons 'oid (mapcar #'car unknown))))
+ (mapcar #'car unknown)))
appending (list initarg (assert-type v ltype)))))))
(assert (not (gethash (oid x) *instance-cache*)))
(setf (gethash (oid x) *instance-cache*) x))))
@@ -326,7 +243,7 @@
(values (let ((oid (pop row))
(args (loop
for x in pslots
- appending (list (pslot-initarg x) (pop row))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
+ appending (list (car (pslot-initargs 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
@@ -340,12 +257,13 @@
(if alias
(intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
name)))
- (cons (sym 'oid) (mapcar (lambda (x) (sym (pslot-name x))) pslots))))))
+ (mapcar (lambda (x) (sym (pslot-name x))) pslots)))))
(defmacro with-pclasses (names &body body)
(labels ((rec (x)
(if x
`(progn
+ (c2mop:ensure-finalized (find-class ',(car x)))
(2sql-orm:setup-pclass ',(car x))
(unwind-protect ,(rec (cdr x))
(2sql:query () '(q:drop-table ,(car x) t t))))
