Coverage report: /home/ati/workspace/perec/query/sql.lisp

Kind	Covered	All	%
expression	820	967	84.8
branch	42	62	67.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

;;; SQL syntax

11

;;;

12

13

;;;----------------------------------------------------------------------------

14

;;; Selects

15

16

(defun sql-select-for-query (query)

17

"Emits code for the QUERY."

18

(ecase (action-of query)

19

(:collect

20

`(sql-select

21

:distinct ,(uniquep query)

22

:columns (list ,@(sql-select-list-for query))

23

:tables (list ,@(sql-table-references-for query))

24

:where ,(where-clause-of query)

25

:order-by (list ,@(order-by-of query))))

26

(:purge

27

(bind ((variable (first (action-args-of query))))

28

(assert variable)

29

`(sql-select

30

:columns (list ,(sql-id-column-reference-for variable))

31

:tables (list ,@(sql-table-references-for query))

32

:where ,(where-clause-of query))))))

33

34

(defun sql-select-oids-for-class (class-name)

35

"Generates a select for the oids of instances of the class named CLASS-NAME."

36

(bind ((tables (rest (primary-tables-of (find-class class-name))))) ; TODO: APPEND/UNION

37

(sql-select-oids-from-tables tables 'sql-union)))

38

39

(defun sql-select-oids-from-tables (tables set-operation)

40

"Generates a select for the union or intersection of oids from TABLES."

41

(declare (type (member sql-union sql-intersect) set-operation))

42

(case (length tables)

43

(0 nil)

44

(1 (sql-select-oids-from-table (first tables)))

45

(otherwise (apply set-operation (mapcar 'sql-select-oids-from-table tables)))))

46

47

(defgeneric sql-select-oids-from-table (table)

48

(:documentation "Generates a select for the oids in TABLE.")

49

(:method ((table table))

50

(sql-select :columns +oid-column-names+ :tables (list (name-of table))))

51

(:method ((table sql-table-alias))

52

(sql-select :columns +oid-column-names+ :tables (list table))))

53

54

;;;----------------------------------------------------------------------------

55

;;; Deletes

56

(defun sql-deletes-for-query (query)

57

   "Returns two values, the first is a list of SQL statements that deletes the records, the second is a cleanup form."

58

(bind ((variable (first (action-args-of query)))

59

(type (xtype-of variable))

60

(tables (when (persistent-class-p type) (tables-for-delete type))))

61

(if (simple-purge-p query)

62

(bind ((table (first tables)))

63

`(list ,(sql-delete-from-table table :where (where-clause-of query))))

64

(bind ((temp-table (rdbms-name-for 'deleted-ids))

65

(create-table `(sql-create-table

66

:name ',temp-table

67

:temporary #t

68

                              :columns (list (sql-identifier :name ',+id-column-name+))

69

                              :as (sql-subquery :query ,(sql-select-for-query query))))

70

(delete-where `(sql-subquery

71

:query

72

(sql-select

73

:columns (list ',+id-column-name+)

74

:tables (list ',temp-table))))

75

(deletes (mapcar #L(sql-delete-for-subselect !1 delete-where) tables))

76

(drop-table `(sql-drop-table

77

:name ',temp-table)))

78

(values `(list ,create-table ,@deletes)

79

drop-table)))))

80

81

(defun simple-purge-p (query)

82

   "The purge is simple if it deletes records from one table only and no need to join other tables for the condition."

83

(and (typep query 'simple-query)

84

(eq (action-of query) :purge)

85

(length=1 (query-variables-of query))

86

(persistent-class-p (xtype-of (first (query-variables-of query))))

87

(length=1 (tables-for-delete (xtype-of (first (query-variables-of query)))))))

88

89

(defun sql-delete-for-subselect (table subselect)

90

"Generate a delete command for records in TABLE whose oid is in the set returned by SUBSELECT."

91

(sql-delete-from-table

92

table

93

:where `(sql-in

94

,(sql-id-column-reference-for table)

95

,subselect)))

96

97

(defun sql-delete-from-table (table &key where)

98

"Generate a delete command for records in TABLE that satisfies the WHERE clause."

99

`(sql-delete

100

:table ,(sql-table-reference-for table nil)

101

:where ,where))

102

103

(defun tables-for-delete (class)

104

"Returns the tables where instances of CLASS are stored."

105

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

106

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

107

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

108

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

109

(super-sub-primary-tables (mappend 'data-tables-of sub-classes)))

110

(delete nil

111

(delete-duplicates

112

(append

113

(list class-primary-table)

114

super-primary-tables

115

super-sub-primary-tables)))))

116

117

;;;----------------------------------------------------------------------------

118

;;; Alias names

119

120

(defvar *suppress-alias-names* nil)

121

122

(defgeneric sql-alias-for (element)

123

(:documentation "Generates a table alias for the given ELEMENT. Alias names may be supressed

124

by setting *SUPRESS-ALIAS-NAMES* to true.")

125

(:method ((name symbol))

126

(unless *suppress-alias-names*

127

(rdbms-name-for name)))

128

(:method ((variable query-variable))

129

(sql-alias-for (name-of variable)))

130

(:method ((class persistent-class))

131

(sql-alias-for (class-name class)))

132

(:method ((table table))

133

(unless *suppress-alias-names*

134

(name-of table))))

135

136

;;;----------------------------------------------------------------------------

137

;;; Select lists

138

139

(defgeneric sql-select-list-for (element)

140

(:method ((query query))

141

;; select oids and prefetched slots

142

;; TODO: if no prefetch, select the expressions in the collect clause

143

(mapcan

144

(lambda (variable) (sql-columns-for-variable variable (prefetchp query)))

145

(query-variables-of query))))

146

147

(defun sql-columns-for-variable (variable prefetchp)

148

(bind ((table-alias (sql-alias-for variable)))

149

(if prefetchp

150

(nconc

151

(sql-oid-column-references-for variable)

152

(mapcan #L(sql-column-references-for !1 table-alias)

153

(prefetched-slots-for variable)))

154

(sql-oid-column-references-for variable))))

155

156

(defun prefetched-slots-for (variable)

157

(bind ((type (xtype-of variable)))

158

(when (persistent-class-p type)

159

(collect-if #L(eq (table-of !1) (primary-table-of type))

160

(prefetched-slots-of type)))))

161

162

;;;----------------------------------------------------------------------------

163

;;; Table references

164

165

(defgeneric sql-table-references-for (element)

166

(:method ((query query))

167

(bind ((variables (query-variables-of query)))

168

(mapcar 'sql-table-reference-for variables variables))))

169

170

(defgeneric sql-table-reference-for (element alias)

171

(:method ((table table) (alias symbol))

172

(sql-table-alias :name (name-of table) :alias alias))

173

174

(:method ((subquery sql-subquery) (alias symbol))

175

(sql-derived-table :subquery subquery :alias alias))

176

177

(:method ((class persistent-class) (alias symbol))

178

(sql-table-reference-for-type class alias))

179

180

(:method ((class-name symbol) (alias symbol))

181

(aif (find-class class-name)

182

(sql-table-reference-for it alias)

183

(error "No persistent class named '~A~%" class-name)))

184

185

(:method ((variable query-variable) (alias symbol))

186

(assert (not (eq (xtype-of variable) +unknown-type+)))

187

(sql-table-reference-for-type (xtype-of variable) alias))

188

189

(:method ((syntax syntax-object) (alias symbol))

190

(make-function-call :fn 'sql-table-reference-for :args (list syntax alias)))

191

192

(:method (element (variable query-variable))

193

(sql-table-reference-for element (sql-alias-for variable)))

194

195

(:method (element (class persistent-class))

196

(sql-table-reference-for element (sql-alias-for class)))

197

198

(:method (element (syntax syntax-object))

199

(make-function-call :fn 'sql-table-reference-for :args (list element syntax))))

200

201

(defgeneric sql-table-reference-for-type (type &optional alias)

202

203

(:method ((class persistent-class) &optional alias)

204

(bind ((tables (rest (primary-tables-of class)))) ; TODO handle UNION/APPEND

205

(case (length tables)

206

(0 (error "No primary table for persistent class: ~A" class))

207

(1 (sql-table-reference-for (first tables) alias))

208

(t (sql-table-reference-for

209

(sql-subquery :query (sql-select-oids-from-tables tables 'sql-union))

210

alias)))))

211

212

(:method ((type-name symbol) &optional alias)

213

(bind ((class (find-class type-name #f)))

214

(typecase class

215

(persistent-class (sql-table-reference-for-type class alias))

216

(otherwise nil))))

217

218

(:method ((type syntax-object) &optional alias) ;; type unknown at compile time

219

(make-function-call

220

:fn 'sql-table-reference-for-type

221

:args (list (backquote-type-syntax type) `',alias)))

222

223

(:method ((combined-type list) &optional alias)

224

(if (contains-syntax-p combined-type)

225

;; delay evaluation until run-time

226

(make-function-call

227

:fn 'sql-table-reference-for-type

228

:args (list (backquote-type-syntax combined-type) `',alias))

229

;; and/or/not types

230

(labels ((ensure-sql-query (table-ref)

231

(assert (not (syntax-object-p table-ref)))

232

(etypecase table-ref

233

                             (sql-table-alias (sql-subquery :query (sql-select-oids-from-table table-ref)))

234

                             (sql-derived-table (cl-rdbms::subquery-of table-ref)))) ; TODO missing export

235

(ensure-alias (table-ref)

236

(when (or (typep table-ref 'sql-table-alias)

237

(typep table-ref 'sql-derived-table))

238

(setf (cl-rdbms::alias-of table-ref) alias))

239

table-ref)

240

(combine-types (sql-set-operation types)

241

(bind ((operands (delete nil

242

                                                    (mapcar 'sql-table-reference-for-type types))))

243

(case (length operands)

244

(0 nil)

245

(1 (ensure-alias (first operands)))

246

(t (sql-table-reference-for

247

(sql-subquery

248

:query (apply sql-set-operation

249

                                                 (mapcar #'ensure-sql-query operands)))

250

alias))))))

251

(case (car combined-type)

252

(or (combine-types 'sql-union (rest combined-type)))

253

(and (combine-types 'sql-intersect (rest combined-type)))

254

(not (not-yet-implemented))

255

(t (error "Unsupported type constructor in ~A" combined-type)))))))

256

257

;;;----------------------------------------------------------------------------

258

;;; Column references

259

260

(defgeneric sql-column-reference-for (element qualifier)

261

(:method ((column-name symbol) (qualifier symbol))

262

(sql-column-alias :column column-name :table qualifier))

263

264

(:method ((column column) qualifier)

265

(sql-column-reference-for (rdbms::name-of column) qualifier))

266

267

(:method ((association-end persistent-association-end-slot-definition) qualifier)

268

(sql-column-reference-for (id-column-of association-end) qualifier))

269

270

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

271

(sql-column-reference-for (last1 (columns-of slot)) qualifier))

272

273

(:method (element qualifier)

274

(sql-column-reference-for element (sql-alias-for qualifier))))

275

276

(defun sql-id-column-reference-for (qualifier)

277

(sql-column-reference-for +id-column-name+ qualifier))

278

279

(defgeneric sql-column-references-for (element qualifier)

280

(:method ((column-names list) qualifier)

281

(mapcar #L(sql-column-reference-for !1 qualifier) column-names))

282

283

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

284

(sql-column-references-for (columns-of slot) qualifier)))

285

286

(defun sql-oid-column-references-for (qualifier)

287

(sql-column-references-for +oid-column-names+ qualifier))

288

289

290

;;;----------------------------------------------------------------------------

291

;;; Subselects

292

293

(defun sql-exists-subselect-for-variable (variable type)

294

"Returns an sql expression which evaluates to true iff the query variable named VARIABLE-NAME

295

has the type TYPE."

296

`(sql-exists

297

(sql-subquery

298

:query

299

(sql-select

300

:columns (list 1)

301

:tables (list ,(sql-table-reference-for-type type type))

302

:where ,(sql-join-condition-for variable type nil)))))

303

304

(defun sql-exists-subselect-for-association-end (variable association-end)

305

"Returns an sql expression which evaluates to true iff the query variable VARIABLE

306

has associated objects through ASSOCIATION-END."

307

(bind ((class (slot-definition-class (other-association-end-of association-end))))

308

`(sql-exists

309

(sql-subquery

310

:query

311

(sql-select

312

:columns (list 1)

313

:tables (list ,(sql-table-reference-for class (sql-alias-for class)))

314

:where ,(sql-join-condition-for variable class (other-association-end-of association-end)))))))

315

316

(defun sql-aggregate-subselect-for-variable (aggregate-function n-association-end 1-var)

317

(bind ((1-association-end (other-association-end-of n-association-end))

318

(n-class (slot-definition-class 1-association-end))

319

(n-var (make-query-variable :name (gensym (symbol-name (class-name n-class)))

320

:xtype n-class)))

321

`(sql-subquery

322

:query

323

(sql-select

324

:columns (list (,aggregate-function ,(sql-id-column-reference-for n-var)))

325

:tables (list ,(sql-table-reference-for n-var n-var))

326

:where ,(sql-join-condition-for 1-var n-var 1-association-end)))))

327

328

(defun sql-aggregate-subselect-for-m-n-association-end (aggregate-function association-end variable)

329

(bind ((other-end (other-association-end-of association-end))

330

(table (primary-table-of (association-of association-end))))

331

`(sql-subquery

332

:query

333

(sql-select

334

:columns (list (,aggregate-function ,(sql-column-reference-for association-end table)))

335

:tables (list (sql-identifier :name ',(name-of table)))

336

:where (sql-=

337

,(sql-column-reference-for other-end table)

338

,(sql-id-column-reference-for variable))))))

339

340

(defun sql-subselect-for-secondary-association-end (association-end variable)

341

(bind ((primary-association-end (other-association-end-of association-end))

342

(class (slot-definition-class primary-association-end)))

343

`(sql-subquery

344

:query

345

(sql-select

346

:columns (list ,(sql-id-column-reference-for nil))

347

:tables (list ,(sql-table-reference-for class nil))

348

:where (sql-=

349

,(sql-column-reference-for primary-association-end nil)

350

,(sql-id-column-reference-for variable))))))

351

352

(defun sql-subselect-for-m-n-association (association-end variable)

353

(bind ((other-end (other-association-end-of association-end))

354

(table (primary-table-of (association-of association-end))))

355

`(sql-subquery

356

:query

357

(sql-select

358

:columns (list ,(sql-column-reference-for association-end table))

359

:tables (list (sql-identifier :name ',(name-of table)))

360

:where (sql-=

361

,(sql-column-reference-for other-end table)

362

,(sql-id-column-reference-for variable))))))

363

364

365

366

;;;----------------------------------------------------------------------------

367

;;; Joins

368

369

(defun sql-join-condition-for (object-1 object-2 association-end-2)

370

(if (not association-end-2)

371

(sql-=

372

(sql-id-column-reference-for object-1)

373

(sql-id-column-reference-for object-2))

374

(bind ((association (association-of association-end-2))

375

(association-kind (association-kind-of association)))

376

(case association-kind

377

(:1-1

378

(if (primary-association-end-p association-end-2)

379

(sql-=

380

(sql-id-column-reference-for object-1)

381

(sql-column-reference-for association-end-2 object-2))

382

(sql-=

383

(sql-id-column-reference-for object-2)

384

(sql-column-reference-for (other-association-end-of association-end-2) object-1))))

385

(:1-n

386

(if (to-one-association-end-p association-end-2) ; TODO should check if primary

387

(sql-=

388

(sql-id-column-reference-for object-1)

389

(sql-column-reference-for association-end-2 object-2))

390

(sql-=

391

(sql-id-column-reference-for object-2)

392

(sql-column-reference-for (other-association-end-of association-end-2) object-1))))

393

(:m-n

394

(bind ((table (primary-table-of association)))

395

(sql-and

396

(sql-=

397

(sql-id-column-reference-for object-1)

398

(sql-column-reference-for association-end-2 table))

399

(sql-=

400

(sql-id-column-reference-for object-2)

401

(sql-column-reference-for (other-association-end-of association-end-2) table)))))))))

402

403

(defun sql-join-condition-for-joined-variable (variable)

404

(sql-join-condition-for variable (object-of variable) (association-end-of variable)))

405

406

(defun sql-join-condition-for-m-n-association (object-1 object-2 association-end-2)

407

(bind ((table (primary-table-of (association-of association-end-2))))

408

`(sql-exists

409

(sql-subquery

410

:query

411

(sql-select

412

:columns (list 1)

413

:tables (list (sql-identifier :name ',(name-of table)))

414

:where ,(sql-join-condition-for object-1 object-2 association-end-2))))))

415

416

417

;;;----------------------------------------------------------------------------

418

;;; Operators

419

420

(defvar *sql-operators* (make-hash-table)

421

"Map from lisp function names to the corresponding SQL operator.")

422

423

(defun sql-operator-p (operator)

424

(gethash operator *sql-operators*))

425

426

(defun sql-operator-for (operator)

427

(gethash operator *sql-operators*))

428

429

(defun define-sql-operator (lisp-operator sql-operator)

430

(setf (gethash lisp-operator *sql-operators*) sql-operator))

431

432

(defun chained-operator (binary-operator &optional default)

433

(lambda (first-arg &rest more-args)

434

(if (null more-args)

435

default

436

(apply 'sql-and

437

(iter (for arg in more-args)

438

(for prev-arg previous arg initially first-arg)

439

(collect (funcall binary-operator prev-arg arg)))))))

440

441

(defun pairwise-operator (binary-operator &optional default)

442

(lambda (first-arg &rest more-args)

443

(if (null more-args)

444

default

445

(apply 'sql-and

446

(iter outer (for rest-args on more-args)

447

(for first previous (car rest-args) initially first-arg)

448

(iter (for second in rest-args)

449

                            (in outer (collect (funcall binary-operator first second)))))))))

450

451

(define-sql-operator 'eq 'sql-equal)

452

(define-sql-operator 'eql 'sql-equal)

453

(define-sql-operator 'equal 'sql-equal)

454

(define-sql-operator '= (chained-operator 'sql-= #t))

455

(define-sql-operator 'string= 'sql-string=)

456

457

(define-sql-operator 'and 'sql-and)

458

(define-sql-operator 'or 'sql-or)

459

(define-sql-operator 'not 'sql-not)

460

461

(define-sql-operator '> (chained-operator 'sql-> #t))

462

(define-sql-operator '< (chained-operator 'sql-< #t))

463

(define-sql-operator '>= (chained-operator 'sql->= #t))

464

(define-sql-operator '<= (chained-operator 'sql-<= #t))

465

(define-sql-operator '/= (pairwise-operator 'sql-<> #t))

466

467

(define-sql-operator '+ 'sql-+)

468

(define-sql-operator '- 'sql--)

469

(define-sql-operator '* 'sql-*)

470

(define-sql-operator '/ 'sql-/)

471

(define-sql-operator 'mod 'sql-%)

472

(define-sql-operator 'expt 'sql-^)

473

(define-sql-operator 'sqrt 'sql-\|/)

474

(define-sql-operator 'abs 'sql-@)

475

476

(define-sql-operator 'subseq 'sql-subseq)

477

(define-sql-operator 'strcat 'sql-\|\|)

478

479

(define-sql-operator 'like 'sql-like)

480

(define-sql-operator 'scan 'sql-regex-match)

481

482

(define-sql-operator 'null 'sql-is-null)

483

484

(defun sql-equal (first second &key check-nils)

485

(cond

486

((sql-null-literal-p first)

487

`(sql-is-null ,second))

488

((sql-null-literal-p second)

489

`(sql-is-null ,first))

490

((or (sql-literal-p first) (sql-literal-p second) (not check-nils))

491

`(sql-= ,first ,second))

492

(t

493

`(sql-or (sql-= ,first ,second) (sql-and (sql-is-null ,first) (sql-is-null ,second))))))

494

495

(defun sql-string= (string1 string2 &key (start1 0) end1 (start2 0) end2 check-nils)

496

(cond

497

((sql-null-literal-p string1)

498

`(sql-is-null ,string2))

499

((sql-null-literal-p string2)

500

`(sql-is-null ,string1))

501

((or (sql-literal-p string1) (sql-literal-p string2) (not check-nils))

502

`(sql-= ,(sql-subseq string1 start1 end1) ,(sql-subseq string2 start2 end2)))

503

(t

504

`(sql-or (sql-and (sql-is-null ,string1) (sql-is-null ,string2))

505

(sql-= ,(sql-subseq string1 start1 end1) ,(sql-subseq string2 start2 end2))))))

506

507

(defun sql-subseq (seq start &optional end)

508

"TODO: other sequnce types"

509

(if (or (not (numberp start)) (> start 0) end)

510

(sql-substring seq (sql-+ start 1) (sql-- (sql-length seq) start))

511

seq))

512

513

(defun sql-substring (str start length)

514

(sql-function-call :name "substring" :arguments (list str start length)))

515

516

(defun sql-regex-match (regex target &key (start 0) end)

517

"TODO: this works for PostgreSQL only"

518

(sql-~ (sql-subseq target start end) regex))

519

520

(defun sql-length (str)

521

(sql-function-call :name "char_length" :arguments (list str)))

522

523

;;;----------------------------------------------------------------------------

524

;;; Aggregate functions

525

526

(defvar *aggregate-functions* (make-hash-table)

527

"Map from lisp function symbol to the corresponing SQL aggregate function.")

528

529

(defun sql-aggregate-function-name-p (function-name)

530

(gethash function-name *aggregate-functions*))

531

532

(defun sql-aggregate-function-for (function-name)

533

(gethash function-name *aggregate-functions*))

534

535

(defun define-aggregate-function (lisp-function-name sql-function-name)

536

(setf (gethash lisp-function-name *aggregate-functions*) sql-function-name))

537

538

(define-aggregate-function 'length 'sql-count)

539

(define-aggregate-function 'min 'sql-min)

540

(define-aggregate-function 'max 'sql-max)

541

(define-aggregate-function 'sum 'sql-sum)

542

(define-aggregate-function 'avg 'sql-avg)

543

544

;;;----------------------------------------------------------------------------

545

;;; Literals

546

;;;

547

(defun sql-null-literal-p (sql)

548

(or (null sql)

549

(and (typep sql 'sql-literal)

550

(null (cl-rdbms::value-of sql))

551

(or (null (cl-rdbms::type-of sql))

552

(not (typep (cl-rdbms::type-of sql) 'cl-rdbms::sql-boolean-type))))))

553

554

(defun sql-literal-p (sql)

555

(typep sql 'cl-rdbms::sql-literal*))

556

557

(defun sql-false-literal ()

558

(sql-literal :value #f :type (make-instance 'cl-rdbms::sql-boolean-type)))

559

560

(defun sql-true-literal ()

561

(sql-literal :value #t :type (make-instance 'cl-rdbms::sql-booelan-type)))