From 42d345c391ca139503d4e5a6b70b2350113f929b Mon Sep 17 00:00:00 2001 From: Drew Crampsie Date: Wed, 31 Aug 2005 14:35:12 -0700 Subject: [PATCH 1/1] Major refactoring of meta-model code + added dependancy on cl-pg-introspect + patches meta-model no longer generates a class definition for each model, but uses a hash table to store instance instead. i never used the named meta-model-classes anyway also, we now require a patched version of cl-pg-introspect which can be found at versions.tech.coop darcs-hash:20050831213512-5417e-6bfc8ef88a8b6b7e25a98159adc6d2a8058b61af.gz --- lisp-on-lines.asd | 4 +-- src/backend/clsql.lisp | 43 +++++++---------------- src/meta-model.lisp | 78 ++++++++++++++++++++++-------------------- src/packages.lisp | 12 +++---- 4 files changed, 61 insertions(+), 76 deletions(-) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index 865f11d..937f5e0 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -17,12 +17,12 @@ :depends-on (:src) :pathname "src/backend/" :components ((:file "clsql")))) - :depends-on (:clsql)) + :depends-on (:clsql :clsql-pg-introspect)) ;; this is no longer used (defsystem :meta-model-clsql :components () - :depends-on (:meta-model :clsql)) + :depends-on (:meta-model :clsql )) (defsystem :mewa :components ((:module :src diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp index 5eff8cc..0083efc 100644 --- a/src/backend/clsql.lisp +++ b/src/backend/clsql.lisp @@ -9,7 +9,6 @@ (export 'list-base-classes) - (defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only-p nil) (database *default-database*)) (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym)))) (get-def (slot) (caar (query @@ -45,11 +44,11 @@ (defmethod list-base-classes ((type (eql :clsql))) *clsql-base-classes*) -(defmethod def-base-type-class-expander ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t)) +(defmethod generate-base-class-definition ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t)) `(def-view-class ,name () ,(meta-model.metadata model))) -(defmethod def-base-type-class-expander :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t)) +(defmethod generate-base-class-definition :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t)) (unless (member name *clsql-base-classes*) (setf *clsql-base-classes* (cons name *clsql-base-classes*)))) @@ -218,7 +217,7 @@ AND fa.attnum = ANY (pg_constraint.confkey)")) :accessor ,name :db-kind :join :db-info (:join-class ,(car row) - :home-key ,home-key + :home-key ,home-key :foreign-key ,foreign-key :target-slot ,name :set t)))) @@ -242,35 +241,19 @@ AND fa.attnum = ANY (pg_constraint.confkey)")) "Create and instrument CLSQL view-class NAME and appropriate meta-model class its default name is %NAME-meta-model." - (let ((model-name (cond ((eq :model-name (car args)) - (pop args) ; remove keyword - (pop args)) ; get value - (t (intern (format nil "%~S-META-MODEL" name)))))) - - `(progn - (let* ((m (def-meta-model ,model-name ,supers ,slots ,args)) - (i (make-instance m))) - (setf (meta-model.base-type i) :clsql) - (prog1 (eval (def-base-class-expander i ',name ',args)) - (defmethod meta-model.metadata ((self ,name)) - (meta-model.metadata i))))))) + `(progn + (let* ((m (define-meta-model ,name ,supers ,slots ,args))) + (setf (meta-model.base-type m) :clsql) + (eval (generate-base-class-expander m ',name ',args))))) -(defmacro def-view-class/table (table &optional (name (sql->sym table)) model-name) +(defmacro def-view-class-from-table (table &optional + (name (clsql-pg-introspect::intern-normalize-for-lisp table))) "takes the name of a table as a string and creates a clsql view-class" - (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp))) - (table-slots (table->slots table pkey name)) - (join-slots - (let ((slots nil)) - (dolist (exp (get-fkey-explosions)) - (when (equalp (car exp) (sql->sym table)) - (setf slots (cons (cdr exp) slots)))) - slots))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (def-view-class/meta ,name - () - ,(append table-slots join-slots) - ,@(when model-name (list :model-name model-name)))))) + `(clsql-pg-introspect:gen-view-class ,table + :classname ,name + :generate-joins :all + :definer def-view-class/meta)) (defmethod prepare-slot-name-for-select ((i standard-db-object) slot-name) diff --git a/src/meta-model.lisp b/src/meta-model.lisp index 09f7f6f..de7335e 100644 --- a/src/meta-model.lisp +++ b/src/meta-model.lisp @@ -1,12 +1,25 @@ (in-package :meta-model) -(defvar *meta-models* nil) - -(defun list-meta-models () - *meta-models*) +(defvar *meta-models* (make-hash-table)) (defclass meta-model-class () - ((metadata + ((name + :accessor meta-model.name + :initarg :name + :initform nil) + (slots + :accessor meta-model.slots + :initarg :slots + :initform nil) + (superclasses + :accessor meta-model.superclasses + :initarg :superclasses + :initform nil) + (options + :accessor meta-model.options + :initarg :options + :initform nil) + (metadata :accessor meta-model.metadata :initarg :metadata :initform nil) @@ -23,39 +36,30 @@ nil) (defmethod meta-model.metadata ((self symbol)) - (meta-model.metadata (make-instance self))) - -(defun gen-supers (supers) - (let (subclassp) - (dolist (x supers) - (when (member x (list-meta-models)) - (setf subclassp t))) - (if subclassp - supers - (cons 'meta-model-class supers)))) - -(defmethod %def-meta-model ((base-type t) name supers slots &rest options) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ,name ,(gen-supers supers) - () - (:default-initargs :metadata ',slots :base-type ,base-type)))) - - -(defmacro def-meta-model (name supers slots &rest options) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (when (not (member (quote ,name) *meta-models*)) - (setf *meta-models* (cons (quote ,name) *meta-models*))) - - (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options))) - class))) - -(defgeneric def-base-type-class-expander (base-type model name args)) - -(defmethod def-base-class-expander ((model t) name args) - (def-base-type-class-expander (meta-model.base-type model) model name args)) + (meta-model.metadata (gethash self *meta-models*))) + +(defmethod meta-model.metadata ((self standard-object)) + (meta-model.metadata (class-name (class-of self)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod make-meta-model (name supers slots options) + (let ((m (make-instance 'meta-model-class + :name name + :superclasses supers + :slots slots + :options options + ;; TODO : the metadata should inherit any superclasses + :metadata slots))) + (setf (gethash name *meta-models*) m)))) + +(defmacro define-meta-model (name supers slots &rest options) + `(make-meta-model ',name ',supers ',slots ',options)) + +(defgeneric generate-base-class-definition (base-type model name args)) + +(defmethod generate-base-class-expander ((model t) name args) + (generate-base-class-definition (meta-model.base-type model) model name args)) -(defmethod base-class-name ((model t)) - (class-name (class-of (meta-model.instance model)))) (defmethod view-class-metadata ((model t)) " diff --git a/src/packages.lisp b/src/packages.lisp index 0c7568e..29815b3 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -1,15 +1,13 @@ (defpackage :meta-model - (:use :common-lisp :clsql) + (:use :common-lisp :clsql :clsql-pg-introspect) + (:shadow :primary-key-p) (:export :meta-model-class :meta-model.base-type :meta-model.instance :meta-model.metadata - :def-meta-model - :def-base-class - :%def-base-class - - :def-view-class/table + :define-meta-model + :def-view-class-from-table :def-view-class/meta :view-class-metadata :create-table-from-model @@ -76,7 +74,7 @@ :search-query)) (defpackage :lisp-on-lines - (:use :mewa :meta-model :common-lisp :it.bese.ucw) + (:use :mewa :meta-model :common-lisp :it.bese.ucw :js) (:nicknames :lol) (:export ;;;; LoL -- 2.20.1