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
) 'symbol-plist-row-reader
))
28 (defun select (&rest query
)
29 (%query
(cons :select query
)))
31 (defun select-only (num &rest query
)
32 (let ((results (%query
`(:limit
,(cons :select query
) ,num
))))
37 (defun insert-into (table &rest values-plist
)
39 (postmodern:sql-compile
`(:insert-into
,table
:set
,@values-plist
))))
42 (defclass db-access-slot-definition
()
43 ((column-name :initform nil
46 :accessor slot-definition-column-name
48 "If non-NIL, contains the name of the column this slot is representing.")
49 (primary-key :initform nil
51 :accessor slot-definition-primary-key-p
)
52 (transient :initform nil
:initarg
:transient
:accessor slot-definition-transient-p
54 "If non-NIL, this slot should be treated as transient and
55 ignored in all database related operations.")
56 (not-null :initform nil
:initarg
:not-null
:accessor slot-definition-not-null-p
57 :documentation
"If non-NIL, a NON NULL database
58 constrained will be introduced.")
61 :initarg
:foreign-type
63 :accessor slot-definition-foreign-type
)
64 (unique :initform nil
:initarg
:unique
:accessor slot-definition-unique
)
67 (on-delete :initform
:cascade
:initarg
:on-delete
:accessor slot-definition-on-delete
68 :documentation
"Action to be performed for this slot
69 when the refering row in the database ceases to exist. Possible
70 values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
71 not a foreign key, it does nothing.")
72 (delayed-constraint :initform nil
:accessor slot-definition-delayed-constraint
73 :documentation
"Closures adding constraints
74 that, for some reason, could not be executed. If there's a slot with
75 this attribute not-NIL in a class definition, then there's something
76 wrong with its SQL counterpart.")))
79 (defclass db-access-class
(standard-class)
80 ((table-name :initarg
:table-name
:initform nil
:accessor class-table-name
)
81 (indices :initarg
:indices
:initform
() :reader class-indices
)
82 (unique :initarg
:unique
:initform
() :reader class-unique
)
83 #+not
!(connection-spec :initarg
:connection-spec
:initform nil
:reader db-class-connection-spec
)
85 (unfinished-classes :initform nil
:allocation
:class
:accessor class-unfinished-classes
86 :documentation
"A class allocated slot
87 containing classes for whom not all the constraints could be
89 (foreign-keys :initform nil
:accessor class-foreign-keys
90 :documentation
"List of foreign-key slots.")
91 (unique-keys :initform nil
:accessor class-unique-keys
92 :documentation
"List of slots whose value should be unique."))
93 (:documentation
"Metaclass for PostgreSQL aware classes. It takes
94 two additional arguments in DEFTABLE: :INDICES (which slots are used
95 as indices) and :CONNECTION-SPEC, which specifies how the class should
96 connect to the database (its format is the same as in
97 POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
98 SUBMARINE assumes it is a class created just for the sake of
99 inheritance and does not create any tables for it."))
101 (defmethod validate-superclass
102 ((class db-access-class
)
103 (superclass standard-class
))
107 (defclass db-access-direct-slot-definition
(standard-direct-slot-definition
108 db-access-slot-definition
)
111 (defmethod direct-slot-definition-class
112 ((class db-access-class
) &key
&allow-other-keys
)
113 (find-class 'db-access-direct-slot-definition
))
115 (defclass db-access-effective-slot-definition
116 (standard-effective-slot-definition
117 db-access-slot-definition
)
120 (defmethod effective-slot-definition-class
121 ((class db-access-class
) &key
&allow-other-keys
)
122 (find-class 'db-access-effective-slot-definition
))
124 (defmethod compute-effective-slot-definition
125 ((class db-access-class
) name direct-slot-definitions
)
126 (declare (ignore name
))
127 (let ((slotd (call-next-method)))
128 (setf (slot-definition-primary-key-p slotd
)
129 (some #'slot-definition-primary-key-p direct-slot-definitions
)
130 (slot-definition-column-name slotd
)
131 (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions
)))
133 (slot-definition-column-name slot
)))
135 (slot-definition-transient-p slotd
)
136 (every #'slot-definition-transient-p direct-slot-definitions
)
137 (slot-definition-foreign-type slotd
)
138 (slot-definition-foreign-type (car direct-slot-definitions
))
139 (slot-definition-not-null-p slotd
)
140 (slot-definition-not-null-p (car direct-slot-definitions
))
141 (slot-definition-unique slotd
) (slot-definition-unique (car direct-slot-definitions
))
142 (slot-definition-type slotd
) (slot-definition-type (car direct-slot-definitions
)))
145 (defun class-id-slot-definition (class)
146 (find-if #'slot-definition-primary-key-p
147 (class-slots class
)))
149 (defmethod class-table-name :around
(class)
150 (or (call-next-method)
153 (defclass standard-db-access-class
(db-access-class)
156 (defmethod ensure-class-using-class :around
((class standard-db-access-class
) name
&rest args
&key direct-slots
&allow-other-keys
)
157 (let ((direct-slots (loop for slot in direct-slots
158 collect
(let* ((sname (getf slot
:name
))
159 (readers (getf slot
:readers
))
160 (writers (getf slot
:writers
)))
161 (setf (getf slot
:readers
)
162 (cons (intern (format nil
"~A.~A"
163 name sname
)) readers
))
164 (setf (getf slot
:writers
)
165 (cons `(setf ,(intern (format nil
"~A.~A"
166 name sname
))) writers
))
170 (apply #'call-next-method class name
:direct-slots direct-slots args
)))
172 (defun dao-id-column-name (class)
173 (slot-definition-column-name
174 (or (class-id-slot-definition class
)
175 (error "No ID slot (primary key) for ~A" class
))))
177 (defclass described-db-access-class
(standard-db-access-class described-class
)
180 (defmethod initialize-instance :around
((class standard-db-access-class
) &rest initargs
&key
(direct-superclasses '()))
181 (declare (dynamic-extent initargs
))
182 (if (loop for direct-superclass in direct-superclasses
183 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
)))
185 (apply #'call-next-method
188 (append direct-superclasses
189 (list (find-class 'standard-db-access-object
)))
192 (defmethod reinitialize-instance :around
((class standard-db-access-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
193 (declare (dynamic-extent initargs
))
194 (if (or (not direct-superclasses-p
)
195 (loop for direct-superclass in direct-superclasses
196 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
))))
198 (apply #'call-next-method
201 (append direct-superclasses
202 (list (find-class 'standard-db-access-object
)))
205 (defclass standard-db-access-object
(standard-object)
208 (defun %select-objects
(type select-fn query
)
209 (mapcar (curry 'make-object-from-plist type
)
210 (apply select-fn
(intern (format nil
"*"))
211 (if (string-equal (first query
) :from
)
213 (append `(:from
,type
) query
)))))
215 (defun select-objects (type &rest query
)
216 (%select-objects type
#'select query
))
218 (defun select-only-n-objects (n type
&rest query
)
219 (let ((fields (if (eq :fields
(car query
))
221 :for cons
:on
(cdr query
)
222 :if
(not (keywordp (car cons
)))
223 :collect
(car cons
) into fields
226 (return (nreverse (print fields
)))
229 (return (nreverse (print fields
))))
231 (list (intern "*")))))
234 (print `(:limit
(:select
236 ,@(if (string-equal (first query
) :from
)
238 (append `(:from
,type
) query
)))
241 (make-object-from-plist type
(first results
))
242 (mapcar (curry 'make-object-from-plist type
) results
)))))
244 (defun make-object-from-plist (type plist
)
245 (let* ((class (find-class type
))
246 (object (make-instance class
))
247 (slotds (class-slots class
)))
250 :for
(key val
) :on plist
:by
#'cddr
252 (dolist (slotd (remove key slotds
253 :key
#'slot-definition-column-name
254 :test-not
#'string-equal
))
256 (setf (slot-value-using-class class object slotd
) val
))
257 :finally
(return (reinitialize-instance object
)))))
259 (defun make-object (type &rest plist
)
260 (make-object-from-plist type plist
))
264 (defun find-dao (type id
265 &key
(table (class-table-name (find-class type
)))
268 "Get the dao corresponding to the given primary key,
269 or return nil if it does not exist."
273 :where
(list ':= id
(or id-column-name
275 (find-class type
)))))))
276 (make-object-from-plist type plist
)))
278 (defmethod shared-initialize :after
((dao standard-db-access-object
)
279 slots
&rest initargs
)
280 (let ((class (class-of dao
))
282 (dolist (slotd (class-slots class
))
283 (with-slots (foreign-type) slotd
285 (when (consp foreign-type
)
286 (setf foreign-key
(cdr foreign-type
)
287 foreign-type
(car foreign-type
)))
288 (if (slot-boundp-using-class class dao slotd
)
289 (let ((value (slot-value-using-class class dao slotd
)))
290 (unless (typep value foreign-type
)
291 (if (connected-p *database
*)
292 (setf (slot-value-using-class class dao slotd
)
293 (find-dao foreign-type value
))
294 (let ((obj (make-instance foreign-type
)))
295 (setf (slot-value-using-class
298 (class-id-slot-definition (class-of obj
)))
301 (defgeneric dao-id
(dao)
302 (:method
((dao standard-db-access-object
))
303 (let ((class (class-of dao
)))
305 (slot-value-using-class class dao
(class-id-slot-definition class
)))))
307 (defun make-dao-from-row (type row
&key slots
)
308 (let* ((class (find-class type
))
309 (dao (make-instance class
))
310 (slotds (class-slots class
)))
317 :collect
(find slot slotds
318 :key
#'slot-definition-name
))
320 :do
(setf (slot-value-using-class class dao slotd
) val
)
321 :finally
(return (reinitialize-instance dao
)))))
323 ;(defgeneric make-dao (type &rest initargs)
324 #+nil
(defun make-dao (type initargs
)
325 "Create a DAO of the given `TYPE' and initialize it according
326 to the values of the alist `INITARGS'. `Initargs' may contain
327 additional values, not used in the initialization proccess."
328 (let ((instance (make-instance type
)))
329 (iter (for slot in
(slots-of instance
))
330 (setf (slot-value instance
(slot-definition-name slot
))
331 (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot
)) 'keyword
) initargs
))))
332 (if (foreign-type-p slot
)
333 (make-instance (sb-pcl:slot-definition-type slot
) :id the-value
)