1 (in-package :lisp-on-lines
)
3 ;;;; NB: These could really be in upstream
5 ;;;; * A PLIST reader for postmodern.
6 (postmodern::def-row-reader symbol-plist-row-reader
(fields)
7 (let ((symbols (map 'list
(lambda (desc)
8 (postmodern::from-sql-name
(postmodern::field-name desc
))) fields
)))
9 (loop :while
(postmodern::next-row
)
10 :collect
(loop :for field
:across fields
11 :for symbol
:in symbols
12 :nconc
(list symbol
(postmodern::next-field field
))))))
14 (s-sql::def-sql-op
:between
(n start end
)
15 `(,@(s-sql::sql-expand n
) " BETWEEN " ,@(s-sql::sql-expand start
) " AND " ,@(s-sql::sql-expand end
)))
17 (s-sql::def-sql-op
:case
(&rest clauses
)
18 `("CASE " ,@(loop for
(test expr
) in clauses collect
(format nil
"WHEN ~A THEN ~A " (s-sql::sql-expand test
) (s-sql::sql-expand expr
))) "END"))
21 ;;;; now the rofl code itself
23 (defvar *row-reader
* 'symbol-plist-row-reader
)
26 (cl-postgres:exec-query
*database
* (sql-compile query
) *row-reader
*))
28 (defun select (&rest query
)
29 (%query
(cons :select query
)))
31 (defun prepare (&rest query
)
32 (cl-postgres:prepare-query
*database
* "test2" (sql-compile (cons :select query
))))
35 (defun select-only (num &rest query
)
36 (let ((results (%query
`(:limit
,(cons :select query
) ,num
))))
41 (defun insert-into (table &rest values-plist
)
43 (postmodern:sql-compile
`(:insert-into
,table
:set
,@values-plist
))))
45 (defun update (table &rest query
)
47 (postmodern:sql-compile
`(:update
,table
,@query
))))
50 (defclass db-access-slot-definition
()
51 ((column-name :initform nil
54 :accessor slot-definition-column-name
56 "If non-NIL, contains the name of the column this slot is representing.")
57 (primary-key :initform nil
59 :accessor slot-definition-primary-key-p
)
60 (transient :initform nil
:initarg
:transient
:accessor slot-definition-transient-p
62 "If non-NIL, this slot should be treated as transient and
63 ignored in all database related operations.")
64 (not-null :initform nil
:initarg
:not-null
:accessor slot-definition-not-null-p
65 :documentation
"If non-NIL, a NON NULL database
66 constrained will be introduced.")
69 :initarg
:foreign-type
71 :accessor slot-definition-foreign-type
)
74 :initarg
:referenced-from
75 :initarg
:referenced-by
76 :accessor slot-definition-foreign-relation
)
81 :accessor slot-definition-foreign-join-spec
)
82 (unique :initform nil
:initarg
:unique
:accessor slot-definition-unique
)
85 (on-delete :initform
:cascade
:initarg
:on-delete
:accessor slot-definition-on-delete
86 :documentation
"Action to be performed for this slot
87 when the refering row in the database ceases to exist. Possible
88 values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
89 not a foreign key, it does nothing.")
90 (delayed-constraint :initform nil
:accessor slot-definition-delayed-constraint
91 :documentation
"Closures adding constraints
92 that, for some reason, could not be executed. If there's a slot with
93 this attribute not-NIL in a class definition, then there's something
94 wrong with its SQL counterpart.")))
97 (defclass db-access-class
(standard-class)
98 ((table-name :initarg
:table-name
:initform nil
:accessor class-table-name
)
99 (indices :initarg
:indices
:initform
() :reader class-indices
)
100 (unique :initarg
:unique
:initform
() :reader class-unique
)
101 #+not
!(connection-spec :initarg
:connection-spec
:initform nil
:reader db-class-connection-spec
)
103 (unfinished-classes :initform nil
:allocation
:class
:accessor class-unfinished-classes
104 :documentation
"A class allocated slot
105 containing classes for whom not all the constraints could be
107 (foreign-keys :initform nil
:accessor class-foreign-keys
108 :documentation
"List of foreign-key slots.")
109 (unique-keys :initform nil
:accessor class-unique-keys
110 :documentation
"List of slots whose value should be unique."))
111 (:documentation
"Metaclass for PostgreSQL aware classes. It takes
112 two additional arguments in DEFTABLE: :INDICES (which slots are used
113 as indices) and :CONNECTION-SPEC, which specifies how the class should
114 connect to the database (its format is the same as in
115 POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
116 SUBMARINE assumes it is a class created just for the sake of
117 inheritance and does not create any tables for it."))
119 (defmethod validate-superclass
120 ((class db-access-class
)
121 (superclass standard-class
))
125 (defclass db-access-direct-slot-definition
(standard-direct-slot-definition
126 db-access-slot-definition
)
129 (defmethod direct-slot-definition-class
130 ((class db-access-class
) &key
&allow-other-keys
)
131 (find-class 'db-access-direct-slot-definition
))
133 (defclass db-access-effective-slot-definition
134 (standard-effective-slot-definition
135 db-access-slot-definition
)
138 (defmethod effective-slot-definition-class
139 ((class db-access-class
) &key
&allow-other-keys
)
140 (find-class 'db-access-effective-slot-definition
))
142 (defmethod compute-effective-slot-definition
143 ((class db-access-class
) name direct-slot-definitions
)
144 (declare (ignore name
))
145 (let ((slotd (call-next-method)))
146 (setf (slot-definition-primary-key-p slotd
)
147 (some #'slot-definition-primary-key-p direct-slot-definitions
)
148 (slot-definition-column-name slotd
)
149 (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions
)))
151 (slot-definition-column-name slot
)))
153 (slot-definition-transient-p slotd
)
154 (every #'slot-definition-transient-p direct-slot-definitions
)
155 (slot-definition-foreign-type slotd
)
156 (slot-definition-foreign-type (car direct-slot-definitions
))
157 (slot-definition-foreign-relation slotd
)
158 (slot-definition-foreign-relation (car direct-slot-definitions
))
159 (slot-definition-foreign-join-spec slotd
)
160 (slot-definition-foreign-join-spec (car direct-slot-definitions
))
161 (slot-definition-not-null-p slotd
)
162 (slot-definition-not-null-p (car direct-slot-definitions
))
163 (slot-definition-unique slotd
) (slot-definition-unique (car direct-slot-definitions
))
164 (slot-definition-type slotd
) (slot-definition-type (car direct-slot-definitions
)))
167 (defun class-id-slot-definition (class)
168 (find-if #'slot-definition-primary-key-p
169 (class-slots class
)))
171 (defmethod class-table-name :around
(class)
172 (or (call-next-method)
175 (defclass standard-db-access-class
(db-access-class)
178 (defun find-foreign-relations (class object slotd
)
179 (when (slot-boundp object
(dao-id-column-name class
))
180 (select-objects (slot-definition-foreign-relation slotd
)
181 :where
`(:= ,(or (slot-definition-foreign-join-spec slotd
)
182 (dao-id-column-name class
))
183 ,(slot-value object
(dao-id-column-name class
))))))
185 (defmethod slot-boundp-using-class :around
186 ((class standard-db-access-class
) object slotd
)
187 (let ((bound?
(call-next-method)))
188 (when (and (not bound?
) (slot-definition-foreign-relation slotd
))
189 (setf (slot-value-using-class class object slotd
)
190 (find-foreign-relations class object slotd
)))
194 (defmethod slot-value-using-class :around
195 ((class standard-db-access-class
) object slotd
)
196 (if (slot-definition-foreign-relation slotd
)
197 (if (slot-boundp-using-class class object slotd
)
199 (setf (slot-value-using-class class object slotd
)
200 (find-foreign-relations class object slotd
)))
203 (defun set-fkey-from-slotd (value object slotd
)
204 (when (slot-boundp value
(dao-id-column-name (class-of value
)))
205 (setf (slot-value object
(slot-definition-column-name slotd
))
206 (slot-value value
(dao-id-column-name (class-of value
))))))
208 (defmethod (setf slot-value-using-class
) :after
209 (value (class standard-db-access-class
) object slotd
)
211 (typep value
'standard-db-access-object
)
212 (slot-definition-foreign-type slotd
)
213 (primary-key-boundp value
))
215 (set-fkey-from-slotd value object slotd
)))
217 (defun find-foreign-objects (db-object)
218 (let* ((class (class-of db-object
))
221 (and (slot-value-using-class class db-object x
)
222 (slot-value-using-class class db-object x
)))
223 (remove-if-not #'lol
::slot-definition-foreign-type
224 (lol::class-slots class
)))))
227 (defun dao-id-column-name (class)
228 (slot-definition-column-name
229 (or (class-id-slot-definition class
)
230 (error "No ID slot (primary key) for ~A" class
))))
232 (defun db-access-object-p (thing)
233 (typep thing
'standard-db-access-object
))
235 (defun primary-key-boundp (object)
236 (check-type object standard-db-access-object
)
237 (slot-boundp object
(dao-id-column-name (class-of object
))))
239 (defclass described-db-access-class
(described-class standard-db-access-class
)
242 (defmethod initialize-instance :around
((class standard-db-access-class
) &rest initargs
&key name
(direct-superclasses '()) direct-slots
)
243 (declare (dynamic-extent initargs
))
244 (let ((direct-slots (loop for slot in direct-slots
245 collect
(let* ((sname (getf slot
:name
))
246 (readers (getf slot
:readers
))
247 (writers (getf slot
:writers
)))
248 (setf (getf slot
:readers
)
249 (cons (intern (format nil
"~A.~A"
250 name sname
)) readers
))
251 (setf (getf slot
:writers
)
252 (cons `(setf ,(intern (format nil
"~A.~A"
253 name sname
))) writers
))
258 (if (loop for direct-superclass in direct-superclasses
259 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
)))
261 (apply #'call-next-method
264 (append direct-superclasses
265 (list (find-class 'standard-db-access-object
)))
266 :direct-slots direct-slots
269 (defmethod reinitialize-instance :around
((class standard-db-access-class
)
271 &key
(name (class-name class
))
272 (direct-superclasses '() direct-superclasses-p
) direct-slots
)
273 (declare (dynamic-extent initargs
))
274 (let ((direct-slots (loop for slot in direct-slots
275 collect
(let* ((sname (getf slot
:name
))
276 (readers (getf slot
:readers
))
277 (writers (getf slot
:writers
)))
278 (setf (getf slot
:readers
)
279 (cons (intern (format nil
"~A.~A"
280 name sname
)) readers
))
281 (setf (getf slot
:writers
)
282 (cons `(setf ,(intern (format nil
"~A.~A"
283 name sname
))) writers
))
288 (if (loop for direct-superclass in direct-superclasses
289 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
)))
291 (apply #'call-next-method
294 (append direct-superclasses
295 (list (find-class 'standard-db-access-object
)))
296 :direct-slots direct-slots
299 (defclass standard-db-access-object
(standard-object)
302 (defun %select-objects
(type select-fn query
)
303 (mapcar (curry 'make-object-from-plist type
)
304 (apply select-fn
(intern (format nil
"*"))
305 (if (string-equal (first query
) :from
)
307 (append `(:from
,type
) query
)))))
309 (defun select-objects (type &rest query
)
310 (%select-objects type
#'select query
))
312 (defun select-only-n-objects (n type
&rest query
)
313 (let ((fields (if (eq :fields
(car query
))
315 :for cons
:on
(cdr query
)
316 :if
(not (keywordp (car cons
)))
317 :collect
(car cons
) into fields
320 (return (nreverse (print fields
)))
323 (return (nreverse (print fields
))))
325 (list (intern "*")))))
328 (print `(:limit
(:select
330 ,@(if (string-equal (first query
) :from
)
332 (append `(:from
,type
) query
)))
335 (make-object-from-plist type
(first results
))
336 (mapcar (curry 'make-object-from-plist type
) results
)))))
338 (defun make-object-from-plist (type plist
)
339 (let* ((class (find-class type
))
340 (object (make-instance class
))
341 (slotds (class-slots class
)))
344 :for
(key val
) :on plist
:by
#'cddr
346 (dolist (slotd (remove key slotds
347 :key
#'slot-definition-column-name
348 :test-not
#'string-equal
))
350 (setf (slot-value-using-class class object slotd
) val
))
351 :finally
(return (reinitialize-instance object
)))))
353 (defun make-object (type &rest plist
)
354 (make-object-from-plist type plist
))
356 (defun insert-object (object)
357 (let ((class (class-of object
))
360 (flet ((ins (slotd &optional
(val (slot-value-using-class class object slotd
)))
361 (push (lambda () (push (slot-definition-column-name slotd
) insert-query
)
362 (push val insert-query
))
364 (loop :for slotd in
(class-slots class
)
365 :do
(cond ((slot-boundp-using-class class object slotd
)
366 (cond ((or (slot-definition-foreign-relation slotd
)
369 ((slot-definition-foreign-type slotd
)
371 (slot-value-using-class class object slotd
)
377 ((slot-definition-primary-key-p slotd
)
378 (setf (slot-value-using-class class object slotd
) (get-default-value (class-table-name class
)
379 (slot-definition-column-name slotd
)))
381 (map nil
#'funcall delayed
)
382 (apply #'insert-into
(class-table-name class
) (nreverse insert-query
))))
386 (defun update-object (object)
387 (let ((class (class-of object
))
390 (flet ((ins (slotd &optional
(val (slot-value-using-class class object slotd
)))
391 (push (lambda () (push (slot-definition-column-name slotd
) update-query
)
392 (push val update-query
))
394 (loop :for slotd in
(class-slots class
)
395 :do
(cond ((slot-boundp-using-class class object slotd
)
396 (cond ((or (slot-definition-foreign-relation slotd
)
399 ((slot-definition-foreign-type slotd
)
401 (slot-value-using-class class object slotd
)
407 ((slot-definition-primary-key-p slotd
)
408 (setf (slot-value-using-class class object slotd
) (get-default-value (class-table-name class
)
409 (slot-definition-column-name slotd
)))
411 (map nil
#'funcall delayed
)
412 (apply #'update
(class-table-name class
) :set
(nconc (nreverse update-query
)
413 (list :where
`(:= ,(dao-id-column-name class
)
414 ,(slot-value object
(dao-id-column-name class
))
418 (defun select-using-object (object &key
(combinator :and
))
419 (let ((class (class-of object
))
421 (flet ((sel (slotd &optional
(val (slot-value-using-class class object slotd
)))
422 (push `(:ilike
,(slot-definition-column-name slotd
) ,(if (stringp val
)
423 (format nil
"~A%" val
) val
)) select-query
)))
424 (loop :for slotd in
(class-slots class
)
425 :do
(cond ((slot-boundp-using-class class object slotd
)
426 (unless (or (slot-definition-foreign-relation slotd
)
427 (slot-definition-foreign-type slotd
))
430 (select-objects (class-table-name class
)
431 :where
(print `(,combinator
,@(nreverse select-query
))))
435 (defun get-default-value-query (table column
)
436 (format nil
"select ~A "
437 (second (select-only 1 ':adsrc
438 :from
'pg_attribute
'pg_attrdef
439 :where
`(:and
(:= adnum attnum
)
440 (:= attname
,(s-sql::to-sql-name column
))
441 (:= adrelid attrelid
)
445 :where
(:= relname
,(s-sql::to-sql-name table
)))))))))
447 (defun get-default-value (table column
)
448 (caar (query (get-default-value-query table column
))))
450 (defun find-dao (type id
451 &key
(table (class-table-name (find-class type
)))
454 "Get the dao corresponding to the given primary key,
455 or return nil if it does not exist."
459 :where
(list ':= id
(or id-column-name
461 (find-class type
)))))))
462 (make-object-from-plist type plist
)))
464 (defmethod shared-initialize :after
((dao standard-db-access-object
)
465 slots
&rest initargs
)
466 (let ((class (class-of dao
))
468 (dolist (slotd (class-slots class
))
469 (with-slots (foreign-type) slotd
471 (when (consp foreign-type
)
472 (setf foreign-key
(cdr foreign-type
)
473 foreign-type
(car foreign-type
)))
474 (if (slot-boundp-using-class class dao slotd
)
475 (let ((value (slot-value-using-class class dao slotd
))) (unless (typep value foreign-type
)
476 (if (connected-p *database
*)
477 (setf (slot-value-using-class class dao slotd
)
478 (find-dao foreign-type value
))
479 (let ((obj (make-instance foreign-type
)))
481 (setf (slot-value-using-class
484 (class-id-slot-definition (class-of obj
)))
487 (defgeneric dao-id
(dao)
488 (:method
((dao standard-db-access-object
))
489 (let ((class (class-of dao
)))
491 (slot-value-using-class class dao
(class-id-slot-definition class
)))))
493 (defun make-dao-from-row (type row
&key slots
)
494 (let* ((class (find-class type
))
495 (dao (make-instance class
))
496 (slotds (class-slots class
)))
503 :collect
(find slot slotds
504 :key
#'slot-definition-name
))
506 :do
(setf (slot-value-using-class class dao slotd
) val
)
507 :finally
(return (reinitialize-instance dao
)))))
509 ;(defgeneric make-dao (type &rest initargs)
510 #+nil
(defun make-dao (type initargs
)
511 "Create a DAO of the given `TYPE' and initialize it according
512 to the values of the alist `INITARGS'. `Initargs' may contain
513 additional values, not used in the initialization proccess."
514 (let ((instance (make-instance type
)))
515 (iter (for slot in
(slots-of instance
))
516 (setf (slot-value instance
(slot-definition-name slot
))
517 (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot
)) 'keyword
) initargs
))))
518 (if (foreign-type-p slot
)
519 (make-instance (sb-pcl:slot-definition-type slot
) :id the-value
)