Coverage report: /home/ati/workspace/perec/persistence/slot-value.lisp

KindCoveredAll%
expression212373 56.8
branch4456 78.6
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :cl-perec)
2
 
3
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
 ;;; Caching slot values in objects
5
 
6
 (defparameter *cache-slot-values* #t
7
   "True means slot values will be cached in the slots of the persistent objects. Writing a slot still goes directly to the database but it will be also stored in the object. If the object's state is modified in the database it is up to the modifier to clear the list of cached slots from the object using the invalidate functions. The purpose of the slot value cache is to increases performance and reduce the number of database interactions during a transaction.")
8
 
9
 (defparameter *bypass-database-access* #f
10
   "True means slot-value-using-class and friends will bypass database access and directly use the underlying CLOS object as a cache. It can be used for reading, writing, making unbound and checking boundness of slots.")
11
 
12
 (defparameter *propagate-cache-changes* #t
13
   "True means setting the slot of an object in the cache will propagate changes to other objects in the cache according to the association end slot integrity rules.")
14
 
15
 (defgeneric invalidate-all-cached-slots (object)
16
   (:documentation "Invalidates all cached slot values in the object.")
17
 
18
   (:method ((object persistent-object))
19
            (setf (cached-slots-of object) nil)
20
            (bind ((class (class-of object)))
21
              (iter (for slot in (persistent-effective-slots-of class))
22
                    (cached-slot-makunbound-using-class class object slot)))))
23
 
24
 (defgeneric invalidate-cached-slot (object slot)
25
   (:documentation "Invalidates the given cached slot value in the object.")
26
 
27
   (:method ((object persistent-object) (slot-name symbol))
28
            (invalidate-cached-slot object (find-slot (class-of object) slot-name)))
29
 
30
   (:method ((object persistent-object) (slot persistent-effective-slot-definition))
31
            (cached-slot-makunbound-using-class (class-of object) object slot)
32
            (delete! slot (cached-slots-of object))))
33
 
34
 (defgeneric propagate-cache-changes (class object slot new-value)
35
   (:documentation "Partially invalidate or update the cache to reflect setting the slot of object to new-value.")
36
 
37
   (:method ((class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition) new-value)
38
            (debug-only (assert (debug-persistent-p object)))
39
            (values)))
40
 
41
 (defgeneric slot-value-cached-p (object slot)
42
   (:documentation "Specifies whether the given slot is cached in the object or not.")
43
   
44
   (:method ((object persistent-object) (slot persistent-effective-slot-definition))
45
            (debug-only (assert (debug-persistent-p object)))
46
            (member slot (cached-slots-of object))))
47
 
48
 (defun cached-slot-value (object slot-name)
49
   "Similar to slot-value but never interacts with the database."
50
   (debug-only (assert (debug-persistent-p object)))
51
   (with-bypassing-database-access
52
     (slot-value object slot-name)))
53
 
54
 (defun (setf cached-slot-value) (new-value object slot-name)
55
   "Similar to (setf slot-value) but never interacts with the database."
56
   (debug-only (assert (debug-persistent-p object)))
57
   (with-bypassing-database-access
58
     (setf (slot-value object slot-name) new-value)))
59
 
60
 (defun cached-slot-boundp-or-value (object slot-name)
61
   "Similar to slot-value-boundp-or-value but never interacts with the database."
62
   (debug-only (assert (debug-persistent-p object)))
63
   (bind ((class (class-of object)))
64
     (cached-slot-boundp-or-value-using-class class object (find-slot class slot-name))))
65
 
66
 (defun (setf cached-slot-boundp-or-value) (new-value object slot-name)
67
   "Similar to (setf slot-value-boundp-or-value) but never interacts with the database."
68
   (debug-only (assert (debug-persistent-p object)))
69
   (bind ((class (class-of object)))
70
     (setf (cached-slot-boundp-or-value-using-class class object (find-slot class slot-name))
71
           new-value)))
72
 
73
 (defgeneric cached-slot-value-using-class (class object slot)
74
   (:documentation "Returns the cached value of the object's slot similar to slot-value-using-class but never interacts with the database.")
75
 
76
   (:method ((class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition))
77
            (debug-only (assert (debug-persistent-p object)))
78
            (with-bypassing-database-access
79
              (slot-value-using-class class object slot))))
80
 
81
 (defgeneric (setf cached-slot-value-using-class) (new-value class object slot)
82
   (:documentation "Sets the cached value of the object's slot similar to (setf slot-value-using-class) but never interacts with the database.")
83
 
84
   (:method (new-value (class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition))
85
            (debug-only (assert (debug-persistent-p object)))
86
            (with-bypassing-database-access
87
              (setf (slot-value-using-class class object slot) new-value))))
88
 
89
 (defgeneric cached-slot-makunbound-using-class (class object slot)
90
   (:documentation "Makes the cached object's slot unbound similar to slot-makunbound-using-class but never interacts with the database.")
91
 
92
   (:method ((class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition))
93
            (debug-only (assert (debug-persistent-p object)))
94
            (with-bypassing-database-access
95
              (slot-makunbound-using-class class object slot))))
