cl-2sql

Lisp to SQL compiler for Common Lisp
git clone https://logand.com/git/cl-2sql.git/
Log | Files | Refs | README | LICENSE

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:
Mcl-2sql.asd | 1+
Amop.lisp | 268+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Morm.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))))