1 (in-package :meta-model
)
3 (defvar *meta-models
* (make-hash-table))
5 (defclass meta-model-class
()
7 :accessor meta-model.name
11 :accessor meta-model.slots
15 :accessor meta-model.superclasses
16 :initarg
:superclasses
19 :accessor meta-model.options
23 :accessor meta-model.metadata
27 :accessor meta-model.instance
31 :accessor meta-model.base-type
35 (defmethod meta-model.metadata
((self (eql nil
)))
38 (defmethod meta-model.metadata
((self symbol
))
39 (meta-model.metadata
(gethash self
*meta-models
*)))
41 (defmethod meta-model.metadata
((self standard-object
))
42 (meta-model.metadata
(class-name (class-of self
))))
44 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
45 (defmethod make-meta-model (name supers slots options
)
46 (let ((m (make-instance 'meta-model-class
51 ;; TODO : the metadata should inherit any superclasses
53 (setf (gethash name
*meta-models
*) m
))))
55 (defmacro define-meta-model
(name supers slots
&rest options
)
56 `(make-meta-model ',name
',supers
',slots
',options
))
58 (defgeneric generate-base-class-definition
(base-type model name args
))
60 (defmethod generate-base-class-expander ((model t
) name args
)
61 (generate-base-class-definition (meta-model.base-type model
) model name args
))
64 (defmethod view-class-metadata ((model t
))
66 This is what meta-model.metadata used to be called,
67 most of the below functions expect this method to exist"
68 (meta-model.metadata model
))
70 (defun list-item-helper (type view
&key
(ret-fun #'car
))
71 "A helper function for the LIST-* methods"
73 (mapcar #'(lambda (slot)
74 (let ((ret-val (funcall ret-fun slot
))
75 (kind (getf (cdr slot
) :db-kind
)))
78 (view-class-metadata view
))))
80 (defmethod list-join-attributes ((view t
))
81 "Returns all slots as an alist of (SLOT-NAME JOIN-ATTRIBUTES) where J-A is the contents of the :JOIN-CLASS portion of a slot definition"
82 (remove nil
(mapcar #'(lambda (def)(cons (car def
) (getf (cdr def
) :db-info
))) (view-class-metadata view
))))
84 (defun list-relations-helper (view predicate-method
&key
(test-key :home-key
) (return-key :join-class
) (return-full nil
))
85 "A helper function for the listing join, relations and the like"
86 (remove nil
(mapcar #'(lambda (x)
87 (when (funcall predicate-method view
(getf (cdr x
) test-key
))
90 (getf (cdr x
) return-key
))))
91 (list-join-attributes view
))))
93 (defmethod list-slots ((view t
))
94 "list the non-joined slots of VIEW-CLASS"
95 (remove-if #'(lambda (x) (find x
(list-joins view
)))
96 (append (list-item-helper :key view
)
97 (list-item-helper nil view
)
98 (list-item-helper :base view
))))
100 (defmethod list-slot-types ((view t
))
101 "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
102 (labels ((rfun (slot)
104 (list (getf (cdr slot
):type
))))
109 (append (lister :key
) (lister :base
) (lister nil
))))
111 (defmethod slot-type ((view t
) slot
)
112 "returns the CLSQL type of SLOT"
113 (second (assoc slot
(list-slot-types view
))))
115 (defmethod list-joins ((view t
))
116 "lists slots that represent joins"
117 (list-item-helper :join view
))
119 (defmethod list-keys ((view t
))
120 "lists slots marked as :key"
121 (list-item-helper :key view
))
123 (defmethod primary-key-p ((view t
) slot
)
124 "returns slot if it is primary key (NOTE: Currently this returns T if the slot appears in LIST_KEYS and does not take into account the :primary-key option. b0rked, to be sure"
125 (find slot
(list-keys view
)))
127 (defmethod list-foreign-keys ((view t
))
128 "returns a list of FOREIGN-KEYS"
129 (flet ((my-primary-key-p (slot)
130 (primary-key-p view slot
)))
131 (remove nil
(remove-if #'my-primary-key-p
132 (mapcar #'(lambda (def)
133 (getf (cdr def
) :home-key
))
134 (list-join-attributes view
))))))
136 (defmethod foreign-key-p ((view t
) slot
)
137 "returns SLOT if it's a foreign key, nil otherwise"
138 (find slot
(list-foreign-keys view
)))
142 (defmethod list-has-a ((view t
))
143 "returns a list of view-classes that are in a 1:1 relationship with VIEW"
144 (list-relations-helper view
#'foreign-key-p
))
146 (defmethod list-has-many ((view t
))
147 "returns a list of view-classes that are in a 1:Many relationship with VIEW"
149 (remove-if #'(lambda (x) (getf (cdr x
) :target-slot
))
150 (list-relations-helper
152 #'primary-key-p
:return-full t
))))
154 (defmethod list-many-to-many ((view t
))
155 "returns a list of view-classes that are in a Many:Many relationship with VIEW"
156 (mapcar #'car
(list-relations-helper
159 (declare (ignore c
))a
)
160 :test-key
:target-slot
163 (defmethod explode-foreign-key ((model clsql
:standard-db-object
) slot
&key
(createp t
))
164 "returns the clsql view-class joined on SLOT"
165 (dolist (s (list-join-attributes model
))
166 (when (equal (getf (cdr s
) :home-key
) slot
)
167 (let* ((fkey (getf (cdr s
) :foreign-key
))
168 (new (sync-instance (make-instance (getf (cdr s
) :join-class
))))
169 (val (or (slot-value model
(car s
))
173 (slot-value model slot
)
174 (slot-value new fkey
))
175 (sync-instance model
)
176 (slot-value model
(car s
)))))))
178 (return-from explode-foreign-key
179 (values val fkey
))))))
181 (defun find-join-helper (foreign-key)
183 (declare (ignore class
))
184 (when (equal slot foreign-key
) t
)))
186 (defmethod find-join-class ((view t
) foreign-key
)
187 "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
188 (car (list-relations-helper view
(find-join-helper foreign-key
) )))
190 (defmethod find-join-key ((view t
) foreign-key
)
191 "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
192 (car (list-relations-helper view
(find-join-helper foreign-key
) :return-key
:foreign-key
)))
194 (defmethod explode-has-many ((view t
) join-slot
)
195 "returns the class of the join as the primary value, the second and third value is the home key and the foreign key"
196 (let ((att (assoc join-slot
(list-join-attributes view
))))
197 (values (getf (cdr att
) :join-class
)
198 (getf (cdr att
) :home-key
)
199 (getf (cdr att
) :foreign-key
))))
201 (defgeneric expr-
= (instance slot-name value
)
202 (:documentation
"Create search expression for appropriate backend."))
204 (defgeneric expr-
> (instance slot-name value
)
205 (:documentation
"Create search expression for appropriate backend."))
207 (defgeneric expr-
< (instance slot-name value
)
208 (:documentation
"Create search expression for appropriate backend."))
210 (defgeneric expr-ends-with
(instance slot-name value
)
211 (:documentation
"Create search expression for appropriate backend."))
213 (defgeneric expr-starts-with
(instance slot-name value
)
214 (:documentation
"Create search expression for appropriate backend."))
216 (defgeneric expr-contains
(instance slot-name value
)
217 (:documentation
"Create search expression for appropriate backend."))
219 (defgeneric expr-and
(instance &rest args
)
220 (:documentation
"Create search expression for appropriate backend."))
222 (defgeneric expr-or
(instance &rest args
)
223 (:documentation
"Create search expression for appropriate backend."))
225 (defgeneric expr-not
(instance &rest args
)
226 (:documentation
"Create search expression for appropriate backend."))
228 (defgeneric select-instances
(instance &rest args
)
229 (:documentation
"Select instances in backend dependent way"))
231 (defgeneric prepare-slot-name-for-select
(instance slot-name
)
234 (defmacro def-compare-expr
(instance-type name expr
&key value-format
)
235 `(defmethod ,name
((instance ,instance-type
) slot-name value
)
236 (declare (ignore instance
))
237 (,expr
(prepare-slot-name-for-select instance slot-name
) ,(typecase value-format
239 (string `(format nil
,value-format value
))
240 (t `(,value-format value
))))))
243 (defmacro def-logical-expr
(instance-type name expr
)
244 `(defmethod ,name
((instance ,instance-type
) &rest args
)
245 (declare (ignore instance
))