96
 
97
 (defgeneric cached-slot-boundp-using-class (class object slot)
98
   (:documentation "Returns the cached boundness of the object's slot similar to slot-boundp-using-class but never interacts with the database.")
99
 
100
   (:method ((class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition))
101
            (debug-only (assert (debug-persistent-p object)))
102
            (with-bypassing-database-access
103
              (slot-boundp-using-class class object slot))))
104
 
105
 (defgeneric cached-slot-boundp-or-value-using-class (class object slot)
106
   (:documentation "Either returns the cached slot value or the unbound slot marker. This method does not interact with the database.")
107
 
108
   (:method ((class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition))
109
            (with-bypassing-database-access
110
              (if (not (slot-boundp-using-class class object slot))
111
                  +unbound-slot-value+
112
                  (slot-value-using-class class object slot)))))
113
 
114
 (defgeneric (setf cached-slot-boundp-or-value-using-class) (new-value class object slot)
115
   (:documentation "Either sets the slot value to the given new value or makes the slot unbound if the new value is the unbound marker. This method does not interact with the database.")
116
 
117
   (:method (new-value (class persistent-class) (object persistent-object) (slot persistent-effective-slot-definition))
118
            (debug-only (assert (debug-persistent-p object)))
119
            (with-bypassing-database-access
120
              (if (eq +unbound-slot-value+ new-value)
121
                  (slot-makunbound-using-class class object slot)
122
                  (setf (slot-value-using-class class object slot) new-value)))))
123
 
124
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125
 ;;; CLOS MOP slot-value-using-class and friends
126
 
