docstring for view-class-metadata
[clinton/lisp-on-lines.git] / src / backend / clsql.lisp
CommitLineData
579597e3 1(in-package :meta-model)
2
3(eval-when (:compile-toplevel :load-toplevel :execute)
4 (use-package :clsql))
5
6(export 'def-meta-model-from-table)
7(export 'def-meta-models)
8(export 'def-view-class/meta)
9(export 'list-base-classes)
10
47a72814 11
12
9d6c69fb 13(defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only nil) (database *default-database*))
47a72814 14 (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
15 (get-def (slot) (caar (query
16 (format nil "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
a6644385 17 (get-default-value (slot)
18 (let ((def (get-def slot)))
19 (if def
9d6c69fb 20 (caar (query (format nil "SELECT ~A" def)))))))
47a72814 21
22 (dolist (slot (list-slots view))
23 (when (and (primary-key-p view slot)
24 (or (not (slot-boundp view slot))
25 (equal (slot-value view slot) nil)))
9d6c69fb
DC
26 (setf (slot-value view slot) (get-default-value slot))
27 (when (and (primary-key-p view slot)
28 (not (slot-value view slot))
29 (not fill-gaps-only))
30 (error "No default value for primary key : ~A" slot))))
31 (when fill-gaps-only
32 (update-objects-joins (list view))
33 (return-from sync-instance))
34 (update-records-from-instance view :database database)
35 (update-instance-from-records view :database database)
36 (update-objects-joins (list view))))
47a72814 37
38
39
579597e3 40(defparameter *clsql-base-classes* (list) )
41
42(defmethod list-base-classes ((type (eql :clsql)))
43 *clsql-base-classes*)
44
9d6c69fb 45(defmethod def-base-type-class-expander ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
579597e3 46 `(def-view-class ,name ()
47 ,(meta-model.metadata model)))
48
9d6c69fb 49(defmethod def-base-type-class-expander :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
579597e3 50 (unless (member name *clsql-base-classes*)
51 (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
52
53(defparameter *sql-type-map* '((:INT4 integer) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
54
55(defun gen-type (table column)
56 (cadr (assoc
57 (cadr (assoc
58 column
59 (list-attribute-types table)
60 :test #'equalp ))
61 *sql-type-map*)))
62
63(defun sql->sym (name &optional (package nil))
64 (flet ((xform (x)
65 (string-upcase (substitute #\- #\_ x))))
66 (if package
67 (intern (xform (string name)) package)
68 (intern (xform (string name))))))
69
9d6c69fb 70(defun table->slots (table pkey &optional (accesor-prefix table) (prefix-all-p nil))
579597e3 71 (mapcar
72 #'(lambda (col)
9d6c69fb
DC
73 (flet ((accessor-name (col)
74 (let ((name (sql->sym col)))
75 (if (or prefix-all-p
76 (and (fboundp name)
77 (eq (type-of (symbol-function name)) 'function)))
78 (sql->sym (concatenate 'string
79 (string accesor-prefix) "-" col))
80 name))))
81
82 `(,(sql->sym col)
83 :accessor ,(accessor-name col)
84 :initarg ,(sql->sym col "KEYWORD")
85 :type ,(gen-type table col)
86 :db-kind
87 ,(if (equalp col pkey)
88 `:key
89 `:base))))
579597e3 90 (list-attributes table)))
91
92(defun view-class-definition-list ()
93 (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
94 (list-tables)))
95
96(defmacro def-meta-models ()
97 (let ((defs (view-class-definition-list)))
98 `(progn ,@defs)))
99
100
579597e3 101(defun get-pkeys ()
102 (let ((keys '()))
103 (dolist (row (get-pkeys-query))
104 (setf keys (acons (car row) (list (cadr row)) keys)))
105 keys))
106
107(defun get-pkeys-query()
108 (query
109 "SELECT pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
110 , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
111 , CASE
112 WHEN contype = 'p' THEN
113 'PRIMARY KEY'
114 ELSE
115 'UNIQUE'
116 END as constraint_type
117 FROM
118 pg_class, pg_attribute,
119 pg_catalog.pg_constraint AS c
120 JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
121 WHERE contype IN ('p', 'u')
122 AND deptype = 'i'
123 and conrelid = pg_class.oid
124 and pg_attribute.attnum = ANY (c.conkey)
125 and pg_attribute.attrelid = pg_class.oid"))
126
127;;here is how this works
128;;from the postgres system tables we get
129;;list of all the has-a relationships.
130;;the inverse of a has-a is an implicit has-many
131;;and any relation having more than one foreign key
132;;is a join table hosting a many-to-many relationship
133
134(defun get-fkey-explosions ()
135 (let ((key-table (get-fkey-explosions-query))
136 (keys '()))
137 (dolist (row key-table)
138 (setf row (mapcar #'(lambda (x)
139 (sql->sym x))
140 row))
141 ;;this one does the has-a
142 (setf keys (acons (car row) (gen-has-a row)
143 keys))
144 ;;the inverse of the previous represents a has-many.
145 (setf keys
146 (acons (fourth row) (gen-has-many row)
147 keys))
148
149 ;;many-to-many
150 (dolist (mrow
151 (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
152 (equal (last row) (last r))))
153 (mapcar #'(lambda (x)
154 (mapcar #'sql->sym x))
155 key-table)))
156 (setf keys (acons (fourth row)
157 (gen-many-to-many mrow (third row) (second row))
158 keys))))
159 keys ))
160
161
162(defun get-fkey-explosions-query ()
163;;these query's are a mess, i don't even know how they work :)
164 (query "
165SELECT pg_class.relname,
166 pg_attribute.attname,
167 fa.attname ,
168 f.relname
169FROM pg_class,
170 pg_constraint,
171 pg_attribute,
172 pg_class as f ,
173 pg_attribute as fa
174WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
175AND pg_class.oid = pg_constraint.conrelid
176AND pg_attribute.attnum = ANY (pg_constraint.conkey)
177AND pg_attribute.attrelid = pg_class.oid
178AND f.oid = confrelid
179AND fa.attrelid = f.oid
180AND fa.attnum = ANY (pg_constraint.confkey)"))
181
182
183;; i chose keyword args here so as to make the code more understandable.
184;; it didn't really work.
185(defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
186 `(,(intern name)
187 :accessor ,(intern name)
188 :db-kind :join
189 :db-info (:join-class ,join-class
190 :home-key ,home-key
191 :foreign-key ,foreign-key
192 :set ,set)))
193
194(defun gen-has-a (row)
195 (gen-join-slot
196 :name
197 (format nil "~A->~A" (string (car row))(string (second row)))
198 :home-key (second row)
199 :foreign-key (third row)
200 :join-class (fourth row)))
201
202(defun gen-has-many (row)
203 (gen-join-slot
204 :name
205 (format nil "~A->~A" (string (car row))(string (second row)))
206 :home-key (third row)
207 :foreign-key (second row)
208 :join-class (car row)
209 :set t))
210
211(defun gen-many-to-many (row home-key foreign-key)
212 (let ((name (sql->sym (string-upcase (format nil "~A->~A" (string (car row)) (string (second row)))))))
213 (setf row (mapcar #'sql->sym row))
214 `(,name
215 :accessor ,name
216 :db-kind :join
217 :db-info (:join-class ,(car row)
218 :home-key ,home-key
219 :foreign-key ,foreign-key
220 :target-slot ,name
221 :set t))))
222
9d6c69fb
DC
223(defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
224 (declare (ignorable database))
225 (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
226 (get-def (slot) (caar (query
227 (format nil "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
228 (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
229
230 (dolist (slot (list-slots view))
231 (when (and (primary-key-p view slot)
232 (or (not (slot-boundp view slot))
233 (equal (slot-value view slot) nil)))
234 (setf (slot-value view slot) (get-default-value slot))))))
235
236;;;;
237
238(defmacro def-view-class/meta (name supers slots &rest args)
239 "Create and instrument CLSQL view-class NAME and
4628b433
DC
240appropriate meta-model class its default name is %NAME-meta-model."
241
9d6c69fb 242 (let ((model-name (cond ((eq :model-name (car args))
4628b433
DC
243 (pop args) ; remove keyword
244 (pop args)) ; get value
9d6c69fb 245 (t (intern (format nil "%~S-META-MODEL" name))))))
4628b433 246
579597e3 247 `(progn
4628b433
DC
248 (let* ((m (def-meta-model ,model-name ,supers ,slots ,args))
249 (i (make-instance m)))
250 (setf (meta-model.base-type i) :clsql)
251 (prog1 (eval (def-base-class-expander i ',name ',args))
252 (defmethod meta-model.metadata ((self ,name))
253 (meta-model.metadata i)))))))
9d6c69fb
DC
254
255(defmacro def-view-class/table (table &optional (name (sql->sym table)) model-name)
579597e3 256 "takes the name of a table as a string and
257creates a clsql view-class"
258 (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp)))
9d6c69fb 259 (table-slots (table->slots table pkey name))
579597e3 260 (join-slots
261 (let ((slots nil))
262 (dolist (exp (get-fkey-explosions))
263 (when (equalp (car exp) (sql->sym table))
264 (setf slots (cons (cdr exp) slots))))
265 slots)))
1da9fd46
DC
266 `(eval-when (:compile-toplevel :load-toplevel :execute)
267 (def-view-class/meta ,name
268 ()
269 ,(append table-slots join-slots)
270 ,@(when model-name (list :model-name model-name))))))
9d6c69fb
DC
271
272(def-compare-expr standard-db-object expr-= sql-=)
273(def-compare-expr standard-db-object expr-< sql-<)
274(def-compare-expr standard-db-object expr-> sql->)
275(def-compare-expr standard-db-object expr-ends-with sql-like :value-format "%~A")
276(def-compare-expr standard-db-object expr-starts-with sql-like :value-format "~A%")
277(def-compare-expr standard-db-object expr-contains sql-like :value-format "%~A%")
278
279(def-logical-expr standard-db-object expr-and #'sql-and)
579597e3 280
9d6c69fb 281(def-logical-expr standard-db-object expr-or #'sql-or)
579597e3 282
9d6c69fb 283(def-logical-expr standard-db-object expr-not #'sql-not)
579597e3 284
9d6c69fb
DC
285(defmethod select-instances ((instance standard-db-object) &rest query)
286 (unless (keywordp (car query))
287 (setf query (cons :where query)))
288 (apply #'select (class-name (class-of instance)) :flatp t query))