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