127
 (defmethod slot-value-using-class ((class persistent-class)
128
                                    (object persistent-object)
129
                                    (slot standard-effective-slot-definition))
130
   "Prefetches persistent slot values when determining whether the object is persistent or not."
131
   (debug-only
132
     (assert (eq class (class-of object)))
133
     (assert (eq class (slot-definition-class slot))))
134
   ;; check for the persistent flag slot
135
   (if (and (not *bypass-database-access*)
136
            (eq (slot-definition-name slot) 'persistent)
137
            (not (slot-boundp-using-class class object slot)))
138
       ;; prefetch if possible otherwise simple existence check
139
       (if (prefetched-slots-of class)
140
           (bind (((values restored-slot-values restored-slots) (restore-prefetched-slots object #t)))
141
             ;; the persistent flag must be stored prior to caching any slot value
142
             (prog1 (setf (slot-value-using-class class object slot) (not (null restored-slots)))
143
               ;; cache prefetched slots
144
               (iter (for restored-slot-value in restored-slot-values)
145
                     (for restored-slot in restored-slots)
146
                     (when (and *cache-slot-values*
147
                                (cache-p restored-slot))
148
                       (setf (cached-slot-boundp-or-value-using-class class object restored-slot) restored-slot-value)))))
149
           ;; simple existence test
150
           (setf (slot-value-using-class class object slot) (object-exists-in-database-p object)))
151
       (call-next-method)))
152
 
153
 (defun slot-boundp-or-value-using-class (class object slot call-next-method return-with)
154
   (debug-only
155
     (assert (eq class (class-of object)))
156
     (assert (eq class (slot-definition-class slot))))
157
   (bind ((persistent (persistent-p object)))
158
     (assert (or *bypass-database-access*
159
                 (not persistent)
160
                 (instance-in-current-transaction-p object)))
161
     (if (or (not persistent)
162
             *bypass-database-access*
163
             (and *cache-slot-values*
164
                  (slot-value-cached-p object slot)))
165
         ;; read the slot value from the cache
166
         (funcall call-next-method)
167
         ;; restore the slot value from the database and put it in the underlying slot when appropriate
168
         (if (and *cache-slot-values*
169
                  (prefetch-p slot))
170
             ;; restore all prefetched slot values at once
171
             (bind (((values restored-slot-values restored-slots) (restore-prefetched-slots object))
172
                    (slot-value))
173
               (iter (for restored-slot-value in restored-slot-values)
174
                     (for restored-slot in restored-slots)
175
                     (when (eq slot restored-slot)
176
                       (setf slot-value restored-slot-value))
177
                     (when (cache-p restored-slot)
178
                       (setf (cached-slot-boundp-or-value-using-class class object restored-slot) restored-slot-value)))
179
               (funcall return-with  slot-value))
180
             ;; only restore the requested slot value
181
             (bind (((values restored-slot-value restored-slot) (restore-slot object slot)))
182
               (when (and *cache-slot-values*
183
                          (cache-p restored-slot))
184
                 (setf (cached-slot-boundp-or-value-using-class class object restored-slot) restored-slot-value))
185
               (funcall return-with restored-slot-value))))))
186
 
187
 (defun (setf slot-boundp-or-value-using-class) (new-value class object slot call-next-method)
188
   (debug-only
189
     (assert (eq class (class-of object)))
190
     (assert (eq class (slot-definition-class slot))))
191
   (bind ((persistent (persistent-p object)))
192
     (assert (or *bypass-database-access*
193
                 (not persistent)
194
                 (instance-in-current-transaction-p object)))
195
     ;; store slot value in the database
196
     (when (and (not *bypass-database-access*)
197
                persistent)
198
       (store-slot object slot new-value)
199
       (unless (modified-p object)
200
         (setf (modified-p object) #t)
201
         (insert-item (current-modified-objects) object)))
202
     ;; update slot value cache if appropriate
203
     (when (and persistent
204
                *propagate-cache-changes*)
205
       (bind ((*propagate-cache-changes* #f))
206
         (propagate-cache-changes class object slot new-value)))
207
     (when (and *cache-slot-values*
208
                (cache-p slot)
209
                persistent)
210
       (pushnew slot (cached-slots-of object)))
211
     ;; store slot value in the underlying slot if appropriate
212
     (when (or (not persistent)
213
               (and *cache-slot-values*
214
                    (cache-p slot))
215
               *bypass-database-access*)
216
       (funcall call-next-method))
217
     new-value))
218
 
219
 (defmethod slot-value-using-class ((class persistent-class)
220
                                    (object persistent-object)
221
                                    (slot persistent-effective-slot-definition))
222
   "Reads the slot value from the database or the cache."
223
   (slot-boundp-or-value-using-class class object slot #'call-next-method #'identity))
224
 
225
 (defmethod (setf slot-value-using-class) (new-value
226
                                           (class persistent-class)
227
                                           (object persistent-object)
228
                                           (slot persistent-effective-slot-definition))
229
   "Writes the new slot value to the database and the cache."
230
   (setf (slot-boundp-or-value-using-class class object slot #'call-next-method) new-value))
231
 
232
 (defmethod slot-boundp-using-class ((class persistent-class)
233
                                     (object persistent-object)
234
                                     (slot persistent-effective-slot-definition))
235
   "Reads boundness from the database or the cache."
236
   (slot-boundp-or-value-using-class class object slot #'call-next-method #L(not (eq +unbound-slot-value+ !1))))
237
 
238
 (defmethod slot-makunbound-using-class ((class persistent-class)
239
                                         (object persistent-object)
240
                                         (slot persistent-effective-slot-definition))
241
   "Writes boundness to the database and the cache."
242
   (setf (slot-boundp-or-value-using-class class object slot #'call-next-method) +unbound-slot-value+)
243
   object)
244
 
245
 (defmethod update-instance-for-different-class :after ((previous-object persistent-object)
246
                                                        (current-object persistent-object)
247
                                                        &rest initargs &key &allow-other-keys)
248
   (declare (ignore initargs))
249
   ;; TODO: update foreign key references according to class name
250
   (bind ((previous-class (class-of previous-object))
251
          (current-class (class-of current-object))
252
          (at-current-object (id-column-matcher-where-clause current-object)))
253
     (setf (class-name-of current-object) (name-of current-class))
254
     (dolist (table (data-tables-of current-class))
255
       (if (member table (data-tables-of previous-class))
256
           (update-records (name-of table)
257
                           (list (class-name-column-of table))
258
                           (list (class-name-value current-object))
259
                           at-current-object)
260
           ;; TODO: handle initargs
261
           (insert-records (name-of table)
262
                           (oid-columns-of table)
263
                           (oid-values current-object))))
264
     (dolist (table (data-tables-of previous-class))
265
       (unless (member table (data-tables-of current-class))
266
         (delete-records (name-of table)
267
                         at-current-object)))))
268
 
269
 ;;;;;;;;;;;;;;;;;;;;;
270
 ;;; Slime integration
271
 
272
 #+#.(cl:when (cl:find-package "SWANK") '(:and))
273
 (progn
274
   (defmethod swank::inspect-slot-for-emacs ((class persistent-class)
275
                                             (object persistent-object)
276
                                             (slot persistent-effective-slot-definition))
277
     (if (debug-persistent-p object)
278
         `(,@(if (slot-value-cached-p object slot)
279
                 `("Cached, value is " (:value ,(standard-instance-access object (slot-definition-location slot)))
280
                   " "
281
                   (:action "[invalidate cache]" ,(lambda () (invalidate-cached-slot object slot))))
282
                 `("Not cached"
283
                   " "
284
                   (:action "[read in]" ,(lambda () (slot-value-using-class class object slot)))))
285
           " "
286
           (:action "[make unbound]" ,(lambda () (slot-makunbound-using-class class object slot))))
287
         (call-next-method)))
288
 
289
   (defmethod swank::inspect-for-emacs ((object persistent-object) inspector)
290
     (bind ((result (call-next-method))
291
            (content (getf result :content)))
292
       (setf (getf result :content)
293
             (append `("Transaction: " (:value ,(when (instance-in-transaction-p object) (transaction-of object))) (:newline))
294
                     content))
295
       (setf (getf result :title)
296
             (if (debug-persistent-p object) "A persistent object" "A transient object"))
297
       result)))