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

Kind	Covered	All	%
expression	38	641	5.9
branch	6	74	8.1

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj/meta/stored.lisp --- CLOS Stored Metaclasses

2

3

;; The stored-class can be assigned to the :metaclass option of a

4

;; class to allow persistent storage of an object on disk. The

5

;; stored-slot-definition is a custom slot option which can be used to

6

;; selectively enable slot serialization.

7

8

;;; Commentary:

9

10

;; This code is derived from XDB.

11

12

;; Note that this is not a general purpose SerDe. It is specifically designed

13

;; to decode/encode objects as simple octet-vectors from/to an open stream

14

;; with minimal overhead. There is a separate interface for general-purpose

15

;; data encoding which can be found in the DAT system.

16

17

;;; Code:

18

(in-package :obj/meta/stored)

19

20

(defvar *default-store* nil)

21

22

(deftype oid () 'word)

23

(deftype cid () '(unsigned-byte 32))

24

25

;;; MOP

26

(defclass stored ()

27

((oid :initarg :oid :accessor oid)

28

(spec :accessor spec :initarg :spec

29

:documentation "Stored objects use a spec pointer to identify which store

30

they are connected to"))

31

(:documentation "Slots which are implicitly bound to all STORED-CLASS metaobjects."))

32

33

(defmethod print-object ((obj stored) stream)

34

"This is useful for debugging and being clear about what is stored and what is

35

not."

36

(format stream "#<~A oid:~A>" (type-of obj) (when (slot-boundp obj 'oid) (oid obj))))

37

38

(defun write-oid (i bs) (write-sequence (integer-to-octets i 32) bs))

39

40

(defun read-oid (bs)

41

(octets-to-integer

42

(coerce

43

'octet-vector

44

(loop for i below 4

45

collect (read-byte bs)))))

46

47

(defclass stored-collection (stored) ()

48

(:documentation "Abstract superclass of all STORED collection types."))

49

50

(defgeneric drop-instance (stored-object)

51

(:documentation "drop-instance reclaims stored object storage by unbinding

52

all stored slot values. It can also helps catch errors where an object

53

should be unreachable, but a reference still exists elsewhere in the DB. On

54

access, the unbound slots should flag an error in the application

55

program. IMPORTANT: this function does not clear any serialized references

56

still in the db. Need a migration or GC for that! drop-instances is the

57

user-facing call as it implements the proper behavior for indexed classes."))

58

59

(defgeneric get-store (self)

60

(:documentation "Get the store associated with SELF. We prefix this accessor with GET- because

61

STORE is reserved for a special method which operates on stored objects.")

62

(:method ((self t))

63

*default-store*))

64

65

(defgeneric stored-slot-reader (sc instance name &optional oids-only)

66

(:documentation

67

"Store-specific slot reader function"))

68

69

(defgeneric stored-slot-writer (sc new-value instance name)

70

(:documentation

71

"Store-specific slot writer function"))

72

73

(defgeneric stored-slot-boundp (sc instance name)

74

(:documentation

75

"Store-specific slot bound test function"))

76

77

(defgeneric stored-slot-makunbound (sc instance name)

78

(:documentation

79

"Store-specific slot makunbound handler"))

80

81

(defgeneric register-instance (self class instance))

82

(defgeneric cache-instance (self obj))

83

(defgeneric get-cached-instance (self oid))

84

(defgeneric uncache-instance (self oid))

85

(defgeneric flush-instance-cache (self))

86

87

(defclass stored-class (standard-class)

88

((%class-schema :accessor %class-schema :initarg :schemas :initform nil)

89

(%store-schemas :accessor %store-schemas :initarg :store-schemas :initform nil)

90

(%class-indexing :accessor %class-indexing :initarg :index :initform t)

91

(%cache-style :accessor %cache-style :initarg :cache-style :initform nil))

92

(:documentation "Superclass for all stored objects."))

93

94

(defmethod get-class-schema (self) (slot-value self '%class-schema))

95

(defmethod set-class-schema (self value)

96

(setf (slot-value self '%class-schema) value))

97

(defsetf get-class-schema set-class-schema)

98

99

(defmethod get-store-schemas (self) (slot-value self '%store-schemas))

100

(defmethod set-store-schemas (self value)

101

(setf (slot-value self '%store-schemas) value))

102

(defsetf get-store-schemas set-store-schemas)

103

104

(defmethod get-class-indexing (self) (slot-value self '%class-indexing))

105

(defsetf get-class-indexing (self) (value)

106

`(setf (slot-value ,self '%class-indexing) ,value))

107

108

(defmethod get-cache-style (self) (slot-value self '%cache-style))

109

(defsetf get-cache-style (self) (value)

110

`(setf (slot-value ,self '%cache-style) ,value))

111

112

(defmethod class-indexing-enabled-p ((class stored-class))

113

(and (not (subtypep (class-name class) 'stored-collection))

114

(get-class-indexing class)))

115

116

(defun migrate-class-index-p (class)

117

(get-class-indexing class))

118

119

(defmethod has-class-schema-p ((class stored-class))

120

(and (get-class-schema class)

121

(eq (class-name (class-of (get-class-schema class)))

122

'stored-schema)))

123

124

(defmethod find-slot-defs-by-type ((class stored-class) type &optional (by-subtype t))

125

(let ((slot-defs (class-slots class)))

126

(loop for slot-def in slot-defs

127

when (if by-subtype

128

(subtypep (type-of slot-def) type)

129

(eq (type-of slot-def) type))

130

collect slot-def)))

131

132

(defmethod find-slot-def-names-by-type ((class stored-class) type &optional (by-subtype t))

133

(mapcar #'slot-definition-name

134

(find-slot-defs-by-type class type by-subtype)))

135

136

;;; Validate

137

(defmethod validate-superclass

138

((class standard-class)

139

(superclass stored-class))

140

nil)

141

142

(defmethod validate-superclass

143

((class stored-class)

144

(superclass standard-class))

145

t)

146

147

(defclass stored-object (stored) ()

148

(:metaclass stored-class)

149

(:documentation

150

"Superclass for all user-defined stored classes. This is

151

automatically inherited if you use the STORED-CLASS

152

metaclass."))

153

154

;;; Slot mixin

155

(defclass stored-slot-definition (standard-slot-definition)

156

((stored-p :initarg :stored

157

:initform t

158

:accessor stored-p)))

159

160

(defgeneric stored-p (mclass)

161

(:method ((mclass t)) nil)

162

(:method ((mclass stored-class)) t)

163

(:method ((mclass stored-slot-definition)) t))

164

165

(defclass stored-direct-slot-definition (stored-slot-definition standard-direct-slot-definition)

166

())

167

168

(defclass stored-effective-slot-definition (stored-slot-definition standard-effective-slot-definition)

169

())

170

171

(defmethod direct-slot-definition-class ((class stored-class)

172

&rest initargs)

173

(declare (ignore initargs))

174

(find-class 'stored-direct-slot-definition))

175

176

(defmethod effective-slot-definition-class ((class stored-class)

177

&key &allow-other-keys)

178

(find-class 'stored-effective-slot-definition))

179

180

(defmethod compute-effective-slot-definition

181

((class stored-class) slot-name direct-definitions)

182

(declare (ignore slot-name))

183

(let ((effective-definition (call-next-method))

184

(direct-definition (car direct-definitions)))

185

(setf (stored-p effective-definition)

186

(stored-p direct-definition))

187

effective-definition))

188

189

(defun make-slots-cache (slot-definitions)

190

(map 'vector

191

(lambda (slot-definition)

192

(cons (slot-definition-location slot-definition)

193

(slot-definition-initform slot-definition)))

194

slot-definitions))

195

196

(defun stored-slot-defs (class)

197

(find-slot-defs-by-type class 'stored-effective-slot-definition nil))

198

199

(defun stored-slot-names (class)

200

(find-slot-def-names-by-type class 'stored-effective-slot-definition nil))

201

202

(defun all-stored-slot-names (class)

203

(append (find-slot-def-names-by-type class 'stored-effective-slot-definition t)

204

(find-slot-def-names-by-type class 'cached-effective-slot-definition t)))

205

206

(defun all-single-valued-slot-defs (class)

207

(append (stored-slot-defs class)

208

(cached-slot-defs class)

209

(indexed-slot-defs class)))

210

211

;;; From Elephant - for future development

212

(defclass cached-slot-definition (standard-slot-definition)

213

((cache :accessor cached-slot-p :initarg :cached)))

214

215

(defclass cached-direct-slot-definition (standard-direct-slot-definition cached-slot-definition)

216

())

217

218

(defclass cached-effective-slot-definition (standard-effective-slot-definition cached-slot-definition)

219

((triggers :accessor derived-slot-triggers :initarg :trigger :initform nil)))

220

221

(defun cached-slot-defs (class)

222

(find-slot-defs-by-type class 'cached-effective-slot-definition nil))

223

224

(defun cached-slot-names (class)

225

(find-slot-def-names-by-type class 'cached-effective-slot-definition nil))

226

227

;;; Transient Slots

228

(defclass transient-slot-definition (standard-slot-definition)

229

((transient :initform t :initarg :transient :allocation :class)))

230

231

(defclass transient-direct-slot-definition (standard-direct-slot-definition transient-slot-definition)

232

())

233

234

(defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition)

235

())

236

237

(defgeneric transient-p (slot)

238

(:method ((slot standard-slot-definition)) t)

239

(:method ((slot transient-slot-definition)) t)

240

(:method ((slot cached-slot-definition)) nil)

241

(:method ((slot stored-slot-definition)) nil))

242

243

(defun ensure-transient-chain (slot-definitions initargs)

244

(declare (ignore initargs))

245

(loop for slot-definition in slot-definitions

246

always (transient-p slot-definition)))

247

248

(defun transient-slot-defs (class)

249

(let ((slot-definitions (class-slots class)))

250

(loop for slot-def in slot-definitions

251

when (transient-p slot-def)

252

collect slot-def)))

253

254

(defun transient-slot-names (class)

255

(mapcar #'slot-definition-name (transient-slot-defs class)))

256

257

(defgeneric database-allocation-p (class)

258

(:method ((class t)) nil)

259

(:method ((class stored-class)) t)

260

(:method ((class stored-slot-definition)) t))

261

262

(defmethod slot-definition-allocation ((slot-definition stored-slot-definition))

263

:database)

264

265

;;; Indexed Slots

266

(defclass indexed-slot-definition (stored-slot-definition)

267

((indexed :accessor indexed-p :initarg :indexed :initarg :index :initform nil :allocation :instance)

268

(inherit :accessor inherit-p :initarg :inherit :initform nil :allocation :instance)))

269

270

(defclass indexed-direct-slot-definition (stored-direct-slot-definition indexed-slot-definition)

271

())

272

273

(defclass indexed-effective-slot-definition (stored-effective-slot-definition indexed-slot-definition)

274

((indices :accessor indexed-slot-indices :initform nil :allocation :instance

275

:documentation "Alist of actual indices by store")

276

(base-class :accessor indexed-slot-base :initarg :base-class :allocation :instance

277

:documentation "The base class to use as an index")))

278

279

(defmethod indexed-p (def)

280

(declare (ignore def))

281

nil)

282

283

(defmethod get-slot-def-index ((def indexed-effective-slot-definition) sc)

284

(awhen (assoc sc (indexed-slot-indices def))

285

(cdr it)))

286

287

(defmethod add-slot-def-index (idx (def indexed-effective-slot-definition) sc)

288

(setf (indexed-slot-indices def)

289

(acons sc idx (indexed-slot-indices def))))

290

291

(defmethod clear-slot-def-index ((def indexed-effective-slot-definition) sc)

292

(setf (indexed-slot-indices def)

293

(remove sc (indexed-slot-indices def) :key #'car)))

294

295

(defmethod indexed-slot-defs (class)

296

(find-slot-def-names-by-type class 'indexed-effective-slot-definition nil))

297

298

(defmethod indexed-slot-names (class)

299

(find-slot-def-names-by-type class 'indexed-effective-slot-definition nil))

300

301

(defclass derived-index-slot-definition (indexed-slot-definition)

302

((derived-fn-ref :accessor derived-fn-ref :initarg :derived-fn)

303

(slot-deps :accessor derived-slot-deps :initarg :slot-deps :initarg :slot-dependencies :initform nil)))

304

305

(defclass derived-index-direct-slot-definition (indexed-direct-slot-definition derived-index-slot-definition)

306

())

307

308

(defclass derived-index-effective-slot-definition (indexed-effective-slot-definition derived-index-slot-definition)

309

((fn :accessor derived-fn :initarg :fn)))

310

311

(defmethod derived-index-slot-defs (class)

312

(find-slot-defs-by-type class 'derived-index-effective-slot-definition nil))

313

314

(defmethod derived-index-slot-names (class)

315

(find-slot-def-names-by-type class 'derived-index-effective-slot-definition nil))

316

317

(defun compile-derived-fn (ref)

318

(if (symbolp ref)

319

(handler-case

320

(and (functionp (symbol-function ref))

321

(gen-derived-fn-wrapper (compile ref)))

322

         (undefined-function (ref) (error "~A does not appear to be a valid function reference" ref)))

323

(if (listp ref)

324

(gen-derived-fn-wrapper (compile nil (eval ref)))

325

(error "~A does not appear to be a valid function expression" ref))))

326

327

(defun gen-derived-sym-wrapper (symbol-fn)

328

"Return a closure to handle errors in the derived index function"

329

(lambda (inst)

330

(handler-case

331

(funcall (symbol-function symbol-fn) inst)

332

(unbound-slot ()

333

(values nil nil))

334

(error (e)

335

(cerror "Ignoring?"

336

"error ~A while computing derived value for ~A"

337

e inst)

338

(values nil nil)))))

339

340

(defun gen-derived-fn-wrapper (compiled)

341

"Return a closure to handle errors in the derived index function"

342

(lambda (inst)

343

(handler-case

344

(funcall compiled inst)

345

(unbound-slot ()

346

(values nil nil))

347

(error (e)

348

(cerror "Ignoring?"

349

"error ~A while computing derived value for ~A"

350

e inst)

351

(values nil nil)))))

352

353

(defclass set-valued-slot-definition (stored-slot-definition)

354

((set-valued-p :accessor set-valued-p :initarg :set-valued :allocation :instance)))

355

356

(defclass set-valued-direct-slot-definition (stored-direct-slot-definition set-valued-slot-definition)

357

())

358

359

(defclass set-valued-effective-slot-definition (stored-effective-slot-definition set-valued-slot-definition)

360

())

361

362

(defun set-valued-slot-defs (class)

363

(find-slot-defs-by-type class 'set-valued-effective-slot-definition nil))

364

365

(defun set-valued-slot-names (class)

366

(find-slot-def-names-by-type class 'set-valued-effective-slot-definition nil))

367

368

(defclass association-slot-definition (stored-slot-definition)

369

((assoc :accessor association :initarg :associate :allocation :instance)

370

(inherit :accessor inherit-p :initarg :inherit :initform nil :allocation :instance)

371

(m2m :accessor many-to-many-p :initarg :many-to-many :initform nil :allocation :instance)))

372

373

(defclass association-direct-slot-definition (stored-direct-slot-definition association-slot-definition)

374

())

375

376

(defclass association-effective-slot-definition (stored-effective-slot-definition association-slot-definition)

377

((type :accessor association-type :initarg :association-type)

378

(base-class :accessor association-slot-base :initarg :base-class :allocation :instance

379

:documentation "The base class to use as an index")

380

(indices :accessor association-slot-indices :initform nil

381

:documentation "Alist of actual indices by store")

382

(classname :accessor foreign-classname :initarg :foreign-classname)

383

(slotname :accessor foreign-slotname :initarg :foreign-slotname)

384

(class :accessor foreign-class :initarg :foreign-class :initform nil

385

:documentation "Direct pointer to foreign class; late binding")))

386

387

(defmethod initialize-instance :after ((slot-def association-effective-slot-definition) &rest args)

388

(declare (ignore args))

389

(let ((assoc (association slot-def)))

390

(cond ((symbolp assoc)

391

(when (many-to-many-p slot-def)

392

              (error "Cannot specify ~A in a many-to-many association, must be of form (class slotname)"

393

assoc))

394

(setf (association-type slot-def) :ref

395

(foreign-classname slot-def) assoc

396

(foreign-slotname slot-def) nil))

397

(t

398

(destructuring-bind (classname slotname) assoc

399

(setf (foreign-classname slot-def) classname)

400

(setf (foreign-slotname slot-def) slotname)

401

(if (many-to-many-p slot-def)

402

(setf (association-type slot-def) :m2m)

403

(setf (association-type slot-def) :m21)))))))

404

405

(defun association-end-p (slot-def)

406

(not (eq (association-type slot-def) :m21)))

407

408

(defun association-slot-defs (class)

409

(find-slot-defs-by-type class 'association-effective-slot-definition nil))

410

411

(defun association-slot-names (class)

412

(find-slot-def-names-by-type class 'association-effective-slot-definition nil))

413

414

(defun association-end-slot-names (class)

415

(let ((results nil))

416

(mapc #'(lambda (slot-def)

417

(when (association-end-p slot-def)

418

(push (slot-definition-name slot-def) results)))

419

(find-slot-defs-by-type class 'association-effective-slot-definition nil))

420

results))

421

422

(defun get-association-slot-index (slot-def sc)

423

(awhen (assoc sc (association-slot-indices slot-def))

424

(cdr it)))

425

426

(defun add-association-slot-index (idx slot-def sc)

427

(setf (association-slot-indices slot-def)

428

(acons sc idx (association-slot-indices slot-def))))

429

430

(defun remove-association-slot-index (slot-def sc)

431

(setf (association-slot-indices slot-def)

432

(delete sc (association-slot-indices slot-def) :key #'car)))

433

434

(defmacro bind-standard-init-arguments ((initargs) &body body)

435

`(let ((allocation-key (getf ,initargs :allocation))

436

(has-initarg-p (getf ,initargs :initargs))

437

(transient-p (getf ,initargs :transient))

438

(indexed-p (or (getf ,initargs :indexed)

439

(getf ,initargs :index)))

440

(derived-p (or (getf ,initargs :derived-fn)

441

(getf ,initargs :fn)))

442

(cached-p (getf ,initargs :cached))

443

(set-valued-p (getf ,initargs :set-valued))

444

(associate-p (getf ,initargs :associate)))

445

(declare (ignorable allocation-key has-initarg-p))

446

(when (consp transient-p) (setq transient-p (car transient-p)))

447

(when (consp indexed-p) (setq indexed-p (car indexed-p)))

448

(when (consp derived-p) (setq derived-p (car derived-p)))

449

(when (consp cached-p) (setq cached-p (car cached-p)))

450

(when (consp set-valued-p) (setq set-valued-p (car set-valued-p)))

451

(when (consp associate-p) (setq associate-p (car associate-p)))

452

,@body))

453

454

(defmethod direct-slot-definition-class ((class stored-class) &rest initargs)

455

"Checks for the transient tag (and the allocation type)

456

and chooses stored or transient slot definitions."

457

(bind-standard-init-arguments (initargs)

458

(cond ((and (eq allocation-key :class) (not transient-p))

459

(error "Stored class slots are not supported, try :transient t."))

460

((> (count t (list (or indexed-p derived-p) transient-p)) 1)

461

(error "Cannot declare a slot to be more than one of transient or indexed."))

462

((and set-valued-p has-initarg-p)

463

(error "Cannot specify initargs for set-valued slots"))

464

           ((and associate-p (or (not (member (type-of associate-p) '(cons symbol))) (eq associate-p t)))

465

            (error "':associate' slot initarg must contain classname or a class / slot reference: (classname slotname)"))

466

((and associate-p has-initarg-p (eq (type-of associate-p) 'cons))

467

            (error "Can only specify initargs for association slots storing single instances of another class"))

468

(derived-p

469

(find-class 'derived-index-direct-slot-definition))

470

(indexed-p

471

(find-class 'indexed-direct-slot-definition))

472

(set-valued-p

473

(find-class 'set-valued-direct-slot-definition))

474

(cached-p

475

(find-class 'cached-direct-slot-definition))

476

(associate-p

477

(find-class 'association-direct-slot-definition))

478

(transient-p

479

(find-class 'transient-direct-slot-definition))

480

(t

481

(find-class 'stored-direct-slot-definition)))))

482

483

(defmethod effective-slot-definition-class ((class stored-class) &rest initargs)

484

"Chooses the stored or transient effective slot

485

definition class depending on the keyword."

486

(bind-standard-init-arguments (initargs)

487

(cond (derived-p

488

(find-class 'derived-index-effective-slot-definition))

489

(indexed-p

490

(find-class 'indexed-effective-slot-definition))

491

(set-valued-p

492

(find-class 'set-valued-effective-slot-definition))

493

(cached-p

494

(find-class 'cached-effective-slot-definition))

495

(associate-p

496

(find-class 'association-effective-slot-definition))

497

(transient-p

498

(find-class 'transient-effective-slot-definition))

499

(t

500

(find-class 'stored-effective-slot-definition)))))

501

502

(defmethod compute-effective-slot-definition-initargs ((class stored-class) slot-definitions)

503

(let ((initargs (call-next-method))

504

(parent-direct-slot (first slot-definitions)))

505

(cond ((ensure-transient-chain slot-definitions initargs)

506

(setf initargs (append initargs '(:transient t))))

507

((not (eq (type-of parent-direct-slot) 'cached-direct-slot-definition))

508

(setf (getf initargs :allocation) :database)))

509

(when (eq (type-of parent-direct-slot) 'set-valued-direct-slot-definition)

510

(setf (getf initargs :set-valued) t))

511

(when (eq (type-of parent-direct-slot) 'cached-direct-slot-definition)

512

(setf (getf initargs :cached) t))

513

(when (eq (type-of parent-direct-slot) 'association-direct-slot-definition)

514

(setf (getf initargs :associate) (association parent-direct-slot))

515

(setf (getf initargs :inherit)

516

(inherit-p parent-direct-slot))

517

(setf (getf initargs :many-to-many) (many-to-many-p parent-direct-slot))

518

(setf (getf initargs :base-class)

519

(if (inherit-p parent-direct-slot)

520

(find-class-for-direct-slot class parent-direct-slot)

521

(class-name class))))

522

(when (eq (type-of parent-direct-slot) 'indexed-direct-slot-definition)

523

(setf (getf initargs :indexed) t)

524

(setf (getf initargs :inherit)

525

(inherit-p parent-direct-slot))

526

(setf (getf initargs :base-class)

527

(if (inherit-p parent-direct-slot)

528

(find-class-for-direct-slot class parent-direct-slot)

529

(class-name class))))

530

(when (eq (type-of parent-direct-slot) 'derived-index-direct-slot-definition)

531

(setf (getf initargs :derived-fn)

532

(derived-fn-ref parent-direct-slot))

533

(setf (getf initargs :inherit)

534

(inherit-p parent-direct-slot))

535

(setf (getf initargs :slot-deps)

536

(derived-slot-deps parent-direct-slot))

537

(setf (getf initargs :fn)

538

(compile-derived-fn (derived-fn-ref parent-direct-slot)))

539

(setf (getf initargs :base-class)

540

(if (inherit-p parent-direct-slot)

541

(find-class-for-direct-slot class parent-direct-slot)

542

(class-name class))))

543

initargs))

544

545

(defun find-class-for-direct-slot (class def)

546

(let ((list (compute-class-precedence-list class)))

547

(labels ((rec (super)

548

(if (null super)

549

nil

550

(aif (find-direct-slot-def-by-name super (slot-definition-name def))

551

(class-name super)

552

(rec (pop list))))))

553

(rec class))))

554

555

(defmethod change-class :before ((previous standard-object) (new-class stored-class) &rest initargs)

556

(declare (ignorable initargs))

557

(unless (subtypep (type-of previous) 'stored)

558

(error "Cannot convert standard objects to stored objects")))

559

560

(defmethod change-class :before ((previous stored) (new-class standard-class) &rest initargs)

561

(declare (ignorable initargs))

562

(unless (subtypep (type-of new-class) 'stored-class)

563

(error "Stored instances cannot be changed to standard classes via change-class")))

564

565

;;; Macros

566

(defmacro defsclass (cname parents slot-defs &rest class-opts)

567

"Shorthand for defining stored objects. Wraps the main

568

class definition with stored-class"

569

`(eval-always

570

(defclass ,cname ,parents

571

,slot-defs

572

,@(add-stored-metaclass-argument class-opts))))

573

574

(defun add-stored-metaclass-argument (class-opts)

575

(when (assoc :metaclass class-opts)

576

(error "User metaclass specification not allowed in defsclass"))

577

(append class-opts (list (list :metaclass 'stored-class))))