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 (cl-postgres:exec-query
*database
* (sql-compile query
) 'symbol-plist-row-reader
))
25 (defun select (&rest query
)
26 (%query
(cons :select query
)))
28 (defun select-only (num &rest query
)
29 (let ((results (%query
`(:limit
,(cons :select query
) ,num
))))
34 (defun insert-into (table &rest values-plist
)
36 (postmodern:sql-compile
`(:insert-into
,table
:set
,@values-plist
))))
39 (defclass db-access-slot-definition
()
40 ((column-name :initform nil
43 :accessor slot-definition-column-name
45 "If non-NIL, contains the name of the column this slot is representing.")
46 (primary-key :initform nil
48 :accessor slot-definition-primary-key-p
)
49 (transient :initform nil
:initarg
:transient
:accessor slot-definition-transient-p
51 "If non-NIL, this slot should be treated as transient and
52 ignored in all database related operations.")
53 (not-null :initform nil
:initarg
:not-null
:accessor slot-definition-not-null-p
54 :documentation
"If non-NIL, a NON NULL database
55 constrained will be introduced.")
58 :initarg
:foreign-type
60 :accessor slot-definition-foreign-type
)
61 (unique :initform nil
:initarg
:unique
:accessor slot-definition-unique
)
64 (on-delete :initform
:cascade
:initarg
:on-delete
:accessor slot-definition-on-delete
65 :documentation
"Action to be performed for this slot
66 when the refering row in the database ceases to exist. Possible
67 values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
68 not a foreign key, it does nothing.")
69 (delayed-constraint :initform nil
:accessor slot-definition-delayed-constraint
70 :documentation
"Closures adding constraints
71 that, for some reason, could not be executed. If there's a slot with
72 this attribute not-NIL in a class definition, then there's something
73 wrong with its SQL counterpart.")))
76 (defclass db-access-class
(standard-class)
77 ((table-name :initarg
:table-name
:initform nil
:accessor class-table-name
)
78 (indices :initarg
:indices
:initform
() :reader class-indices
)
79 (unique :initarg
:unique
:initform
() :reader class-unique
)
80 #+not
!(connection-spec :initarg
:connection-spec
:initform nil
:reader db-class-connection-spec
)
82 (unfinished-classes :initform nil
:allocation
:class
:accessor class-unfinished-classes
83 :documentation
"A class allocated slot
84 containing classes for whom not all the constraints could be
86 (foreign-keys :initform nil
:accessor class-foreign-keys
87 :documentation
"List of foreign-key slots.")
88 (unique-keys :initform nil
:accessor class-unique-keys
89 :documentation
"List of slots whose value should be unique."))
90 (:documentation
"Metaclass for PostgreSQL aware classes. It takes
91 two additional arguments in DEFTABLE: :INDICES (which slots are used
92 as indices) and :CONNECTION-SPEC, which specifies how the class should
93 connect to the database (its format is the same as in
94 POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
95 SUBMARINE assumes it is a class created just for the sake of
96 inheritance and does not create any tables for it."))
98 (defmethod validate-superclass
99 ((class db-access-class
)
100 (superclass standard-class
))
104 (defclass db-access-direct-slot-definition
(standard-direct-slot-definition
105 db-access-slot-definition
)
108 (defmethod direct-slot-definition-class
109 ((class db-access-class
) &key
&allow-other-keys
)
110 (find-class 'db-access-direct-slot-definition
))
112 (defclass db-access-effective-slot-definition
113 (standard-effective-slot-definition
114 db-access-slot-definition
)
117 (defmethod effective-slot-definition-class
118 ((class db-access-class
) &key
&allow-other-keys
)
119 (find-class 'db-access-effective-slot-definition
))
121 (defmethod compute-effective-slot-definition
122 ((class db-access-class
) name direct-slot-definitions
)
123 (declare (ignore name
))
124 (let ((slotd (call-next-method)))
125 (setf (slot-definition-primary-key-p slotd
)
126 (some #'slot-definition-primary-key-p direct-slot-definitions
)
127 (slot-definition-column-name slotd
)
128 (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions
)))
130 (slot-definition-column-name slot
)))
132 (slot-definition-transient-p slotd
)
133 (every #'slot-definition-transient-p direct-slot-definitions
)
134 (slot-definition-foreign-type slotd
)
135 (slot-definition-foreign-type (car direct-slot-definitions
))
136 (slot-definition-not-null-p slotd
)
137 (slot-definition-not-null-p (car direct-slot-definitions
))
138 (slot-definition-unique slotd
) (slot-definition-unique (car direct-slot-definitions
))
139 (slot-definition-type slotd
) (slot-definition-type (car direct-slot-definitions
)))
142 (defun class-id-slot-definition (class)
143 (find-if #'slot-definition-primary-key-p
144 (class-slots class
)))
146 (defmethod class-table-name :around
(class)
147 (or (call-next-method)
150 (defclass standard-db-access-class
(db-access-class)
153 (defmethod ensure-class-using-class :around
((class standard-db-access-class
) name
&rest args
&key direct-slots
&allow-other-keys
)
154 (let ((direct-slots (loop for slot in direct-slots
155 collect
(let* ((sname (getf slot
:name
))
156 (readers (getf slot
:readers
))
157 (writers (getf slot
:writers
)))
158 (setf (getf slot
:readers
)
159 (cons (intern (format nil
"~A.~A"
160 name sname
)) readers
))
161 (setf (getf slot
:writers
)
162 (cons `(setf ,(intern (format nil
"~A.~A"
163 name sname
))) writers
))
167 (apply #'call-next-method class name
:direct-slots direct-slots args
)))
169 (defun dao-id-column-name (class)
170 (slot-definition-column-name
171 (or (class-id-slot-definition class
)
172 (error "No ID slot (primary key) for ~A" class
))))
174 (defclass described-db-access-class
(standard-db-access-class described-class
)
177 (defmethod initialize-instance :around
((class standard-db-access-class
) &rest initargs
&key
(direct-superclasses '()))
178 (declare (dynamic-extent initargs
))
179 (if (loop for direct-superclass in direct-superclasses
180 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
)))
182 (apply #'call-next-method
185 (append direct-superclasses
186 (list (find-class 'standard-db-access-object
)))
189 (defmethod reinitialize-instance :around
((class standard-db-access-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
190 (declare (dynamic-extent initargs
))
191 (if (or (not direct-superclasses-p
)
192 (loop for direct-superclass in direct-superclasses
193 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
))))
195 (apply #'call-next-method
198 (append direct-superclasses
199 (list (find-class 'standard-db-access-object
)))
202 (defclass standard-db-access-object
(standard-object)
205 (defun %select-objects
(type select-fn query
)
206 (mapcar (curry 'make-object-from-plist type
)
207 (apply select-fn
(intern (format nil
"*"))
208 (if (string-equal (first query
) :from
)
210 (append `(:from
,type
) query
)))))
212 (defun select-objects (type &rest query
)
213 (%select-objects type
#'select query
))
215 (defun select-only-n-objects (n type
&rest query
)
216 (let ((fields (if (eq :fields
(car query
))
218 :for cons
:on
(cdr query
)
219 :if
(not (keywordp (car cons
)))
220 :collect
(car cons
) into fields
223 (return (nreverse (print fields
)))
226 (return (nreverse (print fields
))))
228 (list (intern "*")))))
231 (print `(:limit
(:select
233 ,@(if (string-equal (first query
) :from
)
235 (append `(:from
,type
) query
)))
238 (make-object-from-plist type
(first results
))
239 (mapcar (curry 'make-object-from-plist type
) results
)))))
241 (defun make-object-from-plist (type plist
)
242 (let* ((class (find-class type
))
243 (object (make-instance class
))
244 (slotds (class-slots class
)))
247 :for
(key val
) :on plist
:by
#'cddr
249 (dolist (slotd (remove key slotds
250 :key
#'slot-definition-column-name
251 :test-not
#'string-equal
))
253 (setf (slot-value-using-class class object slotd
) val
))
254 :finally
(return (reinitialize-instance object
)))))
256 (defun make-object (type &rest plist
)
257 (make-object-from-plist type plist
))
261 (defun find-dao (type id
262 &key
(table (class-table-name (find-class type
)))
265 "Get the dao corresponding to the given primary key,
266 or return nil if it does not exist."
270 :where
(list ':= id
(or id-column-name
272 (find-class type
)))))))
273 (make-object-from-plist type plist
)))
275 (defmethod shared-initialize :after
((dao standard-db-access-object
)
276 slots
&rest initargs
)
277 (let ((class (class-of dao
))
279 (dolist (slotd (class-slots class
))
280 (with-slots (foreign-type) slotd
282 (when (consp foreign-type
)
283 (setf foreign-key
(cdr foreign-type
)
284 foreign-type
(car foreign-type
)))
285 (if (slot-boundp-using-class class dao slotd
)
286 (let ((value (slot-value-using-class class dao slotd
)))
287 (unless (typep value foreign-type
)
288 (if (connected-p *database
*)
289 (setf (slot-value-using-class class dao slotd
)
290 (find-dao foreign-type value
))
291 (let ((obj (make-instance foreign-type
)))
292 (setf (slot-value-using-class
295 (class-id-slot-definition (class-of obj
)))
298 (defgeneric dao-id
(dao)
299 (:method
((dao standard-db-access-object
))
300 (let ((class (class-of dao
)))
302 (slot-value-using-class class dao
(class-id-slot-definition class
)))))
304 (defun make-dao-from-row (type row
&key slots
)
305 (let* ((class (find-class type
))
306 (dao (make-instance class
))
307 (slotds (class-slots class
)))
314 :collect
(find slot slotds
315 :key
#'slot-definition-name
))
317 :do
(setf (slot-value-using-class class dao slotd
) val
)
318 :finally
(return (reinitialize-instance dao
)))))
320 ;(defgeneric make-dao (type &rest initargs)
321 #+nil
(defun make-dao (type initargs
)
322 "Create a DAO of the given `TYPE' and initialize it according
323 to the values of the alist `INITARGS'. `Initargs' may contain
324 additional values, not used in the initialization proccess."
325 (let ((instance (make-instance type
)))
326 (iter (for slot in
(slots-of instance
))
327 (setf (slot-value instance
(slot-definition-name slot
))
328 (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot
)) 'keyword
) initargs
))))
329 (if (foreign-type-p slot
)
330 (make-instance (sb-pcl:slot-definition-type slot
) :id the-value
)