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 |
19 | :initform 'clsql))) |
20 | |
21 | (defmethod meta-model.metadata ((self (eql nil))) |
22 | nil) |
23 | |
24 | (defun gen-supers (supers) |
25 | (let (subclassp) |
26 | (dolist (x supers) |
27 | (when (member x (list-meta-models)) |
28 | (setf subclassp t))) |
29 | (if subclassp |
30 | supers |
31 | (cons 'meta-model-class supers)))) |
32 | |
33 | (defmethod %def-meta-model ((base-type t) name supers slots &rest options) |
34 | `(defclass ,name ,(gen-supers supers) |
35 | () |
36 | (:default-initargs :metadata ',slots))) |
37 | |
38 | |
39 | (defmacro def-meta-model (name supers slots &rest options) |
40 | `(progn |
41 | (when (not (member (quote ,name) *meta-models*)) |
42 | (setf *meta-models* (cons (quote ,name) *meta-models*))) |
43 | |
44 | (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options))) |
45 | class))) |
46 | |
47 | (defgeneric def-base-class-expander (model base-type name args)) |
48 | |
49 | |
50 | (defmacro def-base-class (name (model) &rest args) |
51 | (let ((i (make-instance model))) |
52 | `(progn |
53 | ,(def-base-class-expander i :clsql name args) |
54 | (defmethod meta-model.metadata ((m ,name)) |
55 | ',(meta-model.metadata i))))) |
56 | |
57 | |
58 | (defmethod base-class-name ((model t)) |
59 | (class-name (class-of (meta-model.instance model)))) |
60 | |
61 | |
62 | |
63 | (defmethod view-class-metadata ((model t)) |
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 |
165 | (values (if val val (make-instance (getf (cdr s) :join-class))) (getf (cdr s) :foreign-key))))))) |
579597e3 |
166 | |
167 | (defun find-join-helper (foreign-key) |
168 | (lambda (class slot) |
169 | (declare (ignore class)) |
170 | (when (equal slot foreign-key) t))) |
171 | |
172 | (defmethod find-join-class ((view t) foreign-key) |
173 | "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY" |
174 | (car (list-relations-helper view (find-join-helper foreign-key) ))) |
175 | |
176 | (defmethod find-join-key ((view t) foreign-key) |
177 | "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY" |
178 | (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key))) |
179 | |
180 | |
181 | |