Coverage report: /home/ellis/comp/core/lib/obj/store.lisp

KindCoveredAll%
expression82070 0.4
branch0172 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; store.lisp --- Data Store Protocols
2
 
3
 ;; Support for Lisp Stores.
4
 
5
 ;;; Commentary:
6
 
7
 ;; Based on work from Elephant and XDB.
8
 
9
 ;; A STORE plays a similar role to ORMs in blub languages, but better since we
10
 ;; have CLOS and MOP for ultimate control. The purpose of a STORE is to
11
 ;; orchestrate the persistence of objects of a specific metaclass called
12
 ;; STORED. The metaclass adds an additional allocation target for slot-objects
13
 ;; which indicates that any access to them from Lisp will be delegated to the
14
 ;; associated STORE.
15
 
16
 ;; The STORE itself is defined in this file and implements the 'controller'
17
 ;; side of the underlying protocol.
18
 
19
 ;;; Code:
20
 (in-package :obj/store)
21
 
22
 (defparameter *store* obj/meta/stored::*default-store*)
23
 
24
 ;; support for swapping out multiple stores? compatibility matrix?
25
 (defvar *stores* nil)
26
 
27
 ;; TODO 2024-12-05: eradicate direct usage of BTrees. otherwise why do we need
28
 ;; RocksDB eh?
29
 (defun make-btree (&optional (st *store*))
30
   "Constructs a new BTree instance for use by the user.  Each backend
31
    returns its own internal type as appropriate and ensures that the 
32
    btree is associated with the store that created it."
33
   (build-btree st))
34
 
35
 (defun make-indexed-btree (&optional (sc *store*))
36
   "Constructs a new indexed BTree instance for use by the user.
37
    Each backend returns its own internal type as appropriate and
38
    ensures that the btree is associated with the store
39
    that created it."
40
   (build-indexed-btree sc))
41
 
42
 ;;; Dup Btrees
43
 (defclass dup-btree (btree) ())
44
 
45
 (defgeneric build-dup-btree (store)
46
   (:documentation 
47
    "Construct a btree of the appropriate type corresponding to this store."))
48
 
49
 (defun make-dup-btree (&optional (store *store*))
50
   (build-dup-btree store))
51
 
52
 ;;; Stored Set
53
 ;; default implementation of simple sets using btrees
