Coverage report: /home/ati/workspace/perec/persistence/class.lisp

Kind	Covered	All	%
expression	554	665	83.3
branch	96	122	78.7

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

2

;;;

3

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

10

;;; Persistent class and slot meta objects

11

12

(defcclass* persistent-class (standard-class exportable)

13

((abstract

14

(compute-as #f)

15

:type boolean

16

     :documentation "An abstract persistent class cannot be instantiated but still can be used in associations and may have slots. Calling make-instance on an abstract persistent class will signal an error. On the other hand abstract classes might not have a primary table and thus handling the instances may require simpler or less SQL statements.")

17

(persistent-direct-slots

18

(compute-as (collect-if #L(typep !1 'persistent-direct-slot-definition) (class-direct-slots -self-)))

19

:type (list persistent-direct-slot-definition)

20

:documentation "The list of direct slots which are defined to be persistent in this class.")

21

(persistent-effective-slots

22

(compute-as (collect-if #L(typep !1 'persistent-effective-slot-definition) (class-slots -self-)))

23

:type (list persistent-effective-slot-definition)

24

     :documentation "The list of effective slots which are turned out to be persistent in this class.")

25

(persistent-direct-super-classes

26

(compute-as (collect-if #'persistent-class-p (class-direct-superclasses -self-)) )

27

:type (list persistent-class)

28

:documentation "The list of persistent direct sub classes.")

29

(persistent-class-precedence-list

30

(compute-as (list* -self- (persistent-effective-super-classes-of -self-)))

31

:type (list persistent-class)

32

:documentation "Similar to class-precedence-list but includes only persistent classes.")

33

(persistent-effective-super-classes

34

(compute-as (compute-persistent-effective-super-classes -self-))

35

:type (list persistent-class)

36

:documentation "The list of effective persistent super classes in class precedence order.")

37

(persistent-direct-sub-classes

38

(compute-as (collect-if #'persistent-class-p (class-direct-subclasses -self-)))

39

:type (list persistent-class)

40

:documentation "The list of persistent direct sub classes.")

41

(persistent-effective-sub-classes

42

(compute-as (compute-persistent-effective-sub-classes -self-))

43

:type (list persistent-class)

44

:documentation "The list of persistent effective sub classes in no particular order.")

45

(primary-table

46

(compute-as (compute-primary-table -self- -current-value-))

47

:type table

48

     :documentation "The table which holds the oid and the data of the direct slots of this class. If the class is abstract and does not have any persistent direct slots then it will not have a primary table. A primary table if exists contains one and only one record per instance of its persistent class.")

49

(primary-tables

50

(compute-as (compute-primary-tables -self-))

51

:type (list class-primary-table)

52

     :documentation "The smallest set of tables which hold all instances and only the instances of this class by having one and only one record per instance. This list may contain functional nodes such as union, append according to the required SQL operation. For classes which have a primary table this list contains only that table while for other classes the list will contain some of the primary tables of the sub persistent classes.")

53

(data-tables

54

(compute-as (compute-data-tables -self-))

55

:type (list table)

56

     :documentation "All the tables which hold direct data of an instance of this class. This list contains the primary tables of the super persistent classes.")

57

(prefetched-slots

58

(compute-as (collect-if #'prefetch-p (persistent-effective-slots-of -self-)))

59

:type (list persistent-effective-slot-definition)

60

     :documentation "The list of effective slots which will be loaded from and stored to the database at once when loading an instance of this class. Moreover when a persistent object is revived its prefetched slots will be loaded.")

61

(non-prefetched-slots

62

(compute-as (remove-if #'prefetch-p (persistent-effective-slots-of -self-)))

63

:type (list effective-slot)

64

     :documentation "The list of effective slots which will be loaded and stored lazily and separately from other slots.")

65

(depends-on

66

(compute-as nil)

67

:type (list persistent-class)

68

     :documentation "The list of persistent classes which must be looked at by this class when computing RDBMS meta data. This used to generate columns into other classes' primary tables.")

69

(depends-on-me

70

(compute-as nil)

71

:type (list persistent-class)

72

     :documentation "The list of persistent classes which must look at this class when computing RDBMS meta data."))

73

   (:documentation "Persistent class is a class meta object for classes. Standard defclass forms may be used to define persistent classes. A persistent class will have persistent slots unless marked with :persistent #f. A persistent slot should have type specification to be efficient both in storage and speed. The special type unbound must be used to mark slots which might be unbound."))

74

75

(defclass identity-preserving-class (computed-class)

76

()

77

   (:documentation "This class serves a very special purpose, namely being able to return the very same instance in make-instance for slot definition meta objects."))

78

79

(defcclass* persistent-slot-definition (standard-slot-definition)

80

((prefetch

81

:type boolean

82

:computed-in compute-as

83

     :documentation "Prefetched slots are loaded from and stored into the database at once. A prefetched slot must be in a table which can be accessed using a where clause matching to the id of the object thus it must be in a data table. The default prefetched slot semantics can be overriden on a per direct slot basis.")

84

(cache

85

:type boolean

86

:computed-in compute-as

87

     :documentation "All prefetched slots are cached slots but the opposite may not be true. When a cached slot is loaded it's value will be stored in the CLOS object for fast subsequent read operations. Also whenever a cached slot is set the value will be remembered. The default cached slot semantics can be overriden on a per direct slot basis.")

88

(index

89

:type boolean

90

:computed-in compute-as

91

:documentation "True means the slot value will be indexed in the underlying RDBMS.")

92

(unique

93

:type boolean

94

:computed-in compute-as

95

     :documentation "True means the slot value will be enforced to be unique among instances in the underlying RDBMS.")

96

(type-check

97

:type (member :always :on-commit)

98

:computed-in compute-as

99

     :documentation "On commit type check means that during the transaction the slot may have null and unbound value and the type check will be done when the transaction commits."))

100

(:documentation "Base class for both persistent direct and effective slot definitions."))

101

102

(defcclass* persistent-direct-slot-definition

103

(persistent-slot-definition standard-direct-slot-definition)

104

()

105

(:metaclass identity-preserving-class)

106

(:documentation "Class for persistent direct slot definitions."))

107

108

(defcclass* persistent-effective-slot-definition

109

(persistent-slot-definition standard-effective-slot-definition)

110

((normalized-type

111

(compute-as (normalized-type-for (slot-definition-type -self-)))

112

:type list)

113

(direct-slots

114

:type (list persistent-direct-slot-definition)

115

     :documentation "The list of direct slots definitions used to compute this effective slot during the class finalization procedure.")

116

(primary-class

117

(compute-as (compute-primary-class -self-))

118

:type persistent-class

119

     :documentation "The persistent class which owns the primary table where this slot will be stored.")

120

(table

121

(compute-as (compute-table -self-))

122

:type table

123

     :documentation "The RDBMS table which will be queried or updated to get and set the data of this slot.")

124

(columns

125

(compute-as (compute-columns -self-))

126

:type (list sql-column)

127

     :documentation "The list of RDBMS columns which will be queried or updated to get and set the data of this slot.")

128

(id-column

129

(compute-as (bind ((type (normalized-type-of -self-)))

130

(if (or (persistent-class-type-p type)

131

(set-type-p type))

132

(first (columns-of -self-)))))

133

:type sql-column

134

     :documentation "This is the id column of the oid reference when appropriarte for the slot type.")

135

(reader

136

(compute-as (compute-reader -self- (slot-definition-type -self-)))

137

:type (or null function)

138

     :documentation "A one parameter function which transforms RDBMS data received as a list to the corresponding lisp object. This is present only for data table slots.")

139

(writer

140

(compute-as (compute-writer -self- (slot-definition-type -self-)))

141

:type (or null function)

142

     :documentation "A one parameter function which transforms a lisp object to the corresponding RDBMS data. This is present only for data table slots.")

143

(primary-table-slot

144

(compute-as (compute-primary-table-slot-p -self-))

145

:type boolean

146

:documentation "True means the slot can be loaded from the primary table of its class.")

147

(data-table-slot

148

(compute-as (compute-data-table-slot-p -self-))

149

:type boolean

150

:documentation "True means the slot can be loaded from one of the data tables of its class.")

151

(prefetch

152

(compute-as (data-table-slot-p -self-))

153

     :documentation "The prefetched option is inherited among direct slots according to the class precedence list. If no direct slot has prefetched specification then the default behaviour is to prefetch data tabe slot.")

154

(cache

155

(compute-as (or (prefetch-p -self-)

156

(persistent-class-type-p (normalized-type-of -self-))))

157

     :documentation "The cached option is inherited among direct slots according to the class precedence list. If no direct slot has cached specification then the default behaviour is to cache prefetched slots and single object references.")

158

(index

159

(compute-as #f)

160

     :documentation "The index option is inherited among direct slots according to the class precedence list with defaulting to false.")

161

(unique

162

(compute-as #f)

163

     :documentation "The unique option is inherited among direct slots according to the class precedence list with defaulting to false.")

164

(type-check

165

(compute-as :always)

166

     :documentation "The type check option is inherited among direct slots according to the class precedence list with defaulting to :always."))

167

(:documentation "Class for persistent effective slot definitions."))

168

169

(defcclass* class-primary-table (table)

170

((oid-columns

171

(compute-as (list (id-column-of -self-) (class-name-column-of -self-)))

172

:type (list sql-column)

173

:documentation "The list of RDBMS columns corresponding to the oid of this table.")

174

(id-column

175

(compute-as (find +id-column-name+ (columns-of -self-) :key 'cl-rdbms::name-of))

176

:type sql-column

177

:documentation "The RDBMS column of corresponding oid slot.")

178

(class-name-column

179

(compute-as (find +class-name-column-name+ (columns-of -self-) :key 'cl-rdbms::name-of))

180

:type sql-column

181

:documentation "The RDBMS column of corresponding oid slot."))

182

(:documentation "This is a special table related to a persistent class."))

183

184

;; :persistent is a slot definition option and may be set to #t or #f

185

(eval-always

186

   (mapc #L(pushnew !1 *allowed-slot-definition-properties*) '(:persistent :prefetch :cache :index :unique :type-check)))

187

188

(defmethod describe-object ((object persistent-class) stream)

189

(call-next-method)

190

(aif (primary-table-of object)

191

(progn

192

(princ "The primary table is the following: ")

193

(describe-object it stream))

194

(princ (format nil "The primary tables are: ~A" (primary-tables-of object)) stream)))

195

196

(defprint-object (slot persistent-slot-definition)

197

(princ (slot-definition-name slot)))

198

199

;;;;;;;;;;

200

;;; Export

201

202

(defmethod export-to-rdbms ((class persistent-class))

203

(ensure-finalized class)

204

(mapc #'ensure-exported

205

(persistent-effective-super-classes-of class))

206

(mapc #'ensure-exported

207

(collect-if #L(typep !1 'persistent-association)

208

(depends-on-of class)))

209

(awhen (primary-table-of class)

210

(ensure-exported it)))

211

212

;;;;;;;;;;;;

213

;;; Computed

214

215

(defgeneric compute-persistent-effective-super-classes (class)

216

(:method ((class persistent-class))

217

(remove-if #L(eq class !1)

218

(collect-if #L(typep !1 'persistent-class)

219

(class-precedence-list class)))))

220

221

(defgeneric compute-persistent-effective-sub-classes (class)

222

(:method ((class persistent-class))

223

(delete-duplicates

224

(append (persistent-direct-sub-classes-of class)

225

(iter (for sub-class in (persistent-direct-sub-classes-of class))

226

(appending (persistent-effective-sub-classes-of sub-class)))))))

227

228

(defun mapped-type-for (type)

229

(if (persistent-class-type-p type)

230

type

231

(find-if #L(cond ((or (eq type !1)

232

(and (listp type)

233

(eq (first type) !1)))

234

#t)

235

((eq 'member !1)

236

(and (listp type)

237

(eq 'member (first type))))

238

(t

239

(subtypep type !1)))

240

*mapped-type-precedence-list*)))

241

242

(defun normalized-type-for (type)

243

(let ((*canonical-types* *mapped-type-precedence-list*))

244

(canonical-type-for

245

`(and (not null)

246

(not unbound)

247

,type))))

248

249

(defun compute-column-type (type)

250

"Returns the RDBMS type for the given type."

251

(let ((normalized-type (normalized-type-for type)))

252

(compute-column-type* (mapped-type-for normalized-type) normalized-type)))

253

254

(defgeneric compute-column-type* (type type-specification)

255

(:method (type type-specification)

256

(declare (ignore type-specification))

257

(error "Cannot map type ~A to RDBMS type" type)))

258

259

(defun column-count-for (normalized-type unbound-and-null-subtype-p)

260

(+ (cond ((persistent-class-type-p normalized-type)

261

2)

262

((primitive-type-p normalized-type)

263

1)

264

(t (error "Cannot map type ~A to a writer" normalized-type)))

265

(if unbound-and-null-subtype-p

266

1

267

0)))

268

269

(defun compute-transformer (transformer-type slot type)

270

"Maps a type to a one parameter lambda which will be called with the received RDBMS values."

271

(flet ((wrapper-function-for (symbol-or-function)

272

(if (functionp symbol-or-function)

273

symbol-or-function

274

                (concatenate-symbol (find-package :cl-perec) symbol-or-function "-" transformer-type)))

275

(identity-wrapper (slot type function column-number)

276

(declare (ignorable slot type column-number))

277

function))

278

(bind ((normalized-type (normalized-type-for type))

279

(mapped-type (mapped-type-for normalized-type))

280

(unbound-subtype-p (unbound-subtype-p type))

281

(null-subtype-p (and (not (null-subtype-p mapped-type))

282

(null-subtype-p type)))

283

(column-count (column-count-for normalized-type (and unbound-subtype-p null-subtype-p)))

284

((values wrapper-1 wrapper-2)

285

(cond ((and unbound-subtype-p

286

null-subtype-p)

287

(values 'unbound-or-null #'identity-wrapper))

288

((and unbound-subtype-p

289

(not null-subtype-p))

290

(values 'unbound (if (null-subtype-p mapped-type)

291

#'identity-wrapper

292

'non-null)))

293

((and (not unbound-subtype-p)

294

null-subtype-p)

295

(values 'non-unbound 'null))

296

((and (not unbound-subtype-p)

297

(not null-subtype-p))

298

(values 'non-unbound (if (null-subtype-p mapped-type)

299

#'identity-wrapper

300

'non-null))))))

301

(values

302

(funcall (wrapper-function-for wrapper-1)

303

slot

304

type

305

(funcall (wrapper-function-for wrapper-2)

306

slot

307

type

308

(funcall (if (eq transformer-type 'reader)

309

'compute-reader*

310

'compute-writer*)

311

mapped-type

312

normalized-type)

313

column-count)

314

column-count)

315

wrapper-1

316

wrapper-2))))

317

318

(defun compute-reader (slot type)

319

"Maps a type to a one parameter lambda which will be called with the received RDBMS values."

320

(compute-transformer 'reader slot type))

321

322

(defgeneric compute-reader* (type type-specification)

323

(:method (type type-specification)

324

(declare (ignore type-specification))

325

(error "Cannot map type ~A to a reader" type))

326

327

(:method ((type symbol) type-specification)

328

(declare (ignore type-specification))

329

(if (persistent-class-type-p type)'object-reader

330

(call-next-method)))

331

332

(:method ((type persistent-class) type-specification)

333

(declare (ignore type-specification))

334

'object-reader))

335

336

(defun compute-writer (slot type)

337

"Maps a type to a one parameter lambda which will be called with the slot value."

338

(compute-transformer 'writer slot type))

339

340

(defgeneric compute-writer* (type type-specification)

341

(:method (type type-specification)

342

(declare (ignore type-specification))

343

(error "Cannot map type ~A to a writer" type))

344

345

(:method ((type symbol) type-specification)

346

(declare (ignore type-specification))

347

(if (persistent-class-type-p type)

348

'object-writer

349

(call-next-method)))

350

351

(:method ((type persistent-class) type-specification)

352

(declare (ignore type-specification))

353

'object-writer))

354

355

(defgeneric compute-primary-table (class current-table)

356

(:method ((class persistent-class) current-table)

357

(ensure-finalized class)

358

(flet ((primary-table-columns-for-class (class)

359

(delete-duplicates

360

(append

361

(mappend #L(when (primary-table-slot-p !1)

362

(columns-of !1))

363

(persistent-effective-slots-of class))

364

(mappend #L(when (eq class (primary-class-of !1))

365

(columns-of !1))

366

(mappend #L(persistent-effective-slots-of !1)

367

                                         (collect-if #L(typep !1 'persistent-class) (depends-on-of class))))))))

368

(when (or (not (abstract-p class))

369

(primary-table-columns-for-class class))

370

(or current-table

371

(make-instance 'class-primary-table

372

:name (rdbms-name-for (class-name class))

373

:columns (compute-as

374

(append

375

(make-oid-columns)

376

                                               (primary-table-columns-for-class class)))))))))

377

378

(defgeneric compute-primary-tables (class)

379

(:method ((class persistent-class))

380

(labels ((primary-classes-of (class)

381

(if (primary-table-of class)

382

(list class)

383

                           (iter (for sub-class in (persistent-direct-sub-classes-of class))

384

(appending (primary-classes-of sub-class))))))

385

(bind ((primary-classes (primary-classes-of class))

386

                     (primary-class-sub-classes (mapcar #'persistent-effective-sub-classes-of primary-classes))

387

(primary-tables (mapcar #'primary-table-of primary-classes)))

388

(when primary-class-sub-classes

389

(if (eq (length (reduce #'union primary-class-sub-classes))

390

(length (reduce #'append primary-class-sub-classes)))

391

(cons 'append primary-tables)

392

(cons 'union primary-tables)))))))

393

394

(defgeneric compute-data-tables (class)

395

(:method ((class persistent-class))

396

(delete-if #'null

397

(mapcar #'primary-table-of

398

                               (list* class (persistent-effective-super-classes-of class))))))

399

400

(defgeneric compute-primary-table-slot-p (slot)

401

(:method ((slot persistent-effective-slot-definition))

402

            (and (not (some #'primary-table-slot-p (persistent-effective-super-slot-precedence-list-of slot)))

403

(data-table-slot-p slot)

404

(eq (primary-class-of slot) (slot-definition-class slot)))))

405

406

(defgeneric compute-data-table-slot-p (slot)

407

(:method ((slot persistent-effective-slot-definition))

408

(bind ((type (normalized-type-of slot)))

409

(and (subtypep (slot-definition-class slot) (primary-class-of slot))

410

(or (primitive-type-p type)

411

(persistent-class-type-p type))))))

412

413

(defgeneric compute-primary-class (slot)

414

(:method ((slot persistent-effective-slot-definition))

415

(or (some #'primary-class-of (persistent-effective-super-slot-precedence-list-of slot))

416

(awhen (normalized-type-of slot)

417

(cond ((set-type-p it)

418

(find-class (set-type-class-for it)))

419

((or (primitive-type-p it)

420

(persistent-class-type-p it))

421

(slot-definition-class slot))

422

(t

423

                         (error "Unknown type ~A in slot ~A" (slot-definition-type slot) slot)))))))

424

425

(defgeneric compute-table (slot)

426

(:method ((slot persistent-effective-slot-definition))

427

(primary-table-of (primary-class-of slot))))

428

429

(defgeneric compute-columns (slot)

430

(:method ((slot persistent-effective-slot-definition))

431

(or (some #'columns-of (persistent-effective-super-slot-precedence-list-of slot))

432

(bind ((name (slot-definition-name slot))

433

(type (slot-definition-type slot))

434

(normalized-type (normalized-type-of slot))

435

(mapped-type (mapped-type-for normalized-type))

436

(complex-type-p (and (null-subtype-p type)

437

(unbound-subtype-p type)

438

                                            (not (null-subtype-p mapped-type))

439

                                            (not (unbound-subtype-p mapped-type))))

440

(class (slot-definition-class slot))

441

(class-name (class-name class)))

442

(when normalized-type

443

(cond ((set-type-p normalized-type)

444

(make-columns-for-reference-slot class-name

445

                                                            (strcat name "-for-" class-name)))

446

((persistent-class-type-p normalized-type)

447

(append

448

(when complex-type-p

449

(list

450

(make-instance 'column

451

                                              :name (rdbms-name-for (concatenate-symbol name "-bound"))

452

:type (sql-boolean-type))))

453

(make-columns-for-reference-slot class-name name)))

454

((primitive-type-p normalized-type)

455

(append

456

(when complex-type-p

457

(list

458

(make-instance 'column

459

                                              :name (rdbms-name-for (concatenate-symbol name "-bound"))

460

:type (sql-boolean-type))))

461

(list

462

(make-instance 'column

463

:name (rdbms-name-for name)

464

                                            :type (compute-column-type type)

465

                                            ;; TODO: add null constraint if type-check is :always (and (not (subytpep 'null type))

466

                                            ;;                                                         (not (subytpep 'unbound type)))

467

                                            :constraints (if (unique-p slot)

468

                                                             (list (sql-unique-constraint)))

469

                                            :index (if (and (index-p slot)

470

                                                            (not (unique-p slot)))

471

                                                       (sql-index :name

472

                                                                  (rdbms-name-for (concatenate-symbol name "-on-" class-name "-idx"))))))))

473

(t

474

(error "Unknown type ~A in slot ~A" type slot))))))))

475

476

;;;;;;;;

477

;;; Type

478

479

(defun primitive-type-p (type)

480

   "Accept types such as: integer, string, boolean, (or unbound integer), (or null string), (or unbound null boolean), etc."

481

(and (not (persistent-class-type-p type))

482

(not (set-type-p type))))

483

484

(defun persistent-class-type-p (type)

485

"Returns true for persistent class types."

486

(subtypep type 'persistent-object))

487

488

(defun set-type-p (type)

489

"Returns true for persistent set types."

490

(and (not (subtypep type 'list))

491

(subtypep type '(set persistent-object))))

492

493

(defun set-type-class-for (type)

494

(second (find 'set type :key #L(first (ensure-list !1)))))

495

496

(defun unbound-subtype-p (type)

497

(and (not (eq 'member type))

498

(subtypep 'unbound type)))

499

500

(defun null-subtype-p (type)

501

(and (not (eq 'member type))

502

(subtypep 'null type)))

503

504

(defmethod matches-type* (value (type symbol))

505

(and (typep value type)

506

(or (not (persistent-class-type-p type))

507

(every (lambda (slot)

508

(bind ((type (normalized-type-of slot))

509

(class (class-of value)))

510

(unless (funcall *matches-type-cut-function* value type)

511

(if (slot-boundp-using-class class value slot)

512

                             (bind ((slot-value (slot-value-using-class class value slot)))

513

(aprog1 (matches-type* slot-value type)

514

(unless it

515

                                   (error (make-condition 'object-slot-type-violation :object value :slot slot)))))

516

(not (unbound-subtype-p type))))))

517

(persistent-effective-slots-of type)))))

518

519

;;;;;;;;;;;

520

;;; Utility

521

522

(defparameter *persistent-classes* (make-hash-table)

523

"A mapping from persistent class names to persistent objects.")

524

525

(defun find-persistent-class (name)

526

(gethash name *persistent-classes*))

527

528

(defun find-persistent-class* (name-or-class)

529

(etypecase name-or-class

530

(symbol (find-persistent-class name-or-class))

531

(persistent-class name-or-class)))

532

533

(defun (setf find-persistent-class) (new-value name)

534

(setf (gethash name *persistent-classes*) new-value))

535

536

(defun persistent-class-p (class)

537

(typep class 'persistent-class))

538

539

(defun persistent-class-name-p (name)

540

(and name

541

(symbolp name)

542

(persistent-class-p (find-class name #f))))

543

544

(defun persistent-slot-p (slot)

545

(typep slot 'persistent-slot-definition))

546

547

(defun slot-definition-class (slot)

548

"Returns the class to which the given slot belongs."

549

#+sbcl(slot-value slot 'sb-pcl::%class)

550

#-sbcl(not-yet-implemented))

551

552

(defun persistent-effective-super-slot-precedence-list-of (slot)

553

(bind ((slot-name (slot-definition-name slot))

554

(slot-class (slot-definition-class slot)))

555

(ensure-finalized slot-class)

556

(iter (for class in (persistent-effective-super-classes-of slot-class))

557

(ensure-finalized class)

558

(aif (find slot-name (persistent-effective-slots-of class) :key #'slot-definition-name)

559

(collect it)))))

560

561

(defun slot-accessor-p (name)

562

(and (symbolp name)

563

(effective-slots-for-accessor name)))

564

565

(defun effective-slots-for-accessor (name)

566

(iter (for (class-name class) in-hashtable *persistent-classes*)

567

(awhen (find name (persistent-direct-slots-of class)

568

:key #'slot-definition-readers

569

:test #'member)

570

(ensure-finalized class)

571

(collect (prog1 (find-slot class (slot-definition-name it))

572

(assert it))))))

573

574

(defun make-oid-columns ()

575

   "Creates a list of RDBMS columns that will be used to store the oid data of the objects in this table."

576

(list

577

(make-instance 'column

578

:name +id-column-name+

579

:type +oid-id-sql-type+

580

:constraints (list (sql-not-null-constraint)

581

(sql-primary-key-constraint)))

582

(make-instance 'column

583

:name +class-name-column-name+

584

:type +oid-class-name-sql-type+)))

585

586

(defun make-columns-for-reference-slot (class-name column-name)

587

(bind ((id-column-name (rdbms-name-for (concatenate-symbol column-name "-id")))

588

(id-index-name (rdbms-name-for (concatenate-symbol column-name "-id-on-" class-name "-idx")))

589

(class-name-column-name (rdbms-name-for (concatenate-symbol column-name "-class-name"))))

590

(list

591

(make-instance 'column

592

:name id-column-name

593

:type +oid-id-sql-type+

594

:index (sql-index :name id-index-name))

595

(make-instance 'column

596

:name class-name-column-name

597

:type +oid-class-name-sql-type+))))