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

KindCoveredAll%
expression01901 0.0
branch0102 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; store.lisp --- RocksDB Store
2
 
3
 ;; OBJ/STORE implementation for RocksDB
4
 
5
 ;;; Code:
6
 (in-package :rdb)
7
 
8
 ;; what should the underlying datastructure be? transaction-db wbwi or cf?
9
 (defclass rdb-btree (btree) ()
10
   (:documentation "A RocksDB implementation of a BTree."))
11
 
12
 (defclass rdb-store (store rdb-database)
13
   ((oid-seq :accessor oid-seq)
14
    (cid-seq :accessor cid-seq)
15
    (logger :initform (default-logger) :initarg :logger :accessor logger))
16
    (:default-initargs
17
     :spec '(:rdb)
18
     :db (make-db :rocksdb :opts (default-rdb-opts))
19
     :columns (make-array 0 :element-type 'rdb-column-family
20
                            :adjustable t
21
                            :fill-pointer t)
22
     ;; :instance-table (make-instance 'rdb-column-family :type '(oid . cid))
23
     ;; :instance-class-index (make-instance 'rdb-column-family :type '(cid . oid))
24
     ;; :root
25
     ;; :schema-table (make-hash-table :size 100 :weakness :value)
26
     ;; :schema-name-index (make-hash-table :size 100 :test 'equal :weakness :value)
27
     ;; :index-table
28
     ;; :instance-table
29
     ;; :instance-class-index
30
     )
31
    (:documentation "A RocksDB STORE. Note that the default column family is used to store
32
 serialized object schemas."))
33
 
34
 (defmethod build-btree ((st rdb-store))
35
   (make-instance 'rdb-btree :store st))
36
 
37
 ;; (build-btree (make-instance 'rdb-store))
38
 
39
 (defun rdb-store-spec-p (spec)
40
   (and (eq (first spec) :rdb)
41
        (typecase (second spec)
42
          (pathname t)
43
          (string t)
44
          (t nil))))
45
 
46
 (defmethod get-value (key (bt rdb-btree))
47
   "Getting a value from a plain RDB-BTREE will fetch the value directly from (DB *STORE*)."
48
   (let ((sc (get-store bt)))
49
     (ensure-transaction (:store sc)
50
       (with-static-stream (key-buf)
51
         (write-oid (oid bt) key-buf)
52
         (ser key key-buf sc)
53
         (let ((buf (db-get-key-buffered
54
                     (btree sc)
55
                     :transaction (current-transaction sc))))
56
           (if buf (values (deserialize buf sc) t)
57
               (values nil nil)))))))
58
 
59
 (defmethod existsp (key (bt rdb-btree))
60
   (let ((sc (get-store bt)))
61
     (ensure-transaction (:store sc)
62
       (with-static-stream (key-buf)
63
       (write-oid (oid bt) key-buf)
64
       (ser key key-buf sc)
65
       (let ((buf (db-get-key-buffered 
66
                   (btree sc)
67
                   :transaction (current-transaction sc))))
68
           (if buf t
69
               nil))))))
70
 
71
 (defmethod (setf get-value) (value key (bt rdb-btree))
72
     (let ((sc (get-store bt)))
73
       (ensure-transaction (:store sc)
74
         (with-static-streams ((key-buf) (value-buf))
75
           (write-oid (oid bt) key-buf)
76
           (ser key key-buf sc)
77
           (ser value value-buf sc)
78
           (db-put-buffered (btree sc)
79
                            :transaction (current-transaction sc))))
80
       value))
81
 
82
 (defmethod delete-key (key (bt rdb-btree) &key)
83
   (let ((sc (get-store bt)) )
84
     (with-static-stream (key-buf)
85
       (ensure-transaction (:store sc)
86
         (write-oid (oid bt) key-buf)
87
         (ser key key-buf sc)
88
         (db-delete-buffered (btree sc)
89
                             :transaction (current-transaction sc))))))
90
 
91
 (defmethod optimize-layout ((bt rdb-btree) &key (freelist-only t) (free-space nil) &allow-other-keys)
92
   (optimize-layout (get-store bt)
93
                    :start-key (oid bt)
94
                    :end-key (oid bt)
95
                    :freelist-only freelist-only
96
                    :free-space free-space))
97
 
98
 (defclass rdb-indexed-btree (indexed-btree rdb-btree)
99
   ((index-table :accessor index-table :initarg :index-table :initform (make-hash-table))
100
    (index-cache-table :accessor index-cache-table :transient t))
101
   (:metaclass stored-class)
102
   (:documentation "A RDB-based BTree supports secondary index-table."))
103
 
104
 (defmethod index-cache-table ((instance rdb-indexed-btree))
105
   ;; Lazily load the index-cache-table to avoid bootstrapping issues: If
106
   ;; we do not lazy-load the index-table cache, it we attempt to
107
   ;; initialize it before the instance-table is available (thus we
108
   ;; cannot map oids to classes -- deserialize does not really work
109
   ;; for complex objects).  -- Red Daly 07/10/2010
110
   (aif (slot-value instance 'index-cache-table)
111
        it
112
        (setf (index-cache-table instance) (index-table instance))))
113
 
114
 (defmethod shared-initialize :after ((instance rdb-indexed-btree) slot-names
115
                                      &rest rest)
116
   (declare (ignore slot-names rest))
117
   (setf (index-cache-table instance) nil))
118
 
119
 (defmethod build-indexed-btree ((sc rdb-store))
120
   (make-instance 'rdb-indexed-btree :store sc))
121
 
122
 (defmethod build-btree-index ((sc rdb-store) &key primary key-form &allow-other-keys)
123
   (make-instance 'rdb-btree-index :primary primary :key-form key-form :store sc))
124
 
125
 (defmethod add-index ((bt rdb-indexed-btree) &key index-name key-form (populate t))
126
   (let ((sc (get-store bt)))
127
 ;; Setting the value of *store* is unfortunately
128
 ;; absolutely required at present, I think because the copying 
129
 ;; of objects is calling "make-instance" without an argument.
130
 ;; I am sure I can find a way to make this cleaner, somehow.
131
     (if (and (not (null index-name))
132
              (symbolp index-name)
133
              (or (symbolp key-form) (listp key-form)))
134
         ;; Can it be that this fails?
135
         (let ((index
136
                (ensure-transaction (:store sc)
137
                  (let ((ht (index-table bt))
138
                        (index (build-btree-index sc 
139
                                                  :primary bt 
140
                                                  :key-form key-form)))
141
                    (setf (gethash index-name (index-cache-table bt)) index)
142
                    (setf (gethash index-name ht) index)
143
                    (setf (index-table bt) ht)
144
                    index))))
145
           (when populate (populate bt index))
146
           index)
147
         (error "Invalid index initargs!"))))
148
 
149
 (defmethod populate ((bt rdb-indexed-btree) index)
150
   (let ((sc (get-store bt)))
151
     (with-static-streams ((primary-buf) (secondary-buf))
152
       (flet ((index (key skey)
153
                (write-oid (oid bt) primary-buf)
154
                (ser key primary-buf sc)
155
                (write-oid (oid index) secondary-buf)
156
                (ser skey secondary-buf sc)
157
                ;; should silently do nothing if
158
                ;; the key/value already exists
159
                (db-put-buffered 
160
                 (index-table sc)
161
                 secondary-buf primary-buf
162
                 :transaction (current-transaction sc))
163
                (reset-static-stream primary-buf)
164
                (reset-static-stream secondary-buf)))
165
         (let ((key-fn (key-fn index))
166
               (last-key nil)
167
               (continue t))
168
           (loop while continue
169
              do
170
              (ensure-transaction (:store sc)
171
                (with-btree-cursor (cursor bt)
172
                  (if last-key 
173
                      (cursor-set cursor last-key)
174
                      (cursor-first cursor))
175
                  (loop for i from 0 upto 1000
176
                     while continue
177
                     do
178
                       (multiple-value-bind (valid? k v) (cursor-current cursor)
179
                         (unless valid? (return-from populate t))
180
                         (multiple-value-bind (index? skey) (funcall key-fn index k v)
181
                           (when index? (index k skey))))
182
                       (multiple-value-bind (valid? k v) (cursor-next cursor)
183
                         (declare (ignore v))
184
                         (if valid? 
185
                             (setf last-key k)
186
                             (setf continue nil))))))))))))
187
 
188
 
189
 (defmethod map-index-table (fn (bt rdb-indexed-btree))
190
   (maphash fn (index-cache-table bt)))
191
 
192
 (defmethod get-index ((bt rdb-indexed-btree) index-name)
193
   (gethash index-name (index-cache-table bt)))
194
 
195
 (defmethod remove-index ((bt rdb-indexed-btree) index-name)
196
   (remhash index-name (index-cache-table bt))
197
   (let ((index-table (index-table bt)))
198
     (remhash index-name index-table)
199
     (setf (index-table bt) index-table)))
200
 
201
 (defmethod (setf get-value) (value key (bt rdb-indexed-btree))
202
   "Set a key / value pair, and update secondary index-table."
203
   (let ((sc (get-store bt)))
204
     (let ((index-table (index-cache-table bt)))
205
       (with-static-streams ((key-buf) (value-buf) (secondary-buf))
206
         (write-oid (oid bt) key-buf)
207
         (ser key key-buf sc)
208
         (ser value value-buf sc)
209
         (ensure-transaction (:store sc)
210
           (db-put-buffered (btree sc)
211
                            key-buf value-buf
212
                            :transaction (current-transaction sc))
213
           ;; Manually write value into secondary index
214
           (loop for index being the hash-value of index-table
215
              do
216
              (multiple-value-bind (index? secondary-key)
217
                  (funcall (key-fn index) index key value)
218
                (when index?
219
                  ;; Insert
220
                  (write-oid (oid index) secondary-buf)
221
                  (ser secondary-key secondary-buf sc)
222
                  (db-put-buffered (index-table sc)
223
                                   secondary-buf key-buf
224
                                   :no-dup t
225
                                   :transaction (current-transaction sc))
226
                  (reset-static-stream secondary-buf))))
227
           value)))))
228
 
229
 (defmethod delete-key (key (bt rdb-indexed-btree) &key)
230
   "Remove a key / value pair, and update secondary index-table."
231
   (let ((sc (get-store bt)))
232
       (with-static-streams ((key-buf) (secondary-buf))
233
         (write-oid (oid bt) key-buf)
234
         (ser key key-buf sc)
235
         (ensure-transaction (:store sc)
236
           (let ((value (get-value key bt)))
237
             (when value
238
               (let ((index-table (index-cache-table bt)))
239
                 (loop 
240
                    for index being the hash-value of index-table
241
                    do
242
                    (multiple-value-bind (index? secondary-key)
243
                        (funcall (key-fn index) index key value)
244
                      (when index?
245
                        (write-oid (oid index) secondary-buf)
246
                        (ser secondary-key secondary-buf sc)
247
                        ;; need to remove kv pairs with a cursor! --
248
                        ;; this is a C performance hack
249
                        (db-delete-kv-buffered 
250
                         (index-table (get-store bt))
251
                         secondary-buf key-buf
252
                         :transaction (current-transaction sc))
253
                        (reset-static-stream secondary-buf))))
254
                 (db-delete-buffered (btree (get-store bt))
255
                                     key-buf
256
                                     :transaction (current-transaction sc)))))))))
257
 
258
 ;; This also needs to build the correct kind of index, and 
259
 ;; be the correct kind of btree...
260
 
261
 (defclass rdb-btree-index (btree-index rdb-btree)
262
   ()
263
   (:metaclass stored-class)
264
   (:documentation "A RDB-based BTree supports secondary index-table."))
265
 
266
 (defmethod get-value (key (bt rdb-btree-index))
267
   "Get the value in the primary DB from a secondary key."
268
   (let ((sc (get-store bt)))
269
     (with-static-streams ((key-buf) (value-buf))
270
       (write-oid (oid bt) key-buf)
271
       (ser key key-buf sc)
272
       (let ((buf (db-get-key-buffered 
273
                   (index-table-assoc sc)
274
                   key-buf value-buf
275
                   :transaction (current-transaction sc))))
276
         (if buf (values (deserialize buf sc) T)
277
             (values nil nil))))))
278
 
279
 (defmethod get-primary-key (key (bt btree-index))
280
   (let ((sc (get-store bt)))
281
     (with-static-streams ((key-buf) (value-buf))
282
       (write-oid (oid bt) key-buf)
283
       (ser key key-buf sc)
284
       (let ((buf (db-get-key-buffered 
285
                   (index-table sc)
286
                   key-buf value-buf
287
                   :transaction (current-transaction sc))))
288
         (if buf 
289
             (let ((oid (read-oid buf)))
290
               (values (deserialize buf sc) oid))
291
             (values nil nil))))))
292
 
293
 (defclass rdb-cursor (cursor)
294
   ((handle :accessor cursor-handle :initarg :handle))
295
   (:documentation "A cursor for traversing (primary) RDB-BTrees."))
296
 
297
 (defmethod make-cursor ((bt rdb-btree))
298
   "Make a cursor from a btree."
299
   (let ((sc (get-store bt)))
300
     (make-instance 'rdb-cursor 
301
                    :btree bt
302
                    :handle (db-cursor (btree sc)
303
                                       :transaction (current-transaction sc))
304
                    :oid (oid bt))))
305
 
306
 (defmethod cursor-close ((cursor rdb-cursor))
307
   (cursor-close (cursor-handle cursor))
308
   (setf (cursor-initialized-p cursor) nil))
309
 
310
 (defmethod cursor-duplicate ((cursor rdb-cursor))
311
   (make-instance (type-of cursor)
312
                  :initialized-p (cursor-initialized-p cursor)
313
                  :oid (cursor-oid cursor)
314
                  :handle (cursor-duplicate 
315
                           (cursor-handle cursor) 
316
                           :position (cursor-initialized-p cursor))))
317
 
318
 (defmethod cursor-current ((cursor rdb-cursor))
319
   (when (cursor-initialized-p cursor)
320
     (let ((sc (get-store (btree cursor))))
321
       (with-static-streams ((key-buf) (value-buf))
322
         (multiple-value-bind (key val)
323
             (cursor-move-buffered (cursor-handle cursor) key-buf value-buf
324
                                      :current t)
325
           (if (and key (= (read-oid key) (cursor-oid cursor)))
326
               (progn (setf (cursor-initialized-p cursor) t)
327
                      (values t (deserialize key sc)
328
                              (deserialize val sc)))
329
               (setf (cursor-initialized-p cursor) nil)))))))
330
 
331
 (defmethod cursor-first ((cursor rdb-cursor))
332
   (let ((sc (get-store (btree cursor))))
333
     (with-static-streams ((key-buf) (value-buf))
334
       (write-oid (cursor-oid cursor) key-buf)
335
       (multiple-value-bind (key val)
336
           (cursor-set-buffered (cursor-handle cursor) 
337
                                   key-buf value-buf :set-range t)
338
         (if (and key (= (read-oid key) (cursor-oid cursor)))
339
             (progn (setf (cursor-initialized-p cursor) t)
340
                    (values t 
341
                            (deserialize key sc)
342
                            (deserialize val sc)))
343
             (setf (cursor-initialized-p cursor) nil))))))
344
 
345
 (defmethod cursor-last ((cursor rdb-cursor))
346
   "A fast cursor last, but a bit 'hackish' by exploiting oid ordering"
347
   (let ((sc (get-store (btree cursor))))
348
   (with-static-streams ((key-buf) (value-buf))
349
     ;; Go to the first element of the next btree
350
     (write-oid (+ (cursor-oid cursor) 1) key-buf)
351
     (if (cursor-set-buffered (cursor-handle cursor)
352
                                 key-buf value-buf :set-range t)
353
         (progn (reset-static-stream key-buf)
354
                (reset-static-stream value-buf)
355
                (multiple-value-bind (key val)
356
                    (cursor-move-buffered (cursor-handle cursor) 
357
                                             key-buf value-buf :prev t)
358
                  (if (and key (= (read-oid key) (cursor-oid cursor)))
359
                      (progn
360
                        (setf (cursor-initialized-p cursor) t)
361
                        (values t (deserialize key sc)
362
                                  (deserialize val sc)))
363
                      (setf (cursor-initialized-p cursor) nil))))
364
         (multiple-value-bind (key val)
365
             (cursor-move-buffered (cursor-handle cursor) key-buf
366
                                      value-buf :last t)
367
           (if (and key (= (read-oid key) (cursor-oid cursor)))
368
               (progn
369
                 (setf (cursor-initialized-p cursor) t)
370
                 (values t (deserialize key sc)
371
                         (deserialize val sc )))
372
               (setf (cursor-initialized-p cursor) nil)))))))
373
 
374
 (defmethod cursor-next ((cursor rdb-cursor))
375
   (if (cursor-initialized-p cursor)
376
       (let ((sc (get-store (btree cursor))))
377
         (with-static-streams ((key-buf) (value-buf))
378
           (multiple-value-bind (key val)
379
               (the (values (or null static-stream)
380
                            (or null static-stream))
381
                 (cursor-move-buffered (cursor-handle cursor) 
382
                                          key-buf value-buf :next t))
383
             (if (and key (= (read-oid key) (cursor-oid cursor)))
384
                 (the (values t t t)
385
                   (values t (deserialize key sc)
386
                           (deserialize val sc)))
387
                 (the null (setf (cursor-initialized-p cursor) nil))))))
388
       (the t (cursor-first cursor))))
389
 
390
 (defmethod cursor-prev ((cursor rdb-cursor))
391
   (if (cursor-initialized-p cursor)
392
       (let ((sc (get-store (btree cursor))))
393
         (with-static-streams ((key-buf) (value-buf))
394
           (multiple-value-bind (key val)
395
               (cursor-move-buffered (cursor-handle cursor)
396
                                        key-buf value-buf :prev t)
397
             (if (and key (= (read-oid key) (cursor-oid cursor)))
398
                 (values t (deserialize key sc)
399
                         (deserialize val sc))
400
                 (setf (cursor-initialized-p cursor) nil)))))
401
       (cursor-last cursor)))
402
 
403
 (defmethod cursor-set ((cursor rdb-cursor) key)
404
   (let ((sc (get-store (btree cursor))))
405
   (with-static-streams ((key-buf) (value-buf))
406
     (write-oid (cursor-oid cursor) key-buf)
407
     (ser key key-buf sc)
408
     (multiple-value-bind (k val)
409
         (cursor-set-buffered (cursor-handle cursor)
410
                              key-buf value-buf :set t)
411
       (if k
412
           (progn
413
             (setf (cursor-initialized-p cursor) t)
414
             (values t key (deserialize val sc)))
415
           (setf (cursor-initialized-p cursor) nil))))))
416
 
417
 (defmethod cursor-set-range ((cursor rdb-cursor) key)
418
   (let ((sc (get-store (btree cursor))))
419
   (with-static-streams ((key-buf) (value-buf))
420
     (write-oid (cursor-oid cursor) key-buf)
421
     (ser key key-buf sc)
422
     (multiple-value-bind (k val)
423
         (cursor-set-buffered (cursor-handle cursor)
424
                                 key-buf value-buf :set-range t)
425
       (if (and k (= (read-oid k) (cursor-oid cursor)))
426
           (progn (setf (cursor-initialized-p cursor) t)
427
                  (values t (deserialize k sc)
428
                          (deserialize val sc)))
429
           (setf (cursor-initialized-p cursor) nil))))))
430
 
431
 (defmethod cursor-get-both ((cursor rdb-cursor) key value)
432
   (let ((sc (get-store (btree cursor))))
433
   (with-static-streams ((key-buf) (value-buf))
434
     (write-oid (cursor-oid cursor) key-buf)
435
     (ser key key-buf sc)
436
     (ser value value-buf sc)
437
     (multiple-value-bind (k v)
438
         (cursor-get-both-buffered (cursor-handle cursor)
439
                                      key-buf value-buf :get-both t)
440
       (declare (ignore v))
441
       (if k
442
           (progn (setf (cursor-initialized-p cursor) t)
443
                  (values t key value))
444
           (setf (cursor-initialized-p cursor) nil))))))
445
 
446
 (defmethod cursor-get-both-range ((cursor rdb-cursor) key value)
447
   (let ((sc (get-store (btree cursor))))
448
   (with-static-streams ((key-buf) (value-buf))
449
     (write-oid (cursor-oid cursor) key-buf)
450
     (ser key key-buf sc)
451
     (ser value value-buf sc)
452
     (multiple-value-bind (k v)
453
         (cursor-get-both-buffered (cursor-handle cursor)
454
                                      key-buf value-buf :get-both-range t)
455
       (if k
456
           (progn (setf (cursor-initialized-p cursor) t)
457
                  (values t key (deserialize v sc)))
458
           (setf (cursor-initialized-p cursor) nil))))))
459
 
460
 (defmethod cursor-delete ((cursor rdb-cursor))
461
   (if (cursor-initialized-p cursor)
462
       (with-static-streams ((key-buf) (value-buf))
463
         (multiple-value-bind (key val)
464
             (cursor-move-buffered (cursor-handle cursor) key-buf value-buf
465
                                      :current t)
466
           (declare (ignore val))
467
           (when (and key (= (read-oid key) (cursor-oid cursor)))
468
             ;; in case of a secondary index this should delete everything
469
             ;; as specified by the RDB docs.
470
             (delete-key (deserialize key (get-store (btree cursor)))
471
                        (btree cursor)))
472
           (setf (cursor-initialized-p cursor) nil)))
473
       (error "Can't delete with uninitialized cursor!")))
474
 
475
 (defmethod cursor-put ((cursor rdb-cursor) value &key (key nil key-specified-p))
476
   "Put by cursor.  Not particularly useful since standard btrees
477
    don't support duplicates.  Cursor is invalid after a put"
478
   (if key-specified-p
479
       (setf (get-value key (btree cursor)) value)
480
       (if (cursor-initialized-p cursor)
481
           (let ((sc (get-store (btree cursor))))
482
             (with-static-streams ((key-buf) (value-buf))
483
               (multiple-value-bind (k v)
484
                   (cursor-move-buffered (cursor-handle cursor) key-buf 
485
                                            value-buf :current t)
486
                 (declare (ignore v))
487
                 (if (and k (= (read-oid k) (cursor-oid cursor)))
488
                     (progn
489
                       (setf (get-value (deserialize k sc) (btree cursor))
490
                             value)
491
                       (reset-static-stream key-buf) (reset-static-stream value-buf)
492
                       (multiple-value-bind (k v)
493
                           (cursor-move-buffered (cursor-handle cursor) key-buf
494
                                                    value-buf :next t)
495
                         (if (and key (= (read-oid k) (cursor-oid cursor)))
496
                             (values t (deserialize k sc) (deserialize v sc))
497
                             (setf (cursor-initialized-p cursor) nil))))
498
                     (setf (cursor-initialized-p cursor) nil)))))
499
           (error "Can't put with uninitialized cursor!"))))
500
 
501
 ;; Secondary cursors
502
 
503
 (defclass rdb-secondary-cursor (secondary-cursor rdb-cursor) ()
504
   (:documentation "Cursor for traversing rdb secondary index-table."))
505
 
506
 (defmethod make-cursor ((bt rdb-btree-index))
507
   "Make a secondary-cursor from a secondary index."
508
   (let ((sc (get-store bt)))
509
     (make-instance 'rdb-secondary-cursor 
510
                    :btree bt
511
                    :handle (db-cursor (index-table-assoc sc)
512
                                       :transaction (current-transaction sc))
513
                    :oid (oid bt))))
514
 
515
 (defmethod cursor-pcurrent ((cursor rdb-secondary-cursor))
516
   (when (cursor-initialized-p cursor)
517
     (with-static-streams ((key-buf) (pkey-buf) (value-buf))
518
       (multiple-value-bind (key pkey val)
519
           (db-cursor-pmove-buffered (cursor-handle cursor)
520
                                     key-buf pkey-buf value-buf
521
                                     :current t)
522
         (if (and key (= (read-oid key) (cursor-oid cursor)))
523
             (progn (setf (cursor-initialized-p cursor) t)
524
                    (let ((sc (get-store (btree cursor))))
525
                      (values t 
526
                              (deserialize key sc)
527
                              (deserialize val sc)
528
                              (progn (read-oid pkey) (deserialize pkey sc)))))
529
             (setf (cursor-initialized-p cursor) nil))))))
530
 
531
 (defmethod cursor-pfirst ((cursor rdb-secondary-cursor))
532
   (with-static-streams ((key-buf) (pkey-buf) (value-buf))
533
     (write-oid (cursor-oid cursor) key-buf)
534
     (multiple-value-bind (key pkey val)
535
         (db-cursor-pset-buffered (cursor-handle cursor) 
536
                                  key-buf pkey-buf value-buf :set-range t)
537
       (if (and key (= (read-oid key) (cursor-oid cursor)))
538
           (progn (setf (cursor-initialized-p cursor) t)
539
                  (let ((sc (get-store (btree cursor))))
540
                  (values t 
541
                          (deserialize key sc)
542
                          (deserialize val sc)
543
                          (progn (read-oid pkey) (deserialize pkey sc)))))
544
           (setf (cursor-initialized-p cursor) nil)))))
545
 
546
 ;; A bit of a hack.....
547
 (defmethod cursor-plast ((cursor rdb-secondary-cursor))
548
   (let ((sc (get-store (btree cursor))))
549
   (with-static-streams ((key-buf) (pkey-buf) (value-buf))
550
     (write-oid (+ (cursor-oid cursor) 1) key-buf)
551
     (if (db-cursor-set-buffered (cursor-handle cursor) 
552
                                 key-buf value-buf :set-range t)    
553
         (progn (reset-static-stream key-buf)
554
                (reset-static-stream value-buf)
555
                (multiple-value-bind (key pkey val)
556
                    (db-cursor-pmove-buffered (cursor-handle cursor) key-buf 
557
                                              pkey-buf value-buf :prev t)
558
                  (if (and key (= (read-oid key) (cursor-oid cursor)))
559
                      (progn
560
                        (setf (cursor-initialized-p cursor) t)
561
                        (values t 
562
                                (deserialize key sc)
563
                                (deserialize val sc)
564
                                (progn (read-oid pkey) 
565
                                       (deserialize pkey sc))))
566
                      (setf (cursor-initialized-p cursor) nil))))
567
         (multiple-value-bind (key pkey val)
568
             (db-cursor-pmove-buffered (cursor-handle cursor) key-buf
569
                                       pkey-buf value-buf :last t)
570
           (if (and key (= (read-oid key) (cursor-oid cursor)))
571
               (progn
572
                 (setf (cursor-initialized-p cursor) t)
573
                 (values t (deserialize key sc)
574
                         (deserialize val sc)
575
                         (progn (read-oid pkey) (deserialize pkey sc))))
576
               (setf (cursor-initialized-p cursor) nil)))))))
577
 
578
 (defmethod cursor-pnext ((cursor rdb-secondary-cursor))
579
   (if (cursor-initialized-p cursor)
580
       (with-static-streams ((key-buf) (pkey-buf) (value-buf))
581
         (multiple-value-bind (key pkey val)
582
             (db-cursor-pmove-buffered (cursor-handle cursor) 
583
                                      key-buf pkey-buf value-buf :next t)
584
           (if (and key (= (read-oid key) (cursor-oid cursor)))
585
               (let ((sc (get-store (btree cursor))))
586
                 (values t (deserialize key sc)
587
                         (deserialize val sc)
588
                         (progn (read-oid pkey) (deserialize pkey sc))))
589
               (setf (cursor-initialized-p cursor) nil))))
590
       (cursor-pfirst cursor)))
591
 
592
 (defmethod cursor-pprev ((cursor rdb-secondary-cursor))
593
   (if (cursor-initialized-p cursor)
594
       (with-static-streams ((key-buf) (pkey-buf) (value-buf))
595
         (multiple-value-bind (key pkey val)
596
             (db-cursor-pmove-buffered (cursor-handle cursor)
597
                                       key-buf pkey-buf value-buf :prev t)
598
           (if (and key (= (read-oid key) (cursor-oid cursor)))
599
               (let ((sc (get-store (btree cursor))))
600
                 (values t (deserialize key sc)
601
                         (deserialize val sc)
602
                         (progn (read-oid pkey) (deserialize pkey sc))))
603
               (setf (cursor-initialized-p cursor) nil))))
604
       (cursor-plast cursor)))
605
 
606
 (defmethod cursor-pset ((cursor rdb-secondary-cursor) key)
607
   (let ((sc (get-store (btree cursor))))
608
     (with-static-streams ((key-buf) (pkey-buf) (value-buf))
609
       (write-oid (cursor-oid cursor) key-buf)
610
       (ser key key-buf sc)
611
       (multiple-value-bind (k pkey val)
612
           (db-cursor-pset-buffered (cursor-handle cursor)
613
                                    key-buf pkey-buf value-buf :set t)
614
         (if k
615
             (progn
616
               (setf (cursor-initialized-p cursor) t)
617
               (values t key (deserialize val sc)
618
                       (progn (read-oid pkey) 
619
                              (deserialize pkey sc))))
620
             (setf (cursor-initialized-p cursor) nil))))))
621
 
622
 (defmethod cursor-pset-range ((cursor rdb-secondary-cursor) key)
623
   (let ((sc (get-store (btree cursor))))
624
     (with-static-streams ((key-buf) (pkey-buf) (value-buf))
625
       (write-oid (cursor-oid cursor) key-buf)
626
       (ser key key-buf sc)
627
       (multiple-value-bind (k pkey val)
628
           (db-cursor-pset-buffered (cursor-handle cursor)
629
                                    key-buf pkey-buf value-buf :set-range t)
630
         (if (and k (= (read-oid k) (cursor-oid cursor)))
631
             (progn (setf (cursor-initialized-p cursor) t)
632
                    (values t (deserialize k sc)
633
                            (deserialize val sc)
634
                            (progn (read-oid pkey) (deserialize pkey sc))))
635
             (setf (cursor-initialized-p cursor) nil))))))
636
 
637
 (defmethod cursor-pget-both ((cursor rdb-secondary-cursor) key pkey)
638
   (with-static-streams ((key-buf) (pkey-buf) (value-buf))
639
     (let ((primary-oid (oid (primary (btree cursor))))
640
           (sc (get-store (btree cursor))))
641
       (write-oid (cursor-oid cursor) key-buf)
642
       (ser key key-buf sc)
643
       (write-oid primary-oid pkey-buf)
644
       (ser pkey pkey-buf sc)
645
       (multiple-value-bind (k p val)
646
           (db-cursor-pget-both-buffered (cursor-handle cursor)
647
                                         key-buf pkey-buf value-buf :get-both t)
648
         (declare (ignore p))
649
         (if k
650
             (progn (setf (cursor-initialized-p cursor) t)
651
                    (values t key (deserialize val sc) pkey))
652
             (setf (cursor-initialized-p cursor) nil))))))
653
 
654
 (defmethod cursor-pget-both-range ((cursor rdb-secondary-cursor) key pkey)
655
   (with-static-streams ((key-buf) (pkey-buf) (value-buf))
656
     (let ((primary-oid (oid (primary (btree cursor))))
657
           (sc (get-store (btree cursor))))
658
       (write-oid (cursor-oid cursor) key-buf)
659
       (ser key key-buf sc)
660
       (write-oid primary-oid pkey-buf)
661
       (ser pkey pkey-buf sc)
662
       (multiple-value-bind (k p val)
663
           (db-cursor-pget-both-buffered (cursor-handle cursor) key-buf 
664
                                         pkey-buf value-buf :get-both-range t)
665
         (if k
666
             (progn (setf (cursor-initialized-p cursor) t)
667
                    (values t key (deserialize val sc)
668
                            (progn (read-oid p) (deserialize p sc))))
669
             (setf (cursor-initialized-p cursor) nil))))))
670
 
671
 (defmethod cursor-delete ((cursor rdb-secondary-cursor))
672
   "Delete by cursor: deletes ALL secondary index values."
673
   (if (cursor-initialized-p cursor)
674
       (with-static-streams ((key-buf) (pkey-buf) (value-buf))
675
         (multiple-value-bind (key pkey val)
676
             (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf
677
                                       value-buf :current t)
678
           (declare (ignore val))
679
           (when (and key (= (read-oid key) (cursor-oid cursor))
680
                      (= (read-oid pkey) (oid (primary
681
                                                      (btree cursor)))))
682
             (delete-key (deserialize pkey (get-store (btree cursor)))
683
                        (primary (btree cursor))))
684
           (setf (cursor-initialized-p cursor) nil)))
685
       (error "Can't delete with uninitialized cursor!")))
686
 
687
 (defmethod cursor-next-dup ((cursor rdb-secondary-cursor))
688
   (when (cursor-initialized-p cursor)
689
     (with-static-streams ((key-buf) (value-buf))
690
       (multiple-value-bind (key val)
691
           (db-cursor-move-buffered (cursor-handle cursor)
692
                                    key-buf value-buf :next-dup t)
693
         (if (and key (= (read-oid key) (cursor-oid cursor)))
694
             (values t (deserialize key (get-store (btree cursor))) 
695
                     (deserialize val (get-store (btree cursor))))
696
             (setf (cursor-initialized-p cursor) nil))))))
697
 
698
 (defmethod cursor-next-nodup ((cursor rdb-secondary-cursor))
699
   (if (cursor-initialized-p cursor)
700
       (with-static-streams ((key-buf) (value-buf))
701
         (multiple-value-bind (key val)
702
             (db-cursor-move-buffered (cursor-handle cursor)
703
                                      key-buf value-buf :next-nodup t)
704
           (if (and key (= (read-oid key) (cursor-oid cursor)))
705
               (values t (deserialize key (get-store (btree cursor))) 
706
                       (deserialize val (get-store (btree cursor))))
707
               (setf (cursor-initialized-p cursor) nil))))
708
       (cursor-first cursor)))
709
 
710
 (defmethod cursor-prev-nodup ((cursor rdb-secondary-cursor))
711
   (if (cursor-initialized-p cursor)
712
       (with-static-streams ((key-buf) (value-buf))
713
         (multiple-value-bind (key val)
714
           (the (values (or null static-stream) 
715
                        (or null static-stream))
716
             (db-cursor-move-buffered (cursor-handle cursor)
717
                                      key-buf value-buf :prev-nodup t))
718
           (if (and key (= (read-oid key) (cursor-oid cursor)))
719
               (values t (deserialize key (get-store (btree cursor))) 
720
                       (deserialize val (get-store (btree cursor))))
721
               (setf (cursor-initialized-p cursor) nil))))
722
       (cursor-last cursor)))
723
 
724
 (defmethod cursor-pnext-dup ((cursor rdb-secondary-cursor))
725
   (when (cursor-initialized-p cursor)
726
     (with-static-streams ((key-buf) (pkey-buf) (value-buf))
727
       (multiple-value-bind (key pkey val)
728
           (the (values (or null static-stream) 
729
                        (or null static-stream)
730
                        (or null static-stream))
731
             (db-cursor-pmove-buffered (cursor-handle cursor)
732
                                     key-buf pkey-buf value-buf :next-dup t))
733
         (if (and key (= (read-oid key) (cursor-oid cursor)))
734
             (the (values t t t t)
735
               (values t (deserialize key (get-store (btree cursor)))
736
                       (deserialize val (get-store (btree cursor)))
737
                       (progn (read-oid pkey) (deserialize pkey (get-store (btree cursor))))))
738
             (the null (setf (cursor-initialized-p cursor) nil)))))))
739
 
740
 (defmethod cursor-pnext-nodup ((cursor rdb-secondary-cursor))
741
   (if (cursor-initialized-p cursor)
742
       (with-static-streams ((key-buf) (pkey-buf) (value-buf))
743
         (multiple-value-bind (key pkey val)
744
             (db-cursor-pmove-buffered (cursor-handle cursor) key-buf
745
                                       pkey-buf value-buf :next-nodup t)
746
           (if (and key (= (read-oid key) (cursor-oid cursor)))
747
               (values t (deserialize key (get-store (btree cursor))) 
748
                       (deserialize val (get-store (btree cursor)))
749
                       (progn (read-oid pkey) (deserialize pkey (get-store (btree cursor)))))
750
               (setf (cursor-initialized-p cursor) nil))))
751
       (cursor-pfirst cursor)))
752
 
753
 (defmethod cursor-pprev-nodup ((cursor rdb-secondary-cursor))
754
   (if (cursor-initialized-p cursor)
755
       (with-static-streams ((key-buf) (pkey-buf) (value-buf))
756
         (multiple-value-bind (key pkey val)
757
             (db-cursor-pmove-buffered (cursor-handle cursor) key-buf
758
                                       pkey-buf value-buf :prev-nodup t)
759
           (if (and key (= (read-oid key) (cursor-oid cursor)))
760
               (values t (deserialize key (get-store (btree cursor)))
761
                       (deserialize val (get-store (btree cursor)))
762
                       (progn (read-oid pkey)
763
                              (deserialize pkey (get-store (btree cursor)))))
764
               (setf (cursor-initialized-p cursor) nil))))
765
       (cursor-plast cursor)))
766
 
767
 
768
 ;; Duplicated btrees
769
 
770
 (defclass rdb-dup-btree (dup-btree rdb-btree) ()
771
 ;;  (:metaclass persistent-metaclass)
772
   (:documentation "A RocksDB implementation of the duplicate btree"))
773
 
774
 (defmethod build-dup-btree ((sc rdb-store))
775
   (make-instance 'rdb-dup-btree :store sc))
776
 
777
 (defmethod get-value (key (bt rdb-dup-btree))
778
   (let ((sc (get-store bt)))
779
     (with-static-streams ((key-buf) (value-buf))
780
       (write-oid (oid bt) key-buf)
781
       (ser key key-buf sc)
782
       (let ((buf (db-get-key-buffered (dup-btrees sc)
783
                                       key-buf value-buf
784
                                       :transaction (current-transaction sc))))
785
         (if buf (values (deserialize buf sc) T)
786
             (values nil nil))))))
787
 
788
 (defmethod existsp (key (bt rdb-dup-btree))
789
   (let ((sc (get-store bt)))
790
     (with-static-streams ((key-buf) (value-buf))
791
       (write-oid (oid bt) key-buf)
792
       (ser key key-buf sc)
793
       (let ((buf (db-get-key-buffered 
794
                   (dup-btrees sc)
795
                   key-buf value-buf
796
                   :transaction (current-transaction sc))))
797
         (if buf t
798
             nil)))))
799
 
800
 ;; This is the only difference with the rdb-btree -- I think that means 
801
 ;; the other methods can be removed.
802
 (defmethod (setf get-value) (value key (bt rdb-dup-btree))
803
     (let ((sc (get-store bt)))
804
       (with-static-streams ((key-buf) (value-buf))
805
         (write-oid (oid bt) key-buf)
806
         (ser key key-buf sc)
807
         (ser value value-buf sc)
808
         (db-put-buffered (dup-btrees sc)
809
                          key-buf value-buf
810
                          :transaction (current-transaction sc)
811
                          :no-dup t)))
812
     value)
813
 
814
 (defmethod delete-key (key (bt rdb-dup-btree) &key)
815
   (let ((sc (get-store bt)) )
816
     (with-static-stream (key-buf)
817
       (write-oid (oid bt) key-buf)
818
       (ser key key-buf sc)
819
       (db-delete-buffered (dup-btrees sc) key-buf 
820
                           :transaction (current-transaction sc)))))
821
 
822
 (defclass rdb-dup-cursor (rdb-cursor) ()
823
   (:documentation "Cursor for traversing rdb secondary index-table."))
824
 
825
 (defmethod make-cursor ((bt rdb-dup-btree))
826
   "Make a secondary-cursor from a secondary index."
827
   (let ((sc (get-store bt)))
828
     (make-instance 'rdb-dup-cursor
829
                    :btree bt
830
                    :handle (db-cursor (dup-btrees sc)
831
                                       :transaction (current-transaction sc))
832
                    :oid (oid bt))))
833
 
834
 (defmethod cursor-next-nodup ((cursor rdb-dup-cursor))
835
   (if (cursor-initialized-p cursor)
836
       (with-static-streams ((key-buf) (value-buf))
837
         (multiple-value-bind (key val)
838
             (db-cursor-move-buffered (cursor-handle cursor)
839
                                      key-buf value-buf :next-nodup t)
840
           (if (and key (= (read-oid key) (cursor-oid cursor)))
841
               (values t (deserialize key (get-store (btree cursor))) 
842
                       (deserialize val (get-store (btree cursor))))
843
               (setf (cursor-initialized-p cursor) nil))))
844
       (cursor-first cursor)))
845
 
846
 (defmethod cursor-delete ((cursor rdb-dup-cursor))
847
   (if (cursor-initialized-p cursor)
848
       (progn (db-cursor-delete (cursor-handle cursor))
849
              (setf (cursor-initialized-p cursor) nil))
850
       (error "Can't delete with uninitialized cursor!")))
851
 
852
 (defmethod open-store ((store rdb-store) &key (recover t)
853
                                               register
854
                                               log)
855
   (if (db-open-p store)
856
       (progn
857
         (log:warn! "Database is already open: ~A" store)
858
         store)
859
       (with-db (db :db store :open t :close :auto)
860
         (if (probe-file (name store))
861
             (progn
862
               (load-opts db)
863
               (open-columns* db)
864
               store)
865
             store))))
866
 
867
 (defmethod close-store ((store rdb-store))
868
   "Close the underlying RocksDB instance."
869
   (close-db store))
870
 
871
 ;; 0-15 reserved cuz why not
872
 (defvar *rdb-oid* 15)
873
 (defvar *rdb-cid* 15)
874
 
875
 (defmethod next-oid ((self rdb-store))
876
   (incf *rdb-oid*))
877
 
878
 (defmethod next-cid ((self rdb-store))
879
   (incf *rdb-cid*))
880
 
881
 (defmethod default-class-id (type (sc rdb-store))
882
   (ecase type
883
     (rdb-btree 1)
884
     (rdb-dup-btree 2)
885
     (rdb-indexed-btree 3)
886
     (rdb-btree-index 4)))
887
 
888
 (defmethod default-class-id-type (cid (sc rdb-store))
889
   (case cid
890
     (1 'rdb-btree)
891
     (2 'rdb-dup-btree)
892
     (3 'rdb-indexed-btree)
893
     (4 'rdb-btree-index)))
894
 
895
 (defmethod reserved-oid-p ((sc rdb-store) oid)
896
   (< oid 16))
897
 
898
 ;;; slot protocol
899
 ;; TODO 2024-11-07:
900
 (defmethod stored-slot-reader ((self rdb-store) instance name &optional oids-only)
901
   (declare (ignore oids-only))
902
   (with-alien ((oid (* unsigned-char) (make-alien unsigned-char 4)))
903
     (std/alien::write-alien-unsigned-byte-64 oid (the (unsigned-byte 64) (oid instance)))
904
     (serde (cons name oid) self)
905
     (let ((ret (get-val (db self) oid)))
906
       (ensure-transaction (:store self)
907
         ret))))
908
 
909
 (defmethod stored-slot-writer ((self rdb-store) new-value instance name)
910
   (ensure-transaction (:store self)))
911
 
912
 (defmethod stored-slot-boundp ((self rdb-store) instance name)
913
   (ensure-transaction (:store self)))
914
 
915
 (defmethod stored-slot-makunbound ((self rdb-store) instance name)
916
   (ensure-transaction (:store self)))
917
 
918
 ;;; Transactions
919
 (defmethod execute-transaction ((self rdb-store) txn
920
                                 &key
921
                                 transaction parent))