54
 (defclass pset (stored-collection) ()
55
   (:documentation "An unordered stored collection of unique elements according to serializer
56
 equal comparison"))
57
 
58
 (defgeneric insert-item (item pset)
59
   (:documentation "Insert a new item into the pset"))
60
 
61
 (defgeneric remove-item (item pset)
62
   (:documentation "Remove specified item from pset"))
63
 
64
 (defgeneric map-pset (fn pset)
65
   (:documentation "Map operator for psets"))
66
 
67
 (defgeneric find-item (item pset &key key test)
68
   (:documentation "Find a an item in the pset using key and test"))
69
 
70
 (defgeneric pset-list (pset)
71
   (:documentation "Convert items of pset into a list for processing"))
72
 
73
 (defgeneric build-pset (sc)
74
   (:documentation "Construct an empty default pset or backend specific pset.
75
                    This is an internal function used by make-pset"))
76
 
77
 (defgeneric drop-pset (pset)
78
   (:documentation "Release pset storage to database for reuse"))
79
 
80
 (defsclass default-pset (pset)
81
   ((btree :accessor pset-btree :initarg :btree)))
82
 
83
 
84
 (defmethod drop-instance ((pset pset))
85
   (drop-pset pset)
86
   (call-next-method))
87
 
88
 ;;; Slot Access
89
 (defmethod slot-value-using-class ((class stored-class) (instance stored-object) (slot-def set-valued-slot-definition))
90
   "Ensure that there is a slot-set in the slot (lazy instantiation)"
91
   (handler-case
92
       (call-next-method)
93
     (unbound-slot ()
94
       (setf (slot-value-using-class class instance slot-def)
95
             (build-slot-set (get-store instance))))))
96
 
97
 (defmethod (setf slot-value-using-class) 
98
     (new-value (class stored-class) (instance stored-object) (slot-def set-valued-slot-definition))
99
   "Setting a value adds it to the slot set"
100
   (if (or (null new-value)
101
           (subtypep (type-of new-value) 'slot-set))
102
       (progn
103
         (slot-makunbound-using-class class instance slot-def)
104
         (call-next-method))
105
       (insert-item new-value (slot-value-using-class class instance slot-def))))
106
 
107
 (defmethod slot-makunbound-using-class ((class stored-class) (instance stored-object) (slot-def set-valued-slot-definition))
108
   "Make sure we reclaim the pset storage"
109
   (awhen (and (slot-boundp-using-class class instance slot-def)
110
               (slot-value-using-class class instance slot-def))
111
     (drop-slot-set it))
112
   (call-next-method))
113
 
114
 ;;  Slot set helpers
115
 (defmacro set-list (object slotname)
116
   "Sugar for getting a list from a set slot"
117
   `(slot-set-list (slot-value ,object ,slotname)))
118
 
119
 (defmacro set-insert (item object slotname)
120
   "Sugar for inserting items under #'equal from the set slot"
121
   `(insert-item ,item (slot-value ,object ,slotname)))
122
 
123
 (defmacro set-remove (item object slotname)
124
   "Sugar for removing items via #'equal from the set slot"
125
   `(remove-item ,item (slot-value ,object ,slotname)))
126
 
127
 ;;  A generic slot set implementation
128
 (defclass slot-set () ()
129
   (:documentation "A proxy object for a set stored in a slot."))
130
 
131
 (defsclass stored-slot-set (slot-set stored-pset) ()
132
   (:documentation "A default slot-set implementation"))
133
 
134
 (defgeneric build-slot-set (sc)
135
   (:documentation "Construct an empty default pset or backend specific pset.
136
                    This is an internal function used by make-pset"))
137
 
138
 (defgeneric slot-set-list (slot-set)
139
   (:documentation "Convert items of pset into a list for processing")
140
   (:method ((set stored-slot-set))
141
     (pset-list set)))
142
 
143
 (defgeneric map-slot-set (fn slot-set)
144
   (:documentation "Map operator for psets")
145
   (:method (fn (set stored-slot-set))
146
     (map-pset fn set)))
147
 
148
 (defgeneric drop-slot-set (pset)
149
   (:documentation "Release pset storage to database for reuse")
150
   (:method ((set stored-slot-set))
151
     (drop-instance set)))
152
 
153
 ;;; Associations
154
 (defmethod slot-value-using-class 
155
     ((class stored-class) (instance stored-object) (slot-def association-slot-definition))
156
   (if (eq (association-type slot-def) :ref)
157
       (call-next-method)
158
       (get-associated instance slot-def)))
159
 
160
 (defmethod (setf slot-value-using-class) 
161
     (new-value (class stored-class) (instance stored-object) (slot-def association-slot-definition))
162
   (add-association instance (slot-definition-name slot-def) new-value)
163
   new-value)
164
 
165
 (defmethod slot-boundp-using-class 
166
     ((class stored-class) (instance stored-object) (slot-def association-slot-definition))
167
   (when (eq (association-type slot-def) :ref)
168
     (call-next-method)))
169
 
170
 (defmethod slot-makunbound-using-class 
171
     ((class stored-class) (instance stored-object) (slot-def association-slot-definition))
172
   (when (eq (association-type slot-def) :ref)
173
     (remove-association-end class instance slot-def nil)
174
     (call-next-method))) ;; remove storage
175
 
176
 
177
 ;; =========================
178
 ;; Handling reads
179
 ;; =========================
180
 
181
 (defun type-check-association (instance slot-def other-instance)
182
   (when (null other-instance)
183
     (return-from type-check-association t))
184
   (unless (subtypep (type-of other-instance) (foreign-classname slot-def))
185
     (cerror "Ignore and return"
186
             "Value ~A written to association slot ~A of instance ~A 
187
              of class ~A must be a subtype of ~A"
188
             other-instance (foreign-slotname slot-def) instance
189
             (type-of instance) (foreign-classname slot-def))
190
     (return-from type-check-association nil))
191
   (unless (equal (spec instance) (spec other-instance))
192
     (cerror "Ignore and return"
193
             "Cannot association objects from different stores:
194
              ~A is in ~A and ~A is in ~A"
195
             instance (get-store instance)
196
             other-instance (get-store other-instance))
197
     (return-from type-check-association nil))
198
   t)
199
 
200
 (defun get-associated (instance slot-def)
201
   (let* ((fclass (get-foreign-class slot-def))
202
          (fslot (get-foreign-slot fclass slot-def))
203
          (sc (get-store instance))
204
          (index (get-association-index fslot sc)))
205
     (flet ((map-obj (value oid)
206
              (declare (ignore value))
207
              (store-recreate-instance sc oid)))
208
       (declare (dynamic-extent (function map-obj)))
209
       (map-btree #'map-obj index :value (oid instance) :collect t))))
210
 
211
 
212
 ;; ==========================
213
 ;;  Handling updates
214
 ;; ==========================
215
 
216
 (defun update-association-end (class instance slot-def target)
217
   "Get the association index and add the target object as a key that
218
    refers back to this instance so we can get the set of referrers to target"
219
   (let ((index (get-association-index slot-def (get-store instance))))
220
     (when (and (eq (association-type slot-def) :ref)
221
                (slot-boundp-using-class class instance slot-def))
222
       (remove-kv (oid (slot-value-using-class class instance slot-def)) (oid instance) index))
223
     (when (not (null instance))
224
       (setf (get-value (oid target) index) (oid instance)))))
225
 
226
 (defun remove-association-end (class instance slot-def associated)
227
   (let ((index (get-association-index slot-def (get-store instance))))
228
     (if (and (eq (association-type slot-def) :ref)
229
              (slot-boundp-using-class class instance slot-def))
230
         (remove-kv (oid (slot-value-using-class class instance slot-def)) (oid instance) index)
231
         (when associated ;it is possible that the original association
232
                          ;slot was not bound at the time of
233
                          ;deletion. thus, remove the entry only when
234
                          ;it is bound
235
           (remove-kv (oid associated) (oid instance) index)))))
236
 
237
 (defun update-other-association-end (class instance slot-def other-instance)
238
   "Update the association index for the other object so that it maps from
239
    us to it.  Also add error handling."
240
   (declare (ignore class))
241
   (let* ((fclass (class-of other-instance))
242
          (fslot (get-foreign-slot fclass slot-def))
243
          (sc (get-store other-instance)))
244
     (update-association-end fclass other-instance fslot instance)
245
     (when (eq (association-type slot-def) :ref)
246
       (stored-slot-writer sc instance other-instance (slot-definition-name fslot)))))
247
 
248
 (defun get-foreign-class (slot-def)
249
   (find-class (foreign-classname slot-def)))
250
 
251
 (defun get-foreign-slot (fclass slot-def)
252
   (find-slot-def-by-name fclass (foreign-slotname slot-def)))
253
 
254
 ;; =============================
255
 ;;  Late-binding Initialization
256
 ;; =============================
257
 
258
 (defun get-association-index (slot-def sc)
259
   (ifret (get-association-slot-index slot-def sc)
260
     (aif (get-store-association-index slot-def sc)
261
          (progn (add-association-slot-index it slot-def sc) it)
262
          (let ((new-idx (make-dup-btree sc)))
263
            (add-slot-index sc new-idx (association-slot-base slot-def) (slot-definition-name slot-def))
264
            (add-association-slot-index new-idx slot-def sc)
265
            new-idx))))
266
 
267
 (defun get-store-association-index (slot-def sc)
268
   (let* ((master (index-table sc))
269
          (base (association-slot-base slot-def))
270
          (slotname (slot-definition-name slot-def)))
271
     (get-value (cons base slotname) master)))
272
 
273
 ;; ===============================
274
 ;;  Association-specific slot API
275
 ;; ===============================
276
 
277
 (defun add-association (instance slot associated)
278
   (let* ((sc (get-store instance))
279
          (class (class-of instance))
280
          (slot-def (if (symbolp slot) (find-slot-def-by-name class slot) slot)))
281
     (when (null slot-def)
282
       (error "Slot ~A not found in class ~A for instance ~A" slot class instance))
283
     (when (type-check-association instance slot-def associated)
284
       (ensure-transaction (:store sc)
285
         (case (association-type slot-def)
286
           (:ref (update-association-end class instance slot-def associated)
287
                 (stored-slot-writer sc associated instance (slot-definition-name slot-def)))
288
           (:m21 (update-other-association-end class instance slot-def associated))
289
           (:m2m (update-association-end class instance slot-def associated)
290
                 (update-other-association-end class instance slot-def associated)))))))
291
 
292
 (defun remove-association (instance slotname associated)
293
   (let* ((class (class-of instance))
294
          (fclass (class-of associated))
295
          (slot-def (if (symbolp slotname) (find-slot-def-by-name class slotname) slotname))
296
          (fslot (get-foreign-slot fclass slot-def))
297
          (sc (get-store associated)))
298
     (when (null slot-def)
299
       (error "Slot ~A not found in class ~A for instance ~A" slotname class instance))
300
     (when (type-check-association instance slot-def associated)
301
       (ensure-transaction (:store sc)
302
         (case (association-type slot-def)
303
           (:ref (when (slot-boundp-using-class class instance slot-def)
304
                   (slot-makunbound-using-class class instance slot-def)))
305
           (:m21 (when (slot-boundp-using-class fclass associated fslot)
306
                   (slot-makunbound-using-class fclass associated fslot)))
307
           (:m2m (remove-association-end fclass associated fslot instance)
308
                 (remove-association-end class instance slot-def associated)))))))
309
 
310
 (defun get-associations (instance slot)
311
   (slot-value instance (if (symbolp slot) slot (slot-definition-name slot))))
312
 
313
 (defun associatedp (instance slot associated)
314
   (find associated (get-associations instance slot)))
315
 
316
 ;;; IDs
317
 (defgeneric next-oid (store)
318
   (:documentation
319
    "The source of unique object IDs."))
320
 
321
 (let ((%next-oid -1))
322
   (defmethod next-oid ((store list))
323
     (incf %next-oid)))
324
 
325
 (defgeneric next-cid (store)
326
   (:documentation
327
    "The source of unique class schema IDs."))
328
 
329
 (let ((%next-cid -1))
330
   (defmethod next-cid ((store list))
331
     (incf %next-cid)))
332
 
333
 (defun unindex-slot-value (sc key value old-name old-base)
334
   (let* ((master (index-table sc))
335
          (index (get-value (cons old-base old-name) master)))
336
     (remove-kv key value index)))
337
 
338
 ;;; Schema
339
 (defclass stored-object-schema (object-schema upgradable-schema) ())
340
 
341
 (defmethod print-object ((schema stored-object-schema) stream)
342
   (print-unreadable-object (schema stream :type t)
343
     (format stream "~A ~A (s: ~A p: ~A)"
344
             (id schema) (schema-class-name schema)
345
             (schema-successor schema) (schema-predecessor schema))))
346
 
347
 (defun make-stored-object-schema (cid class-schema)
348
   (let ((schema (logical-copy-schema 'stored-object-schema class-schema)))
349
     (setf (id schema) cid)
350
     schema))
351
 
352
 (defun logical-copy-schema (type schema)
353
   (assert (subtypep type 'schema:schema))
354
   (make-instance type
355
     :class-name (schema-class-name schema)
356
     :fields (copy-list (fields schema))))
357
 
358
 (defun copy-schema (type schema)
359
   (assert (subtypep type 'schema))
360
   (let ((new 
361
          (make-instance type
362
                         :name (schema:schema-class-name schema)
363
                         :successor (schema:schema-successor schema)
364
                         :predecessor (schema:schema-predecessor schema)
365
                         :fields (copy-array (schema:fields schema)))))
366
     (when (subtypep (type-of schema) 'upgradable-schema)
367
       (setf (id new) (id schema))
368
       (setf (upgrade new) (upgrade schema))
369
       (setf (version new) (version schema)))
370
     new))
371
 
372
 ;;; DB Evolution
373
 (defmethod upgrade-db-instance ((instance stored-object) (new-schema upgradable-schema) (old-schema upgradable-schema) old-values)
374
   "Upgrade a database instance from the old-schema to the new-schema.
375
    This does mean loading it into memory (for now)!"
376
   (let ((st (get-store instance))
377
         (diff (schema-diff new-schema old-schema)))
378
     (awhen (upgrade old-schema)
379
       (apply-schema-change-fn instance it old-schema))
380
     (loop for entry in diff do
381
              (upgrade-instance-slot st instance (diff-type entry) (diff-recs entry) old-values))
382
     (initialize-new-slots instance diff)
383
     (set-instance-schema-id st (oid instance) (id new-schema))))
384
 
385
 (defmethod upgrade-instance-slot (sc instance (type (eql :change)) recs old-values)
386
   "Handle changes in class type"
387
   (destructuring-bind (old-rec new-rec) recs
388
     (with-slots ((old-type type) (old-name name) (old-args args)) old-rec
389
       (cond ;; If it was not indexed, and now is, we have to notify the index of the new value
390
             ((and (member old-type '(:stored :cached))
391
                   (eq (slot-field-type new-rec) :indexed)
392
                   (slot-boundp instance old-name))
393
              (setf (slot-value instance old-name) (slot-value instance old-name)))
394
             ;; If it was indexed, and the base index has changed 
395
             ;; The new index will get updated as a natural part of the rest of the protocol
396
             ((and (member old-type '(:indexed :derived))
397
                   (not (eq (getf old-args :base)
398
                            (getf (slot-field-args new-rec) :base)))
399
                   (slot-boundp instance old-name))
400
              (let ((slot-value (slot-value instance old-name)))
401
                (unindex-slot-value sc slot-value (oid instance) old-name (getf old-args :base))))
402
             ;; If it was a stored slot and now isn't, drop it and add the new type back
403
             ((and (member old-type '(:stored :indexed :cached :derived))
404
                   (not (member (slot-field-type new-rec) '(:stored :indexed :cached :derived))))
405
              (upgrade-instance-slot sc instance :rem (list old-rec) old-values)
406
              (upgrade-instance-slot sc instance :add (list new-rec) old-values))
407
             ;; If the old slot was indexed
408
             ((and (eq old-type :indexed) (eq (slot-field-type new-rec) :indexed)
409
                   (not (eq (getf (slot-field-args old-rec) :base)
410
                            (getf (slot-field-args new-rec) :base))))
411
              nil)
412
             (t nil)))))
413
 
414
 (defmethod upgrade-instance-slot (sc instance (type (eql :rem)) recs old-values)
415
   "Handle slot removal and cleanup of values, such as sets"
416
   (with-slots (type name args) (first recs)
417
     (when (member type '(:stored :cached :indexed :derived))
418
       (stored-slot-makunbound sc instance name))
419
     (when (member type '(:indexed :derived))
420
       (awhen (getf old-values name)
421
         (unindex-slot-value sc (cdr it) (oid instance) name args)))
422
     (when (eq type :set-valued)
423
       (let ((set (and (stored-slot-boundp sc instance name)
424
                       (stored-slot-reader sc instance name))))
425
         (when set (drop-btree set))
426
         (slot-makunbound instance name)))))
427
 
428
 (defmethod upgrade-instance-slot (sc instance (type (eql :add)) recs old-values)
429
   "Not needed, new slots are initialized above"
430
   (declare (ignore sc instance recs old-values))
431
   nil)
432
 
433
 (defun initialize-new-slots (instance diff)
434
   (labels ((adding-stored? (entry)
435
              (when (and (eq :add (diff-type entry))
436
                         (member (slot-field-type (first (diff-recs entry)))
437
                                 '(:stored :indexed :cached :set-valued)))
438
                (slot-field-name (first (diff-recs entry)))))
439
            (change-to-stored? (entry)
440
              (when (and (eq :change (diff-type entry))
441
                         (not (member (slot-field-type (first (diff-recs entry)))
442
                                      '(:stored :indexed :cached :set-valued)))
443
                         (member (slot-field-type (second (diff-recs entry)))
444
                                 '(:stored :indexed :cached :set-valued)))
445
                (slot-field-name (second (diff-recs entry)))))
446
            (init-slot? (entry)
447
              (or (adding-stored? entry)
448
                  (change-to-stored? entry)))
449
            (compute-init-slots ()
450
              (remove-if #'null (mapcar #'init-slot? diff))))
451
     (apply #'shared-initialize instance (compute-init-slots) nil)))
452
 
453
 (defmethod change-db-instance ((current stored-object) previous
454
                                new-schema old-schema)
455
   "Change a database instance from one schema & class to another
456
    These are different objects with the same oid"
457
   (let ((sc (get-store current))
458
         (oid (oid current))
459
         (diff (schema-diff new-schema old-schema)))
460
       ;; do we need to pass the stored object?  Transient ops require previous?
461
       (awhen (upgrade old-schema)
462
         (apply-schema-change-fn current it old-schema))
463
       ;; Handle changed slots
464
       (loop for entry in diff do
465
            (change-instance-slot sc current previous (diff-type entry) (diff-recs entry)))
466
       ;; Initialize new slots (is this done by default?)
467
       (initialize-new-slots current diff)
468
       (uncache-instance sc oid)
469
       (set-instance-schema-id sc oid (id new-schema))))
470
 
471
 (defmethod change-instance-slot (sc current previous (type (eql :change)) recs)
472
   "Handle changes in class type"
473
 ;; TODO
474
 ;;   (print recs)
475
 ;;   (dump-btree (instance-table sc))
476
 ;;   (dump-index (index-table sc))
477
   (destructuring-bind (old-rec new-rec) recs
478
     (with-slots ((old-type type) (old-name name) (old-args args)) old-rec
479
       (with-slots ((new-type type) (new-name name) (new-args args)) new-rec
480
         (cond ;; If it was not indexed, and now is, we have to notify the index of the new value (?)
481
           ((and (member old-type '(:stored :cached))
482
                 (eq new-type :indexed) (slot-boundp previous old-name))
483
            (setf (slot-value previous old-name) (slot-value previous old-name)))
484
           ;; If the old slot was indexed, we definitely need to unindex it to avoid
485
           ;; having the objects hang around in the index
486
           ((and (eq old-type :indexed) (eq new-type :indexed)
487
                 (slot-boundp previous old-name))
488
            (unindex-slot-value sc (slot-value previous old-name)
489
                                (oid previous) old-name (getf old-args :base))
490
            (setf (slot-value current new-name) (slot-value previous old-name)))
491
           ((and (eq old-type :indexed) (slot-boundp previous old-name))
492
            (unindex-slot-value sc (slot-value previous old-name)
493
                                (oid previous) old-name (getf old-args :base)))
494
           ;; If it was a stored slot and now isn't, drop it and add the new type back
495
           ((and (member old-type '(:stored :indexed :cached))
496
                 (not (member new-type '(:stored :indexed :cached))))
497
            (change-instance-slot sc current previous :rem (list old-rec))
498
            (change-instance-slot sc current previous :add (list new-rec)))
499
           (t nil))))))
500
 
501
 (defmethod change-instance-slot (sc current previous (type (eql :rem)) recs)
502
   "Handle slot removal and cleanup of values, such as sets"
503
   (declare (ignore current))
504
   (with-slots ((prev-type type) (prev-name name) (prev-args args)) (first recs)
505
     (cond ((member prev-type '(:stored :cached :indexed))
506
            (slot-makunbound previous prev-name))
507
           ((eq type :set-valued)
508
            (let ((set (and (stored-slot-boundp sc previous prev-name)
509
                            (stored-slot-reader sc previous prev-name))))
510
              (when set (drop-btree set))
511
              (slot-makunbound previous prev-name))))))
512
 
513
 (defmethod change-instance-slot (sc current previous (type (eql :add)) recs)
514
   "Not needed, new slots are initialized above"
515
   (declare (ignore sc current previous recs))
516
   nil)
517
 
518
 (defgeneric temp-spec (type spec))
519
 (defgeneric delete-spec (type spec))
520
 (defgeneric copy-spec (type src dst))
521
 
522
 ;;; Classes
523
 (defgeneric recreate-instance (instance &rest initargs &key &allow-other-keys)
524
   (:method ((instance t) &rest args)
525
     (declare (ignore args))
526
     instance)
527
   (:method ((instance stored-object) &rest args &key oid schema (st *store*))
528
     (declare (ignore args))
529
     ;; Initialize basic instance data
530
     (initial-stored-setup instance :oid oid :store st)
531
   ;; Update db instance data
532
   (when schema
533
     (let ((official-schema (lookup-schema st (class-of instance))))
534
       (unless (eq (name schema) (name official-schema))
535
         (upgrade-db-instance instance official-schema schema nil))))
536
   ;; Load cached slots, set, assoc values, etc.
537
   (shared-initialize instance t :oid oid)
538
   instance)
539
   (:method ((instance stored-collection) &rest initargs &key oid (st *store*))
540
     (declare (ignore initargs))
541
     ;; Initialize basic instance data
542
     (initial-stored-setup instance :oid oid :store st)
543
     ;; Load cached slots, set, assoc values, etc.
544
     (shared-initialize instance t :oid oid)
545
     instance))
546
 
547
 (defmethod recreate-instance-using-class ((class t) &rest initargs &key &allow-other-keys)
548
   "Implement a subset of the make-instance functionality to avoid initialize-instance
549
    calls after the initial creation time"
550
   (apply #'recreate-instance (allocate-instance class) initargs))
551
 
552
 ;; Class Redefinition
553
 (defmethod update-instance-for-redefined-class :around ((instance stored-object) added-slots discarded-slots property-list &rest initargs)
554
   (declare (ignore discarded-slots added-slots initargs))
555
   (let* ((st (get-store instance))
556
 ;;       (class (class-of instance))
557
          (current-schema (get-current-db-schema st (type-of instance))))
558
 ;;    (unless (match-schemas (%class-schema class) current-schema))
559
       (prog1 
560
           (call-next-method)
561
         (let ((prior-schema (aif (schema:schema-predecessor current-schema)
562
                                  (get-store-schema st it)
563
                                  (error "If the schemas mismatch, a derived store schema should have been computed"))))
564
           (assert (and current-schema prior-schema))
565
           (upgrade-db-instance instance current-schema prior-schema property-list)))))
566
 
567
 (defmethod update-instance-for-different-class :after ((previous stored-object) (current stored-object) 
568
                                                         &rest initargs &key)
569
   ;; Update db to new class configuration
570
   ;; - handle indices, removals, associations and additions
571
   (let* ((sc (get-store current))
572
          (current-schema (lookup-schema sc (class-of current)))
573
          (previous-schema (lookup-schema sc (class-of previous))))
574
     (assert (eq sc (get-store previous)))
575
     (change-db-instance current previous current-schema previous-schema)
576
     ;; Deal with new stored slot, cached and transient initialization
577
     (let* ((diff-entries (schema-diff current-schema previous-schema))
578
            (add-entries (remove-if-not (lambda (entry) (eq :add (diff-type entry))) diff-entries))
579
            (add-names (when add-entries (mapcar #'field-name (mapcan #'diff-recs add-entries)))))
580
       (apply #'shared-initialize current add-names initargs))))
581
 
582
 ;;; Store
583
 (defclass store () 
584
   ((spec :type list
585
          :accessor spec
586
          :initform nil
587
          :initarg :spec
588
          :documentation "Data store initialization functions are
589
          expected to initialize :spec on the call to
590
          make-instance")
591
    ;; Generic support for the object, indexing and root protocols
592
    (root 
593
     :reader store-root 
594
     :documentation "This is an instance of the data store btree. It should have an OID that is
595
 fixed in the code and does not change between sessions. Usually this is
596
 something like 0, 1 or -1")
597
    (schema-table 
598
     :reader schema-table
599
     :documentation "Schema id to schema database table")
600
    (schema-name-index 
601
     :reader schema-name-index
602
     :documentation "Schema name to schema database table")
603
    (schema-cache 
604
     :accessor schema-cache :initform (make-cache-table :test 'eq)
605
     :documentation "This is a cache of class schemas stored in the database indexed by classid")
606
    (schema-classes 
607
     :accessor schema-classes :initform nil
608
     :documentation "Maintains a list of all classes that have a cached schema value so we can shutdown cleanly")
609
    (schema-cache-lock 
610
     :accessor schema-cache-lock :initform (make-mutex :name "cache-lock")
611
     :documentation "Protection for updates to the cache from multiple threads. Do not override.")
612
    ;; Instance storage
613
    (instance-table 
614
     :reader instance-table
615
     :documentation "Contains map of oid to class ids")
616
    (instance-class-index 
617
     :reader instance-class-index
618
     :documentation "A reverse map of class id to oid")
619
    (instance-cache 
620
     :accessor instance-cache :initform (make-cache-table :test 'eql)
621
     :documentation 
622
     "This is an instance cache and part of the metaclass protocol. Data stores
623
 should not override the default behavior.")
624
    (instance-cache-lock 
625
     :accessor instance-cache-lock :initform (make-mutex :name "instance-cache")
626
     :documentation "Protection for updates to the cache from multiple threads. Do not override.")
627
    ;; Root table for all indices
628
    (index-table 
629
     :reader index-table
630
     :documentation 
631
     "This is another root for class indexing that is also a data store specific
632
 stored btree instance with a unique OID that persists between sessions. No
633
 cache is needed because we cache in the class slots.")
634
    (serializer :accessor serializer :initform nil)
635
    (deserializer :accessor deserializer :initform nil)))
636
 
637
 (defmethod print-object ((self store) stream)
638
   (print-unreadable-object (self stream :type t)
639
     (format stream "~A" (second (spec self)))))
640
 
641
 (defmethod initialize-instance :before  ((instance stored)
642
                                          &rest initargs
643
                                          &key oid
644
                                               store)
645
   "Each stored instance has an oid and a home store spec"
646
   (declare (ignore initargs))
647
   (initial-stored-setup instance :oid oid :store store))
648
 
649
 (defun initial-stored-setup (instance &key oid store)
650
   (assert store)
651
   (if oid
652
       (setf (oid instance) oid)
653
       (register-new-instance instance (class-of instance) store))
654
   (setf (spec instance) (spec store))
655
   (cache-instance store instance))
656
 
657
 (defun class-schema-id (st class)
658
   (if (subtypep (class-name class) 'btree)
659
       (default-class-id (class-name class) st)
660
       (id (lookup-schema st class))))
661
 
662
 (defmethod register-instance ((self list) class instance)
663
   (set-instance-schema-id self (oid instance) (class-schema-id self class)))
664
 
665
 (defmethod register-instance ((st store) cl instance)
666
   (set-instance-schema-id st (oid instance) (class-schema-id st cl)))
667
 
668
 (defmethod set-instance-schema-id ((st store) oid cid)
669
   (let ((table (instance-table st)))
670
     (delete-key oid table)
671
     (setf (get-value oid table) cid)))
672
 
673
 (defmethod get-instance-class ((st store) oid &optional classname)
674
   "Get the class object using the oid or using the provided classname"
675
   (when classname
676
     (return-from get-instance-class (find-class classname)))
677
   (let ((cid (oid->schema-id oid st)))
678
     (unless cid
679
       (signal-missing-instance oid (spec st))
680
       (return-from get-instance-class (find-class 'stored-object)))
681
     (get-schema-id-class st cid)))
682
 
683
 (defmethod get-schema-id-class ((st store) cid)
684
   "Get the class given the schema id"
685
   (aif (default-class-id-type cid st)
686
        (find-class it)
687
        (let ((schema (get-store-schema st cid)))
688
          (values (find-class (schema-class-name schema)) schema))))
689
 
690
 (define-condition missing-stored-instance (simple-condition)
691
    ((oid :initarg :oid :accessor error-oid)
692
     (spec :initarg :spec :accessor error-spec)))
693
 
694
 (defun signal-missing-instance (oid spec)
695
   (cerror "Return a proxy object"
696
           'missing-stored-instance
697
           :format-control "Instance with OID ~A is not stored in ~A"
698
           :format-arguments (list oid spec)
699
           :oid oid
700
           :spec spec))
701
 
702
 (defmethod store-recreate-instance ((st store) oid &optional classname)
703
   "Called by the deserializer to return an instance"
704
   (handler-case 
705
       (progn 
706
         ;; Quick test since only the GC deletes object references
707
         (awhen (get-cached-instance st oid)
708
           (return-from store-recreate-instance it))
709
         ;; Update cache unless someone has before us!
710
         (with-mutex ((instance-cache-lock st))
711
           (aif (get-cached-instance st oid) it
712
                (multiple-value-bind (class schema) (get-instance-class st oid classname)
713
                  (recreate-instance-using-class class :oid oid :store st :schema schema)))))
714
     (missing-stored-instance (e)
715
       (signal e))))
716
 
717
 (defmethod get-slot-def-index ((def association-effective-slot-definition) sc)
718
   "Since endpoints of an association implement an index we should be able to perform
719
    inverted-index relation functions on them directly"
720
   (get-association-index def sc))
721
 
722
 (defun register-new-instance (instance class store)
723
   (setf (oid instance) (next-oid store))
724
   (register-instance store class instance))
725
 
726
 (defun check-valid-store (store)
727
   (if-let ((ok (subtypep (type-of store) 'store)))
728
     ok
729
     (error "This function requires a valid store")))
730
 
731
 (defmethod build-pset ((sc store))
732
   "Default pset method; override if backend has better policy"
733
   (let ((btree (make-dup-btree sc)))
734
     (make-instance 'default-pset :btree btree :sc sc)))
735
 
736
 (defun make-pset (&key items pset (store *store*))
737
   (let ((new-pset (build-pset store)))
738
     (when (and items pset)
739
       (error "Can only initialize a new pset with item list or pset to copy, not both"))
740
     (when items
741
       (mapc (lambda (item)
742
               (insert-item item new-pset))
743
             items))
744
     (when pset
745
       (map-pset (lambda (item)
746
                   (insert-item item new-pset))
747
                 pset))
748
     new-pset))
749
 
750
 (defmethod insert-item (item (pset default-pset))
751
   (setf (get-value item (pset-btree pset)) t)
752
   item)
753
 
754
 (defmethod remove-item (item (pset default-pset))
755
   (delete-key (pset-btree pset) item)
756
   item)
757
 
758
 (defmethod find-item (item (pset default-pset) &key key (test #'equal))
759
   (if (not (or key test))
760
       (get-value item (pset-btree pset))
761
       (map-btree (lambda (elt dc)
762
                    (declare (ignore dc))
763
                    (let ((cmpval (if key (funcall key elt) elt)))
764
                      (if (funcall test item cmpval)
765
                          (return-from find-item elt))))
766
                  (pset-btree pset))))
767
 
768
 (defmethod map-pset (fn (pset default-pset))
769
   (map-btree (lambda (key value) 
770
                (declare (ignore value))
771
                (funcall fn key))
772
              (pset-btree pset))
773
   pset)
774
 
775
 (defmethod pset-list ((pset default-pset))
776
   (map-btree #'(lambda (k v) 
777
                  (declare (ignore v))
778
                  k) 
779
              (pset-btree pset) :collect t))
780
 
781
 (defmethod drop-pset ((pset default-pset))
782
   (ensure-transaction (:store *store*)
783
     (awhen (pset-btree pset)
784
       (drop-btree it))))
785
 
786
 (defmethod build-slot-set ((sc store))
787
   (let ((btree (make-btree sc)))
788
     (make-instance 'stored-slot-set :btree btree :sc sc)))
789
 
790
 (defmethod drop-instance ((inst stored-object))
791
   (drop-instance-slots inst)
792
   (call-next-method))
793
 
794
 (defmethod drop-instance ((inst stored))
795
   (let ((sc (get-store inst)))
796
     (with-mutex ((instance-cache-lock sc))
797
       (remcache (oid inst) (instance-cache sc)))
798
     (delete-key (oid inst) (instance-table sc))))
799
 
800
 (defun drop-instance-slots (instance)
801
   "A helper function for drop-instance, that deletes the storage of 
802
    stored slots of instance from the db"
803
   (let ((class (class-of instance)))
804
     (loop for slot-def in (class-slots class)
805
        when (stored-p slot-def)
806
        do (slot-makunbound-using-class class instance slot-def))))
807
 
808
 (defun dropped-instance-p (st oid)
809
   "An instance has not been dropped if it is in the instance
810
    table and has a valid class id"
811
   (multiple-value-bind (cid found?)
812
       (get-value oid (instance-table st))
813
     (and cid found?)))
814
 
815
 (defmethod oid->schema-id (oid (st store))
816
   (get-value oid (instance-table st)))
817
 
818
 (defgeneric default-class-id (base-type sc)
819
   (:documentation "A method implemented by the store for providing
820
    fixed class ids for basic btree derivative types")
821
   (:method ((base-type t) (sc list))
822
     (sxhash base-type)))
823
 
824
 (defgeneric default-class-id-type (id sc)
825
   (:documentation "A method implemented by the store which provides
826
    the type associated with a default id or nil if the id does not match"))
827
 
828
 (defgeneric reserved-oid-p (sc oid)
829
   (:documentation "Is this OID reserved by the store? GC doesn't touch"))
830
 
831
 (defmethod add-class-store-schema (st (class stored-class) schema)
832
   ;; NOTE: Needs to be lock protected
833
   (pushnew (class-name class) (schema-classes st))
834
   (remove-class-store-schema st class)
835
   (setf (get-store-schemas class)
836
         (acons (spec st) schema (get-store-schemas class))))
837
 
838
 (defmethod remove-class-store-schema (st (class stored-class))
839
   ;; NOTE: Needs to be lock protected
840
   (setf (get-store-schemas class)
841
         (remove (spec st) (get-store-schemas class) 
842
                 :key #'car :test #'equalp)))
843
 
844
 (defmethod get-class-store-schema (st (class stored-class))
845
   (awhen (assoc (spec st) (get-store-schemas class))
846
     (cdr it)))
847
 
848
 (defmethod lookup-schema ((st store) (class stored-class))
849
   "Get the latest db class schema from caches, etc."
850
   ;; Lookup class cached version
851
   (awhen (get-class-store-schema st class) 
852
     (when (eq (schema:schema-successor it) nil)
853
       (return-from lookup-schema it)))
854
   ;; Lookup stored version
855
   (aif (get-current-db-schema st (class-name class))
856
        ;; Store it
857
        (prog1 it
858
          (add-class-store-schema st class it))
859
        ;; Or create it
860
        (create-store-schema st class)))
861
 
862
 (defmethod get-store-schema ((st store) schema-id &optional class)
863
   "Find the db class schema by schema id. CLASS needs to be supplied
864
   if the class object isn't registered via (SETF FIND-CLASS) yet."
865
   (assert (typep schema-id 'fixnum))
866
   ;; Lookup in store cache
867
   (std/macs:ifret (get-cache schema-id (schema-cache st))
868
          ;; Lookup in store table
869
          (let* ((schema (get-value schema-id (schema-table st)))
870
                 (class (or class (find-class (schema:schema-class-name schema)))))
871
            (assert schema)
872
            ;; Update store cache
873
            (with-mutex ((schema-cache-lock st))
874
              (setf (get-cache schema-id (schema-cache st)) schema))
875
            ;; Also cache in class slot
876
            (add-class-store-schema st class schema)
877
            schema)))
878
 
879
 (defmethod create-store-schema ((st store) class)
880
   "We don't have a cached store schema, so create a new one"
881
   (ensure-finalized class)
882
   (let ((schema (make-stored-object-schema (next-cid st) (get-class-schema class))))
883
     ;; Add to database
884
     (setf (get-value (id schema) (schema-table st))
885
           schema)
886
     ;; Let get-store-schema cache it for us
887
     (get-store-schema st (id schema) class)))
888
 
889
 (defmethod update-store-schema ((st store) schema &optional update-cache)
890
   "Use this to update the schema version that is on store and in 
891
    all the various caches"
892
   (assert (typep schema 'stored-object-schema))
893
   (assert (id schema))
894
   (let ((schema-id (id schema)))
895
     (set-store-schema st schema-id schema)
896
     (when update-cache
897
       (with-mutex ((schema-cache-lock st))
898
         (setf (get-cache schema-id (schema-cache st)) schema))
899
       (awhen (find-class (schema:schema-class-name schema) nil)
900
         (add-class-store-schema st (find-class (schema:schema-class-name schema)) schema)))))
901
 
902
 
903
 (defmethod set-store-schema ((st store) schema-id schema)
904
   "Insert a new schema into the store table"
905
   (setf (get-value schema-id (schema-table st))
906
         schema))
907
 
908
 (defmethod remove-store-schema ((st store) schema-id)
909
   "Remove a schema from the store table; uncache separately"
910
   (delete-key schema-id (schema-table st)))
911
 
912
 (defmethod uncache-store-schema ((st store) schema-id)
913
   (handler-case
914
       (progn
915
         (with-mutex ((schema-cache-lock st))
916
           (remcache schema-id (schema-cache st)))
917
         (remove-class-store-schema st (get-schema-id-class st schema-id)))
918
     (program-error (e) ;; in case the class is gone for some reason
919
       (warn "Error ~A in uncache-store-schema , ignoring" e)
920
       nil)))
921
 
922
 (defun get-current-db-schema (sc name)
923
   (awhen (sort (get-db-schemas sc name)
924
                #'> :key #'id)
925
     (car it)))
926
 
927
 (defun get-db-schemas (st classname)
928
   "Return schemas ordered oldest to youngest (ascending cids)"
929
   (sort
930
    (map-btree #'(lambda (cname schema)
931
                   (declare (ignore cname))
932
                   schema)
933
               (schema-name-index st)
934
               :value classname :collect t)
935
    #'<
936
    :key #'id))
937
 
938
 (defun update-derived-slot (class instance derived-slot-def)
939
   "Make a copy of the functionality here to be more efficient"
940
   (let ((sc (get-store instance)))
941
     (multiple-value-bind (new-value index?)
942
         (funcall (derived-fn derived-slot-def) instance)
943
       (when index?
944
         (update-slot-index sc class instance derived-slot-def new-value)
945
         (stored-slot-writer sc new-value instance 
946
                                 (slot-definition-name derived-slot-def))))))
947
 
948
 (defun derived-index-updater (class instance written-slot-def)
949
   "Compute the derived indices to update from the slot-def that is
950
    being written to.  Should be called in a transaction"
951
   (awhen (derived-slot-triggers written-slot-def)
952
     (dolist (derived-slot-def it)
953
       (update-derived-slot class instance derived-slot-def))))
954
 
955
 (defun update-slot-index (sc class instance slot-def new-value)
956
   "Update an index value when written"
957
   (let ((oid (oid instance)))
958
       (let* ((idx (get-slot-def-index slot-def sc))
959
              (old-value-bound-p (slot-boundp-using-class class instance slot-def))
960
              (old-value (when old-value-bound-p
961
                           (slot-value-using-class class instance slot-def))))
962
         (unless idx
963
           (setf idx (ensure-slot-def-index slot-def sc)))
964
         (when old-value-bound-p 
965
           (remove-kv old-value oid idx))
966
         (setf (get-value new-value idx) oid))))
967
 
968
 (defun get-store-index (slot-def sc)
969
   "Get the slot-def's index from the store"
970
   (let* ((master (index-table sc))
971
          (base (indexed-slot-base slot-def))
972
          (name (slot-definition-name slot-def)))
973
     (get-value (cons base name) master)))
974
 
975
 (defun ensure-slot-def-index (slot-def sc)
976
   "If a slot's index does not exist, create it"
977
   (aif (get-store-index slot-def sc)
978
        (progn (add-slot-def-index it slot-def sc) it)
979
        (let ((new-idx (make-btree sc)))
980
          (add-slot-index sc new-idx (indexed-slot-base slot-def) (slot-definition-name slot-def))
981
          (add-slot-def-index new-idx slot-def sc)
982
          new-idx)))
983
 
984
 (defmethod add-slot-index ((sc store) new-index class-name index-name)
985
   "Add it to the index table and the class slot def"
986
   (setf (get-value (cons class-name index-name) (index-table sc))
987
         new-index))
988
 
989
 (defmethod drop-slot-index ((sc store) class-name index-name)
990
   (clear-slot-def-index (find-slot-def-by-name (find-class class-name) index-name) sc)
991
   (delete-key (cons class-name index-name) (index-table sc)))
992
 
993
 (defmethod rebuild-slot-index ((sc store) class-name index-name)
994
   (drop-slot-index sc class-name index-name)
995
   (let ((class (find-class class-name)))
996
     (ensure-slot-def-index (find-slot-def-by-name class index-name) sc)
997
     (map-class #'(lambda (instance)
998
                    (when (slot-boundp instance index-name)
999
                      (update-slot-index sc class instance
1000
                                         (find-slot-def-by-name class index-name)
1001
                                         (slot-value instance index-name))))
1002
                class)))
1003
 
1004
 (defun rebuild-slot-indices (sc class)
1005
   "Rebuild all slot indices for CLASS, or all known classes
1006
   if CLASS is NIL. CLASS may be a class or class name."
1007
   (let* ((classes (list* (etypecase class
1008
                             (null (known-classes sc))
1009
                             (class class)
1010
                             (symbol (find-class class)))))
1011
          (class-names (mapcar #'class-name classes)))
1012
     (loop for class in classes
1013
           for class-name in class-names
1014
           do (progn
1015
                (format t "=== class ~S~%" class)
1016
                (dolist (slotname (indexed-slot-names class))
1017
                  (ensure-finalized class) ; for CLASS-SLOTS
1018
                  (when (member slotname (class-slots class) :key #'slot-definition-name)
1019
                    (format t "slot index ~S~%" slotname)
1020
                    (rebuild-slot-index sc class-name slotname)))))))
1021
 
1022
 (defun known-classes (sc)
1023
   "Return all classes that are known both to SC and the current
1024
   Lisp image."
1025
   (remove-duplicates
1026
     (remove nil
1027
             (maphash (lambda (cid schema)
1028
                          (declare (ignore cid))
1029
                          (let ((class (find-class (name schema) nil)))
1030
                            (unless class
1031
                              (warn "Class ~S not defined, ignoring." (name schema)))
1032
                            class))
1033
                        (schema-table sc)))))
1034
 
1035
 (defun map-class (fn class &key collect oids (sc *store*))
1036
   "Perform a map operation over all instances of class.  Takes a
1037
    function of one argument, a class instance."
1038
   (flet ((map-fn (cidx pcidx oid)
1039
            (declare (ignore cidx pcidx))
1040
            (funcall fn (store-recreate-instance sc oid)))
1041
          (map-oid-fn (cidx pcidx oid)
1042
            (declare (ignore cidx pcidx))
1043
            (funcall fn oid)))
1044
     (declare (dynamic-extent (function map-fn) (function map-oid-fn)))
1045
     (let* ((classobj (if (symbolp class) (find-class class) class))
1046
            (classname (if (symbolp class) class (class-name class)))
1047
            (db-schemas (get-db-schemas sc classname))
1048
            (schema-ids (if db-schemas 
1049
                            (mapcar #'id (reverse db-schemas))
1050
                            (list (id (lookup-schema sc (if (symbolp class) (find-class class) class)))))))
1051
       (unless (class-indexing-enabled-p classobj)
1052
         (cerror "Ignore and return nil"
1053
                 "Class ~A is not indexed" classname)
1054
         (return-from map-class nil))
1055
 ;;      (dump-schema-status sc classname)
1056
       (loop for schema-id in schema-ids appending
1057
            (map-index (if oids #'map-oid-fn #'map-fn)
1058
                       (instance-class-index sc)
1059
                       :value schema-id
1060
                       :collect collect)))))
1061
 
1062
 (defun map-inverted-index (fn class index &rest args &key start end (value nil value-p) from-end collect oids)
1063
   "map-inverted-index maps a function of two variables, taking key
1064
    and instance, over a subset of class instances in the order
1065
    defined by the index.  Specify the class by classname or class object 
1066
    and index by quoted name.  The index may be a slot index, derived index,
1067
    or a valued association slot.
1068
 
1069
    To map only a subset of key-value pairs, specify the range
1070
    using the :start and :end keywords; all elements greater than
1071
    or equal to :start and less than or equal to :end will be
1072
    traversed regardless of whether the start or end value is in
1073
    the index.  
1074
 
1075
    Use nil in the place of start or end to specify the first
1076
    element or last element, respectively.  
1077
 
1078
    To map a single value, iff it exists, use the :value keyword.
1079
    This is the only way to travers all nil values.
1080
 
1081
    To map from :end to :start in descending order, set :from-end
1082
    to true.  If :value is used, :from-end is ignored
1083
 
1084
    The 'oids' argument passes the oid of the instance to the provided
1085
    function instead of the recreated instance."
1086
   (declare (dynamic-extent args)
1087
            (ignorable args))
1088
   (let* ((btree (if (symbolp index)
1089
                     (find-inverted-index class index)
1090
                     index))
1091
          (class-obj (etypecase class
1092
                       (symbol (find-class class))
1093
                       (stored-class class)))
1094
          (sc (get-store btree)))
1095
     (flet ((map-obj (value oid)
1096
              (funcall fn value (store-recreate-instance sc oid))))
1097
       (cond ((eq 'association-effective-slot-definition (type-of (find-slot-def-by-name class-obj index)))
1098
              (map-btree (if oids fn #'map-obj) btree :value (oid value) :collect collect))
1099
             (value-p (map-btree (if oids fn #'map-obj) btree :value value :collect collect))
1100
             (t (map-btree (if oids fn #'map-obj) btree :start start :end end :from-end from-end :collect collect))))))
1101
 
1102
 (defun get-unique-values (index &aux values)
1103
     (with-btree-cursor (cur index)
1104
       (multiple-value-bind (valid? value oid)
1105
           (cursor-first cur)
1106
         (declare (ignore oid))
1107
         (when valid?
1108
           (push value values)
1109
           (loop 
1110
                (multiple-value-bind (valid? value oid)
1111
                    (btree::cursor-next-nodup cur)
1112
                  (declare (ignore oid))
1113
                  (unless valid?
1114
                    (return-from get-unique-values (nreverse values)))
1115
                  (push value values)))))))
1116
 
1117
 (defmethod sb-sequence:emptyp ((btree btree))
1118
     (with-btree-cursor (cur btree)
1119
       (multiple-value-bind (valid k) (cursor-next cur)
1120
         (declare (ignore k))
1121
         (cond ((not valid) ;; truly empty
1122
                t)
1123
               ((eq btree (store-root (get-store btree)))
1124
                (not (cursor-next cur)))
1125
               (t nil)))))
1126
 
1127
 (defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil) (sc *store*))
1128
   (find-inverted-index (find-class class) slot :null-on-fail null-on-fail :sc sc))
1129
 
1130
 (defmethod find-inverted-index ((class stored-class) slot &key ignore-errors (store *store*))
1131
   (ensure-finalized class)
1132
   (flet ((assert-error ()
1133
            (when ignore-errors (return-from find-inverted-index nil))
1134
            (cerror "Return null and continue?"
1135
                    "Inverted slot index ~A not found for class ~A with indexed slots: ~A" 
1136
                    slot (class-name class) (indexed-slot-names class))))
1137
     (let ((slot-def (find-slot-def-by-name class slot)))
1138
       (unless (and slot-def
1139
                    (or (eq (type-of slot-def) 'indexed-effective-slot-definition)
1140
                        (eq (type-of slot-def) 'derived-index-effective-slot-definition)))
1141
         (assert-error))
1142
       (let ((idx (get-slot-def-index slot-def store)))
1143
         (unless idx
1144
           (setf idx (ensure-slot-def-index slot-def store)))
1145
         idx))))
1146
 
1147
 ;;; Controller Protocol
1148
 (defgeneric open-store (st &key recover recover-fatal thread &allow-other-keys)
1149
   (:documentation "Opens the underlying environment and all the necessary
1150
 database tables. Different data stores may use different keys so all methods
1151
 should &allow-other-keys. There are three standard keywords: :recover,
1152
 :recover-fatal and :thread. Recover means that recovery should be checked for
1153
 or performed on startup. Recover fatal means a full rebuild from log files is
1154
 requested. Thread merely indicates to the data store that it is a threaded
1155
 application and any steps that need to be taken (for example transaction
1156
 implementation) are taken. :thread is usually true."))
1157
 
1158
 (defgeneric close-store (st)
1159
   (:documentation "Close the db handles and environment. Should be in a state where lisp could be
1160
 shut down without causing an inconsistent state in the db. Also, the object
1161
 could be used by open-store to reopen the database."))
1162
 
1163
 (defgeneric optimize-layout (st &key &allow-other-keys)
1164
   (:documentation "If supported, speed up the index and allocation by freeing up any available
1165
 storage and return it to the free list. See the methods of data stores to
1166
 determine what options are valid. Supported both on stores (all btrees and
1167
 stored slots) and specific btrees."))
1168
 
1169
 
1170
 ;;; Controller User API
1171
 
1172
 ;; start stop
1173
 
1174
 (defun close-all-stores ()
1175
   (loop for pair in *stores*
1176
        do (close-store (cdr pair))))
1177
 
1178
 ;; (pushnew 'close-all-stores sb-ext:*exit-hooks*)
1179
 
1180
 (defmacro with-open-store (spec &body body)
1181
   "Executes the body with an open store,
1182
    unconditionally closing the store on exit."
1183
   `(let ((*store* nil))
1184
      (declare (special *store*))
1185
      (open-store ,spec)
1186
      (unwind-protect
1187
           (progn ,@body)
1188
        (close-store *store*))))
1189
 
1190
 (defmacro with-store ((store) &body body)
1191
   (with-gensyms (ref)
1192
     `(let* ((,ref ,store)
1193
             (*store* 
1194
              (if (listp ,ref)
1195
                  (get-store ,ref)
1196
                  ,ref)))
1197
        (declare (special *store*))
1198
        ,@body)))
1199
 
1200
 ;; drop-instances
1201
 
1202
 ;;; Root indexes
1203
 (defun add-to-root (key value &key (st *store*))
1204
   "Add an arbitrary stored thing to the root, so you can
1205
    retrieve it in a later session.  Anything referenced by an
1206
    object added to the root is considered reachable and thus live"
1207
   (declare (type store st))
1208
   ;; (assert (not (eq key *elephant-properties-label*)))
1209
   (setf (get-value key (store-root st)) value))
1210
 
1211
 (defun get-from-root (key &key (st *store*))
1212
   "Get the value associated with key from the root.  Returns two
1213
    values, the value, or nil, and a boolean indicating whether a
1214
    value was found or not (so you know if nil is a value or an
1215
    indication of non-presence)"
1216
   (declare (type store st))
1217
   (get-value key (store-root st)))
1218
 
1219
 (defun root-existsp (key &key (st *store*))
1220
   "Test whether a given key is instantiated in the root"
1221
   (declare (type store st))
1222
   (if (btree:existsp key (store-root st))
1223
       t 
1224
       nil))
1225
 
1226
 (defun remove-from-root (key &key (st *store*))
1227
   "Remove something from the root by the key value"
1228
   (declare (type store st))
1229
   (delete-key key (store-root st)))
1230
 
1231
 (defun map-root (fn &key (st *store*))
1232
   "Takes a function of two arguments, key and value, to map over
1233
    all key-value pairs in the root"
1234
   (map-btree fn (store-root st)))
1235
 
1236
 ;;; Slot Access
1237
 (defmethod slot-value-using-class ((class stored-class) (instance stored-object) (slot-def stored-slot-definition))
1238
   "Get the slot value from the database."
1239
   (let ((name (slot-definition-name slot-def)))
1240
     (stored-slot-reader (get-store instance) instance name)))
1241
 
1242
 (defmethod (setf slot-value-using-class) (new-value (class stored-class) (instance stored-object) (slot-def stored-slot-definition))
1243
   "Set the slot value in the database."
1244
   (let ((name (slot-definition-name slot-def)))
1245
       (cond
1246
         ((derived-slot-triggers slot-def)
1247
          (stored-slot-writer (get-store instance) new-value instance name)
1248
          (derived-index-updater class instance slot-def))
1249
         (t (stored-slot-writer (get-store instance) new-value instance name))))
1250
   new-value)
1251
 
1252
 (defmethod slot-boundp-using-class ((class stored-class) (instance stored-object) (slot-def stored-slot-definition))
1253
   "Checks if the slot exists in the database."
1254
   (when instance
1255
     (let ((name (slot-definition-name slot-def)))
1256
       (stored-slot-boundp (get-store instance) instance name))))
1257
 
1258
 (defmethod slot-boundp-using-class ((class stored-class) (instance stored-object) (slot-name symbol))
1259
   "Checks if the slot exists in the database."
1260
   (loop for slot in (class-slots class)
1261
      for matches-p = (eq (slot-definition-name slot) slot-name)
1262
      until matches-p
1263
      finally (return (if (and matches-p
1264
                               (subtypep (type-of slot) 'stored-slot-definition))
1265
                        (stored-slot-boundp (get-store instance) instance slot-name)
1266
                        (call-next-method)))))
1267
 
1268
 (defmethod slot-makunbound-using-class ((class stored-class) (instance stored-object) (slot-def stored-slot-definition))
1269
   "Removes the slot value from the database."
1270
   (stored-slot-makunbound (get-store instance) instance (slot-definition-name slot-def)))
1271
 
1272
 (defun valid-stored-reference-p (object sc)
1273
   "Ensures that object can be written as a reference into store sc"
1274
   (or (not (slot-boundp object 'spec))
1275
       (eq (spec object) (spec sc))))
1276
 
1277
 (define-condition cross-store-error (error)
1278
   ((object :accessor error-object :initarg :object)
1279
    (home :accessor error-home-store :initarg :home-store)
1280
    (guest :accessor error-guest-store :initarg :guest-store))
1281
   (:documentation "An error condition raised when an object is being written into a data store other
1282
                    than its home store")
1283
   (:report (lambda (condition stream)
1284
              (format stream "Attempted to write object ~A with home store ~A into store ~A"
1285
                      (error-object condition)
1286
                      (error-home-store condition)
1287
                      (error-guest-store condition)))))
1288
 
1289
 (defun signal-cross-store-error (object sc)
1290
   (cerror "Proceed to write incorrect reference"
1291
           'cross-reference-error
1292
           :object object
1293
           :home-store (get-store object)
1294
           :guest-store sc))
1295
 
1296
 ;;; Macros
1297
 (defmacro defstore (name super spec &rest options)
1298
   "Define a new STORE class.")
1299
 
1300
 ;; TODO 2024-12-05: do we want to pass DB by value here (in the environment of
1301
 ;; WITH-STORE) or are we better off binding DATABASE instances as
1302
 ;; *STORE-BACKEND*?
1303
 (defmacro with-store ((sym &rest initargs &key &allow-other-keys) &body body)
1304
   "Similar to WITH-DB but for STORE objects instead of DATABASEs. 
1305
 
1306
 INITARGS may contain any number keys that have been registered with the
1307
 current *STORE-BACKEND*.")