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