Commit | Line | Data |
---|---|---|
579597e3 | 1 | (in-package :meta-model) |
2 | ||
3 | (defvar *meta-models* nil) | |
4 | ||
5 | (defun list-meta-models () | |
6 | *meta-models*) | |
7 | ||
8 | (defclass meta-model-class () | |
9 | ((metadata | |
10 | :accessor meta-model.metadata | |
11 | :initarg :metadata | |
12 | :initform nil) | |
13 | (instance | |
14 | :accessor meta-model.instance | |
15 | :initarg :instance | |
16 | :initform nil) | |
17 | (base-type | |
18 | :accessor meta-model.base-type | |
9d6c69fb DC |
19 | :initarg :base-type |
20 | :initform :clsql))) | |
579597e3 | 21 | |
22 | (defmethod meta-model.metadata ((self (eql nil))) | |
23 | nil) | |
24 | ||
bf5ae490 DC |
25 | (defmethod meta-model.metadata ((self symbol)) |
26 | (meta-model.metadata (make-instance self))) | |
27 | ||
579597e3 | 28 | (defun gen-supers (supers) |
29 | (let (subclassp) | |
30 | (dolist (x supers) | |
31 | (when (member x (list-meta-models)) | |
32 | (setf subclassp t))) | |
33 | (if subclassp | |
34 | supers | |
35 | (cons 'meta-model-class supers)))) | |
36 | ||
37 | (defmethod %def-meta-model ((base-type t) name supers slots &rest options) | |
1da9fd46 DC |
38 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
39 | (defclass ,name ,(gen-supers supers) | |
40 | () | |
41 | (:default-initargs :metadata ',slots :base-type ,base-type)))) | |
579597e3 | 42 | |
43 | ||
44 | (defmacro def-meta-model (name supers slots &rest options) | |
1da9fd46 | 45 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
579597e3 | 46 | (when (not (member (quote ,name) *meta-models*)) |
47 | (setf *meta-models* (cons (quote ,name) *meta-models*))) | |
48 | ||
49 | (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options))) | |
50 | class))) | |
51 | ||
9d6c69fb | 52 | (defgeneric def-base-type-class-expander (base-type model name args)) |
579597e3 | 53 | |
9d6c69fb DC |
54 | (defmethod def-base-class-expander ((model t) name args) |
55 | (def-base-type-class-expander (meta-model.base-type model) model name args)) | |
579597e3 | 56 | |
579597e3 | 57 | (defmethod base-class-name ((model t)) |
58 | (class-name (class-of (meta-model.instance model)))) | |
579597e3 | 59 | |
60 | (defmethod view-class-metadata ((model t)) | |
835ac88d DC |
61 | " |
62 | This is what meta-model.metadata used to be called, | |
63 | most of the below functions expect this method to exist" | |
579597e3 | 64 | (meta-model.metadata model)) |
65 | ||
66 | (defun list-item-helper (type view &key (ret-fun #'car)) | |
67 | "A helper function for the LIST-* methods" | |
68 | (remove nil | |
69 | (mapcar #'(lambda (slot) | |
70 | (let ((ret-val (funcall ret-fun slot)) | |
71 | (kind (getf (cdr slot) :db-kind))) | |
72 | (when (eql kind type) | |
73 | ret-val ))) | |
74 | (view-class-metadata view)))) | |
75 | ||
76 | (defmethod list-join-attributes ((view t)) | |
77 | "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" | |
78 | (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) :db-info ))) (view-class-metadata view)))) | |
79 | ||
80 | (defun list-relations-helper (view predicate-method &key (test-key :home-key) (return-key :join-class) (return-full nil)) | |
81 | "A helper function for the listing join, relations and the like" | |
82 | (remove nil (mapcar #'(lambda (x) | |
83 | (when (funcall predicate-method view (getf (cdr x) test-key )) | |
84 | (if return-full | |
85 | x | |
86 | (getf (cdr x) return-key )))) | |
87 | (list-join-attributes view)))) | |
88 | ||
89 | (defmethod list-slots ((view t)) | |
90 | "list the non-joined slots of VIEW-CLASS" | |
91 | (remove-if #'(lambda (x) (find x (list-joins view))) | |
92 | (append (list-item-helper :key view) | |
93 | (list-item-helper nil view) | |
94 | (list-item-helper :base view)))) | |
95 | ||
96 | (defmethod list-slot-types ((view t)) | |
97 | "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type" | |
98 | (labels ((rfun (slot) | |
99 | (cons (car slot) | |
100 | (list (getf (cdr slot):type)))) | |
101 | (lister (type) | |
102 | (list-item-helper | |
103 | type view | |
104 | :ret-fun #'rfun))) | |
105 | (append (lister :key) (lister :base)))) | |
106 | ||
107 | (defmethod slot-type ((view t) slot) | |
108 | "returns the CLSQL type of SLOT" | |
109 | (second (assoc slot (list-slot-types view)))) | |
110 | ||
111 | (defmethod list-joins ((view t)) | |
112 | "lists slots that represent joins" | |
113 | (list-item-helper :join view)) | |
114 | ||
115 | (defmethod list-keys ((view t)) | |
116 | "lists slots marked as :key" | |
117 | (list-item-helper :key view)) | |
118 | ||
119 | (defmethod primary-key-p ((view t) slot) | |
120 | "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" | |
121 | (find slot (list-keys view))) | |
122 | ||
123 | (defmethod list-foreign-keys ((view t)) | |
124 | "returns a list of FOREIGN-KEYS" | |
125 | (flet ((my-primary-key-p (slot) | |
126 | (primary-key-p view slot))) | |
127 | (remove nil (remove-if #'my-primary-key-p | |
128 | (mapcar #'(lambda (def) | |
129 | (getf (cdr def) :home-key)) | |
130 | (list-join-attributes view)))))) | |
131 | ||
132 | (defmethod foreign-key-p ((view t) slot) | |
133 | "returns SLOT if it's a foreign key, nil otherwise" | |
134 | (find slot (list-foreign-keys view))) | |
135 | ||
136 | ||
137 | ||
138 | (defmethod list-has-a ((view t)) | |
139 | "returns a list of view-classes that are in a 1:1 relationship with VIEW" | |
140 | (list-relations-helper view #'foreign-key-p)) | |
141 | ||
142 | (defmethod list-has-many ((view t)) | |
143 | "returns a list of view-classes that are in a 1:Many relationship with VIEW" | |
144 | (mapcar #'car | |
145 | (remove-if #'(lambda (x) (getf (cdr x) :target-slot)) | |
146 | (list-relations-helper | |
147 | view | |
148 | #'primary-key-p :return-full t)))) | |
149 | ||
150 | (defmethod list-many-to-many ((view t)) | |
151 | "returns a list of view-classes that are in a Many:Many relationship with VIEW" | |
152 | (mapcar #'car (list-relations-helper | |
153 | view | |
154 | #'(lambda (c a) | |
155 | (declare (ignore c))a) | |
156 | :test-key :target-slot | |
157 | :return-full t))) | |
158 | ||
159 | (defmethod explode-foreign-key ((model clsql:standard-db-object) slot) | |
160 | "returns the clsql view-class joined on SLOT" | |
161 | (dolist (s (list-join-attributes model)) | |
162 | (when (equal (getf (cdr s) :home-key) slot) | |
4eabb213 | 163 | (let ((val (slot-value model (car s)))) |
164 | (return-from explode-foreign-key | |
233380f7 | 165 | (values (if val val (make-instance (getf (cdr s) :join-class))) |
166 | (getf (cdr s) :foreign-key))))))) | |
579597e3 | 167 | |
168 | (defun find-join-helper (foreign-key) | |
169 | (lambda (class slot) | |
170 | (declare (ignore class)) | |
171 | (when (equal slot foreign-key) t))) | |
172 | ||
173 | (defmethod find-join-class ((view t) foreign-key) | |
174 | "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY" | |
175 | (car (list-relations-helper view (find-join-helper foreign-key) ))) | |
176 | ||
177 | (defmethod find-join-key ((view t) foreign-key) | |
178 | "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY" | |
179 | (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key))) | |
180 | ||
a6644385 | 181 | (defmethod explode-has-many ((view t) join-slot) |
182 | "returns the class of the join as the primary value, the second and third value is the home key and the foreign key" | |
183 | (let ((att (assoc join-slot (list-join-attributes view)))) | |
184 | (values (getf (cdr att) :join-class) | |
185 | (getf (cdr att) :home-key) | |
186 | (getf (cdr att) :foreign-key)))) | |
187 | ||
9d6c69fb DC |
188 | (defgeneric expr-= (instance slot-name value) |
189 | (:documentation "Create search expression for appropriate backend.")) | |
a6644385 | 190 | |
9d6c69fb DC |
191 | (defgeneric expr-> (instance slot-name value) |
192 | (:documentation "Create search expression for appropriate backend.")) | |
579597e3 | 193 | |
9d6c69fb DC |
194 | (defgeneric expr-< (instance slot-name value) |
195 | (:documentation "Create search expression for appropriate backend.")) | |
579597e3 | 196 | |
9d6c69fb DC |
197 | (defgeneric expr-ends-with (instance slot-name value) |
198 | (:documentation "Create search expression for appropriate backend.")) | |
199 | ||
200 | (defgeneric expr-starts-with (instance slot-name value) | |
201 | (:documentation "Create search expression for appropriate backend.")) | |
202 | ||
203 | (defgeneric expr-contains (instance slot-name value) | |
204 | (:documentation "Create search expression for appropriate backend.")) | |
205 | ||
206 | (defgeneric expr-and (instance &rest args) | |
207 | (:documentation "Create search expression for appropriate backend.")) | |
208 | ||
209 | (defgeneric expr-or (instance &rest args) | |
210 | (:documentation "Create search expression for appropriate backend.")) | |
211 | ||
212 | (defgeneric expr-not (instance &rest args) | |
213 | (:documentation "Create search expression for appropriate backend.")) | |
214 | ||
215 | (defgeneric select-instances (instance &rest args) | |
216 | (:documentation "Select instances in backend dependent way")) | |
217 | ||
f1ce8b6e DC |
218 | (defgeneric prepare-slot-name-for-select (instance slot-name) |
219 | (:method (i s) s)) | |
220 | ||
9d6c69fb DC |
221 | (defmacro def-compare-expr (instance-type name expr &key value-format) |
222 | `(defmethod ,name ((instance ,instance-type) slot-name value) | |
223 | (declare (ignore instance)) | |
f1ce8b6e | 224 | (,expr (prepare-slot-name-for-select instance slot-name) ,(typecase value-format |
9d6c69fb DC |
225 | (null 'value) |
226 | (string `(format nil ,value-format value)) | |
227 | (t `(,value-format value)))))) | |
228 | ||
f1ce8b6e | 229 | |
9d6c69fb DC |
230 | (defmacro def-logical-expr (instance-type name expr) |
231 | `(defmethod ,name ((instance ,instance-type) &rest args) | |
232 | (declare (ignore instance)) | |
233 | (apply ,expr args))) |