removed the index count from list-presentations
[clinton/lisp-on-lines.git] / src / backend / clsql.lisp
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
11 (defparameter *clsql-base-classes* (list) )
12
13 (defmethod list-base-classes ((type (eql :clsql)))
14 *clsql-base-classes*)
15
16 (defmethod def-base-class-expander ((model meta-model-class) (base-type (eql :clsql)) (name t) (args t))
17 `(def-view-class ,name ()
18 ,(meta-model.metadata model)))
19
20 (defmethod def-base-class-expander :after ((model meta-model-class) (base-type (eql :clsql)) (name t) (args t))
21 (unless (member name *clsql-base-classes*)
22 (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
23
24 (defparameter *sql-type-map* '((:INT4 integer) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
25
26 (defun gen-type (table column)
27 (cadr (assoc
28 (cadr (assoc
29 column
30 (list-attribute-types table)
31 :test #'equalp ))
32 *sql-type-map*)))
33
34 (defun sql->sym (name &optional (package nil))
35 (flet ((xform (x)
36 (string-upcase (substitute #\- #\_ x))))
37 (if package
38 (intern (xform (string name)) package)
39 (intern (xform (string name))))))
40
41 (defun table->slots (table pkey)
42 (mapcar
43 #'(lambda (col)
44 `(,(sql->sym col)
45 :accessor ,(sql->sym col)
46 :initarg ,(sql->sym col "KEYWORD")
47 :type ,(gen-type table col)
48 :db-kind
49 ,(if (equalp col pkey)
50 `:key
51 `:base)))
52 (list-attributes table)))
53
54 (defun view-class-definition-list ()
55 (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
56 (list-tables)))
57
58 (defmacro def-meta-models ()
59 (let ((defs (view-class-definition-list)))
60 `(progn ,@defs)))
61
62
63
64
65
66 (defun get-pkeys ()
67 (let ((keys '()))
68 (dolist (row (get-pkeys-query))
69 (setf keys (acons (car row) (list (cadr row)) keys)))
70 keys))
71
72 (defun get-pkeys-query()
73 (query
74 "SELECT pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
75 , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
76 , CASE
77 WHEN contype = 'p' THEN
78 'PRIMARY KEY'
79 ELSE
80 'UNIQUE'
81 END as constraint_type
82 FROM
83 pg_class, pg_attribute,
84 pg_catalog.pg_constraint AS c
85 JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
86 WHERE contype IN ('p', 'u')
87 AND deptype = 'i'
88 and conrelid = pg_class.oid
89 and pg_attribute.attnum = ANY (c.conkey)
90 and pg_attribute.attrelid = pg_class.oid"))
91
92 ;;here is how this works
93 ;;from the postgres system tables we get
94 ;;list of all the has-a relationships.
95 ;;the inverse of a has-a is an implicit has-many
96 ;;and any relation having more than one foreign key
97 ;;is a join table hosting a many-to-many relationship
98
99 (defun get-fkey-explosions ()
100 (let ((key-table (get-fkey-explosions-query))
101 (keys '()))
102 (dolist (row key-table)
103 (setf row (mapcar #'(lambda (x)
104 (sql->sym x))
105 row))
106 ;;this one does the has-a
107 (setf keys (acons (car row) (gen-has-a row)
108 keys))
109 ;;the inverse of the previous represents a has-many.
110 (setf keys
111 (acons (fourth row) (gen-has-many row)
112 keys))
113
114 ;;many-to-many
115 (dolist (mrow
116 (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
117 (equal (last row) (last r))))
118 (mapcar #'(lambda (x)
119 (mapcar #'sql->sym x))
120 key-table)))
121 (setf keys (acons (fourth row)
122 (gen-many-to-many mrow (third row) (second row))
123 keys))))
124 keys ))
125
126
127 (defun get-fkey-explosions-query ()
128 ;;these query's are a mess, i don't even know how they work :)
129 (query "
130 SELECT pg_class.relname,
131 pg_attribute.attname,
132 fa.attname ,
133 f.relname
134 FROM pg_class,
135 pg_constraint,
136 pg_attribute,
137 pg_class as f ,
138 pg_attribute as fa
139 WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
140 AND pg_class.oid = pg_constraint.conrelid
141 AND pg_attribute.attnum = ANY (pg_constraint.conkey)
142 AND pg_attribute.attrelid = pg_class.oid
143 AND f.oid = confrelid
144 AND fa.attrelid = f.oid
145 AND fa.attnum = ANY (pg_constraint.confkey)"))
146
147
148 ;; i chose keyword args here so as to make the code more understandable.
149 ;; it didn't really work.
150 (defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
151 `(,(intern name)
152 :accessor ,(intern name)
153 :db-kind :join
154 :db-info (:join-class ,join-class
155 :home-key ,home-key
156 :foreign-key ,foreign-key
157 :set ,set)))
158
159 (defun gen-has-a (row)
160 (gen-join-slot
161 :name
162 (format nil "~A->~A" (string (car row))(string (second row)))
163 :home-key (second row)
164 :foreign-key (third row)
165 :join-class (fourth row)))
166
167 (defun gen-has-many (row)
168 (gen-join-slot
169 :name
170 (format nil "~A->~A" (string (car row))(string (second row)))
171 :home-key (third row)
172 :foreign-key (second row)
173 :join-class (car row)
174 :set t))
175
176 (defun gen-many-to-many (row home-key foreign-key)
177 (let ((name (sql->sym (string-upcase (format nil "~A->~A" (string (car row)) (string (second row)))))))
178 (setf row (mapcar #'sql->sym row))
179 `(,name
180 :accessor ,name
181 :db-kind :join
182 :db-info (:join-class ,(car row)
183 :home-key ,home-key
184 :foreign-key ,foreign-key
185 :target-slot ,name
186 :set t))))
187
188 (defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
189 (declare (ignorable database))
190 (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
191 (get-def (slot) (caar (query
192 (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)))))
193 (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
194
195 (dolist (slot (list-slots view))
196 (when (and (primary-key-p view slot)
197 (or (not (slot-boundp view slot))
198 (equal (slot-value view slot) nil)))
199 (setf (slot-value view slot) (get-default-value slot))))))
200
201 ;;;;
202
203 (defmacro def-view-class/meta (name supers slots &rest args)
204 `(progn
205 (let* ((m (def-meta-model model-name ,supers ,slots ,args))
206 (i (make-instance m)))
207 (prog1 (eval (def-base-class-expander i :clsql ',name ',args))
208 (defmethod meta-model.metadata ((self ,name))
209 (meta-model.metadata i))))))
210
211
212 (defmacro def-view-class/table (table &optional name)
213 "takes the name of a table as a string and
214 creates a clsql view-class"
215 (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp)))
216 (table-slots (table->slots table pkey))
217 (join-slots
218 (let ((slots nil))
219 (dolist (exp (get-fkey-explosions))
220 (when (equalp (car exp) (sql->sym table))
221 (setf slots (cons (cdr exp) slots))))
222 slots)))
223 `(def-view-class/meta ,(if name name (sql->sym table))
224 ()
225 ,(append table-slots join-slots))))
226
227
228