1 (in-package :meta-model
)
3 (defvar *meta-models
* nil
)
5 (defun list-meta-models ()
8 (defclass meta-model-class
()
10 :accessor meta-model.metadata
14 :accessor meta-model.instance
18 :accessor meta-model.base-type
22 (defmethod meta-model.metadata
((self (eql nil
)))
25 (defun gen-supers (supers)
28 (when (member x
(list-meta-models))
32 (cons 'meta-model-class supers
))))
34 (defmethod %def-meta-model
((base-type t
) name supers slots
&rest options
)
35 `(defclass ,name
,(gen-supers supers
)
37 (:default-initargs
:metadata
',slots
:base-type
,base-type
)))
40 (defmacro def-meta-model
(name supers slots
&rest options
)
42 (when (not (member (quote ,name
) *meta-models
*))
43 (setf *meta-models
* (cons (quote ,name
) *meta-models
*)))
45 (let ((class ,(%def-meta-model
(cadr (or (assoc :base-type options
) '(t t
))) name supers slots options
)))
48 (defgeneric def-base-type-class-expander
(base-type model name args
))
50 (defmethod def-base-class-expander ((model t
) name args
)
51 (def-base-type-class-expander (meta-model.base-type model
) model name args
))
53 (defmacro def-base-class
(name (model) &rest args
)
54 (let ((i (make-instance model
)))
56 (eval ,(def-base-class-expander i name args
))
57 (defmethod meta-model.metadata
((m ,name
))
58 ',(meta-model.metadata i
)))))
61 (defmethod base-class-name ((model t
))
62 (class-name (class-of (meta-model.instance model
))))
66 (defmethod view-class-metadata ((model t
))
67 (meta-model.metadata model
))
69 (defun list-item-helper (type view
&key
(ret-fun #'car
))
70 "A helper function for the LIST-* methods"
72 (mapcar #'(lambda (slot)
73 (let ((ret-val (funcall ret-fun slot
))
74 (kind (getf (cdr slot
) :db-kind
)))
77 (view-class-metadata view
))))
79 (defmethod list-join-attributes ((view t
))
80 "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"
81 (remove nil
(mapcar #'(lambda (def)(cons (car def
) (getf (cdr def
) :db-info
))) (view-class-metadata view
))))
83 (defun list-relations-helper (view predicate-method
&key
(test-key :home-key
) (return-key :join-class
) (return-full nil
))
84 "A helper function for the listing join, relations and the like"
85 (remove nil
(mapcar #'(lambda (x)
86 (when (funcall predicate-method view
(getf (cdr x
) test-key
))
89 (getf (cdr x
) return-key
))))
90 (list-join-attributes view
))))
92 (defmethod list-slots ((view t
))
93 "list the non-joined slots of VIEW-CLASS"
94 (remove-if #'(lambda (x) (find x
(list-joins view
)))
95 (append (list-item-helper :key view
)
96 (list-item-helper nil view
)
97 (list-item-helper :base view
))))
99 (defmethod list-slot-types ((view t
))
100 "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
101 (labels ((rfun (slot)
103 (list (getf (cdr slot
):type
))))
108 (append (lister :key
) (lister :base
))))
110 (defmethod slot-type ((view t
) slot
)
111 "returns the CLSQL type of SLOT"
112 (second (assoc slot
(list-slot-types view
))))
114 (defmethod list-joins ((view t
))
115 "lists slots that represent joins"
116 (list-item-helper :join view
))
118 (defmethod list-keys ((view t
))
119 "lists slots marked as :key"
120 (list-item-helper :key view
))
122 (defmethod primary-key-p ((view t
) slot
)
123 "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"
124 (find slot
(list-keys view
)))
126 (defmethod list-foreign-keys ((view t
))
127 "returns a list of FOREIGN-KEYS"
128 (flet ((my-primary-key-p (slot)
129 (primary-key-p view slot
)))
130 (remove nil
(remove-if #'my-primary-key-p
131 (mapcar #'(lambda (def)
132 (getf (cdr def
) :home-key
))
133 (list-join-attributes view
))))))
135 (defmethod foreign-key-p ((view t
) slot
)
136 "returns SLOT if it's a foreign key, nil otherwise"
137 (find slot
(list-foreign-keys view
)))
141 (defmethod list-has-a ((view t
))
142 "returns a list of view-classes that are in a 1:1 relationship with VIEW"
143 (list-relations-helper view
#'foreign-key-p
))
145 (defmethod list-has-many ((view t
))
146 "returns a list of view-classes that are in a 1:Many relationship with VIEW"
148 (remove-if #'(lambda (x) (getf (cdr x
) :target-slot
))
149 (list-relations-helper
151 #'primary-key-p
:return-full t
))))
153 (defmethod list-many-to-many ((view t
))
154 "returns a list of view-classes that are in a Many:Many relationship with VIEW"
155 (mapcar #'car
(list-relations-helper
158 (declare (ignore c
))a
)
159 :test-key
:target-slot
162 (defmethod explode-foreign-key ((model clsql
:standard-db-object
) slot
)
163 "returns the clsql view-class joined on SLOT"
164 (dolist (s (list-join-attributes model
))
165 (when (equal (getf (cdr s
) :home-key
) slot
)
166 (let ((val (slot-value model
(car s
))))
167 (return-from explode-foreign-key
168 (values (if val val
(make-instance (getf (cdr s
) :join-class
))) (getf (cdr s
) :foreign-key
)))))))
170 (defun find-join-helper (foreign-key)
172 (declare (ignore class
))
173 (when (equal slot foreign-key
) t
)))
175 (defmethod find-join-class ((view t
) foreign-key
)
176 "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
177 (car (list-relations-helper view
(find-join-helper foreign-key
) )))
179 (defmethod find-join-key ((view t
) foreign-key
)
180 "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
181 (car (list-relations-helper view
(find-join-helper foreign-key
) :return-key
:foreign-key
)))
183 (defmethod explode-has-many ((view t
) join-slot
)
184 "returns the class of the join as the primary value, the second and third value is the home key and the foreign key"
185 (let ((att (assoc join-slot
(list-join-attributes view
))))
186 (values (getf (cdr att
) :join-class
)
187 (getf (cdr att
) :home-key
)
188 (getf (cdr att
) :foreign-key
))))
190 (defgeneric expr-
= (instance slot-name value
)
191 (:documentation
"Create search expression for appropriate backend."))
193 (defgeneric expr-
> (instance slot-name value
)
194 (:documentation
"Create search expression for appropriate backend."))
196 (defgeneric expr-
< (instance slot-name value
)
197 (:documentation
"Create search expression for appropriate backend."))
199 (defgeneric expr-ends-with
(instance slot-name value
)
200 (:documentation
"Create search expression for appropriate backend."))
202 (defgeneric expr-starts-with
(instance slot-name value
)
203 (:documentation
"Create search expression for appropriate backend."))
205 (defgeneric expr-contains
(instance slot-name value
)
206 (:documentation
"Create search expression for appropriate backend."))
208 (defgeneric expr-and
(instance &rest args
)
209 (:documentation
"Create search expression for appropriate backend."))
211 (defgeneric expr-or
(instance &rest args
)
212 (:documentation
"Create search expression for appropriate backend."))
214 (defgeneric expr-not
(instance &rest args
)
215 (:documentation
"Create search expression for appropriate backend."))
217 (defgeneric select-instances
(instance &rest args
)
218 (:documentation
"Select instances in backend dependent way"))
220 (defmacro def-compare-expr
(instance-type name expr
&key value-format
)
221 `(defmethod ,name
((instance ,instance-type
) slot-name value
)
222 (declare (ignore instance
))
223 (,expr slot-name
,(typecase value-format
225 (string `(format nil
,value-format value
))
226 (t `(,value-format value
))))))
228 (defmacro def-logical-expr
(instance-type name expr
)
229 `(defmethod ,name
((instance ,instance-type
) &rest args
)
230 (declare (ignore instance
))