1 (in-package :lisp-on-lines
)
4 (defclass db-access-slot-definition
()
5 ((column-name :initform nil
:initarg
:db-name
:accessor slot-definition-column-name
7 "If non-NIL, contains the name of the column this slot is representing.")
8 (primary-key :initform nil
10 :accessor slot-definition-primary-key-p
)
11 (transient :initform nil
:initarg
:transient
:accessor slot-definition-transient-p
13 "If non-NIL, this slot should be treated as transient and
14 ignored in all database related operations.")
15 (not-null :initform nil
:initarg
:not-null
:accessor slot-definition-not-null-p
16 :documentation
"If non-NIL, a NON NULL database
17 constrained will be introduced.")
20 :initarg
:foreign-type
22 :accessor slot-definition-foreign-type
)
23 (unique :initform nil
:initarg
:unique
:accessor slot-definition-unique
)
26 (on-delete :initform
:cascade
:initarg
:on-delete
:accessor slot-definition-on-delete
27 :documentation
"Action to be performed for this slot
28 when the refering row in the database ceases to exist. Possible
29 values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
30 not a foreign key, it does nothing.")
31 (delayed-constraint :initform nil
:accessor slot-definition-delayed-constraint
32 :documentation
"Closures adding constraints
33 that, for some reason, could not be executed. If there's a slot with
34 this attribute not-NIL in a class definition, then there's something
35 wrong with its SQL counterpart.")))
37 (defmethod slot-definition-column-name :around
(slotd)
38 (or (call-next-method) (slot-definition-name slotd
)))
41 (defclass db-access-class
(standard-class)
42 ((table-name :initarg
:table-name
:initform nil
:accessor class-table-name
)
43 (indices :initarg
:indices
:initform
() :reader class-indices
)
44 (unique :initarg
:unique
:initform
() :reader class-unique
)
45 #+not
!(connection-spec :initarg
:connection-spec
:initform nil
:reader db-class-connection-spec
)
47 (unfinished-classes :initform nil
:allocation
:class
:accessor class-unfinished-classes
48 :documentation
"A class allocated slot
49 containing classes for whom not all the constraints could be
51 (foreign-keys :initform nil
:accessor class-foreign-keys
52 :documentation
"List of foreign-key slots.")
53 (unique-keys :initform nil
:accessor class-unique-keys
54 :documentation
"List of slots whose value should be unique."))
55 (:documentation
"Metaclass for PostgreSQL aware classes. It takes
56 two additional arguments in DEFTABLE: :INDICES (which slots are used
57 as indices) and :CONNECTION-SPEC, which specifies how the class should
58 connect to the database (its format is the same as in
59 POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
60 SUBMARINE assumes it is a class created just for the sake of
61 inheritance and does not create any tables for it."))
63 (defmethod validate-superclass
64 ((class db-access-class
)
65 (superclass standard-class
))
69 (defclass db-access-direct-slot-definition
(standard-direct-slot-definition
70 db-access-slot-definition
)
73 (defmethod direct-slot-definition-class
74 ((class db-access-class
) &key
&allow-other-keys
)
75 (find-class 'db-access-direct-slot-definition
))
77 (defclass db-access-effective-slot-definition
78 (standard-effective-slot-definition
79 db-access-slot-definition
)
82 (defmethod effective-slot-definition-class
83 ((class db-access-class
) &key
&allow-other-keys
)
84 (find-class 'db-access-effective-slot-definition
))
86 (defmethod compute-effective-slot-definition
87 ((class db-access-class
) name direct-slot-definitions
)
88 (declare (ignore name
))
89 (let ((slotd (call-next-method)))
90 (setf (slot-definition-primary-key-p slotd
)
91 (some #'slot-definition-primary-key-p direct-slot-definitions
)
92 (slot-definition-transient-p slotd
)
93 (every #'slot-definition-transient-p direct-slot-definitions
)
94 (slot-definition-foreign-type slotd
)
95 (slot-definition-foreign-type (car direct-slot-definitions
))
96 (slot-definition-not-null-p slotd
)
97 (slot-definition-not-null-p (car direct-slot-definitions
))
98 (slot-definition-unique slotd
) (slot-definition-unique (car direct-slot-definitions
))
99 (slot-definition-type slotd
) (slot-definition-type (car direct-slot-definitions
)))
102 (defun class-id-slot-definition (class)
103 (find-if #'slot-definition-primary-key-p
104 (class-slots class
)))
106 (defmethod class-table-name :around
(class)
107 (or (call-next-method)
110 (defclass standard-db-access-class
(db-access-class)
113 (defun dao-id-column-name (class)
114 (slot-definition-column-name
115 (or (class-id-slot-definition class
)
116 (error "No ID slot (primary key) for ~A" class
))))
118 (defclass described-db-access-class
(standard-db-access-class described-class
)
121 (defmethod initialize-instance :around
((class standard-db-access-class
) &rest initargs
&key
(direct-superclasses '()))
122 (declare (dynamic-extent initargs
))
123 (if (loop for direct-superclass in direct-superclasses
124 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
)))
126 (apply #'call-next-method
129 (append direct-superclasses
130 (list (find-class 'standard-db-access-object
)))
133 (defmethod reinitialize-instance :around
((class standard-db-access-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
134 (declare (dynamic-extent initargs
))
135 (if (or (not direct-superclasses-p
)
136 (loop for direct-superclass in direct-superclasses
137 thereis
(ignore-errors (subtypep direct-superclass
'standard-db-access-object
))))
139 (apply #'call-next-method
142 (append direct-superclasses
143 (list (find-class 'standard-db-access-object
)))
146 (defclass standard-db-access-object
(standard-object)
151 (defun find-dao (type id
152 &key
(table (class-table-name (find-class type
)))
155 "Get the dao corresponding to the given primary key,
156 or return nil if it does not exist."
157 (let ((row (first (query
160 :where
(:= id
(or id-column-name
162 (find-class type
)))))))))
163 (make-dao-from-row type row
)))
165 (defmethod shared-initialize :after
((dao standard-db-access-object
)
166 slots
&rest initargs
)
167 (let ((class (class-of dao
)))
168 (dolist (slotd (class-slots class
))
169 (with-slots (foreign-type) slotd
171 (if (slot-boundp-using-class class dao slotd
)
172 (let ((value (slot-value-using-class class dao slotd
)))
173 (unless (typep value foreign-type
)
174 (if (connected-p *database
*)
175 (setf (slot-value-using-class class dao slotd
)
176 (find-dao foreign-type value
))
177 (let ((obj (make-instance foreign-type
)))
178 (setf (slot-value-using-class
181 (class-id-slot-definition (class-of obj
)))
184 (defgeneric dao-id
(dao)
185 (:method
((dao standard-db-access-object
))
186 (let ((class (class-of dao
)))
188 (slot-value-using-class class dao
(class-id-slot-definition class
)))))
190 (postmodern::def-row-reader symbol-plist-row-reader
(fields)
192 (let ((symbols (map 'list
(lambda (desc)
193 (postmodern::from-sql-name
(postmodern::field-name desc
))) fields
)))
194 (loop :while
(postmodern::next-row
)
195 :collect
(loop :for field
:across fields
196 :for symbol
:in symbols
197 :nconc
(list symbol
(postmodern::next-field field
))))))
200 (setf postmodern
::*result-styles
*
201 (nconc (list '(:plists symbol-plist-row-reader nil
)
202 '(:plist symbol-plist-row-reader t
))
203 postmodern
::*result-styles
*))
205 (defun select (&rest query
)
206 (query (sql-compile (cons :select query
)) :plists
))
208 (defun select-only (num &rest query
)
209 (query (sql-compile `(:limit
,(cons :select query
) ,num
))
212 (defun make-dao-from-row (type row
&key slots
)
213 (let* ((class (find-class type
))
214 (dao (make-instance class
))
215 (slotds (class-slots class
)))
222 :collect
(find slot slotds
223 :key
#'slot-definition-name
))
225 :do
(setf (slot-value-using-class class dao slotd
) val
)
226 :finally
(return (reinitialize-instance dao
)))))
228 ;(defgeneric make-dao (type &rest initargs)
229 #+nil
(defun make-dao (type initargs
)
230 "Create a DAO of the given `TYPE' and initialize it according
231 to the values of the alist `INITARGS'. `Initargs' may contain
232 additional values, not used in the initialization proccess."
233 (let ((instance (make-instance type
)))
234 (iter (for slot in
(slots-of instance
))
235 (setf (slot-value instance
(slot-definition-name slot
))
236 (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot
)) 'keyword
) initargs
))))
237 (if (foreign-type-p slot
)
238 (make-instance (sb-pcl:slot-definition-type slot
) :id the-value
)