Coverage report: /home/ati/workspace/perec/query/result-set.lisp

Kind	Covered	All	%
expression	168	261	64.4
branch	10	18	55.6

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

(declaim (optimize (debug 3) (safety 3) (speed 0)))

10

11

;;;; This file contains classes and methods for storing, filtering, mapping

12

;;;; results of SQL queries.

13

;;;;

14

;;;; TODO: filters are not lazy

15

;;;; TODO: scrolled-result-set should add an ORDER-BY clause to the query to make it deterministic

16

17

18

;;;

19

;;; Result-set

20

;;;

21

22

(defclass* result-set ()

23

())

24

25

(defgeneric open-result-set (type sql-query)

26

(:documentation "Returns a new result-set which is the result of the sql-query."))

27

28

(defgeneric close-result-set (result-set)

29

(:documentation "Closes the result-set. After this operation the result-set cannot be accessed.")

30

(:method (result-set)

31

(values)))

32

33

(defgeneric revive-result-set! (result-set)

34

(:documentation "Refreshes the result set to be valid in the current transaction.")

35

(:method (result-set)

36

(values)))

37

38

(defgeneric record-count-of (result-set)

39

(:documentation "Returns the number of records in RESULT-SET.")

40

(:method ((result-set abstract-container))

41

(size result-set)))

42

43

(defgeneric records-of (result-set &optional start end)

44

(:documentation "Returns records of RESULT-SET as a sequence from START index

45

(inclusive, default is 0) to END index (exclusive, default is the number of records).")

46

(:method :around (result-set &optional (start 0) end)

47

(bind ((size (record-count-of result-set)))

48

(unless end (setf end size))

49

              (unless (<= 0 start size) (error "Start index ~D out of range for result-set: ~A" start result-set))

50

              (unless (<= 0 end size) (error "End index ~D out of range for result-set: ~A" end result-set))

51

              (unless (<= start end) (error "Start index ~D is greater than end index ~D" start end))

52

(if (= start end)

53

nil

54

(call-next-method result-set start end))))

55

(:method ((result-set iteratable-container-mixin) &optional start end)

56

(iter (for i from start below end)

57

                  (collect (nth-element result-set i)))) ; FIXME: don't use nth-element here, O(N^2)

58

(:method ((result-set array-container) &optional start end)

59

(iter (for i from start below end)

60

(collect (nth-element result-set i)))))

61

62

(defgeneric to-list (result &optional flatp)

63

(:documentation "Converts the result to a list.

64

If FLATP is true then the rows are flattened (useful when they contain only one column).")

65

(:method ((result list) &optional flatp)

66

(if flatp (apply 'nconc result) result))

67

(:method ((result contents-as-list-mixin) &optional flatp)

68

(to-list (contents result) flatp))

69

(:method ((result iteratable-container-mixin) &optional flatp)

70

(iter (with iterator = (make-iterator result))

71

(while (current-element-p iterator))

72

(if flatp

73

(appending (coerce (current-element iterator) 'list))

74

(collect (coerce (current-element iterator) 'list)))

75

(move-forward iterator)))

76

(:method ((result result-set) &optional flatp)

77

(if flatp

78

(iter (for record in-sequence (records-of result))

79

(appending (coerce record 'list)))

80

(coerce (records-of result) 'list)))

81

(:method ((result scroll) &optional flatp) ; for testing only

82

            (iter outer                       ; (called from code generated by the debug compiler)

83

84

(for page from 0)

85

(for dummy first (first-page! result) then (next-page! result))

86

(while (= page (page result)))

87

(for elements = (elements result))

88

(while (> (length elements) 0))

89

(iter (for element in-sequence elements)

90

(in outer

91

(if flatp

92

(appending (coerce element 'list))

93

(collect (coerce element 'list))))))))

94

95

(defgeneric to-scroll (result-set)

96

(:documentation "Converts the result set to a scroll.")

97

(:method ((result-set scroll))

98

result-set)

99

(:method ((result-set result-set))

100

(make-instance 'result-set-scroll :result-set result-set)))

101

102

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

103

;;; Scroll

104

;;;

105

(defclass* result-set-scroll (fixed-size-scroll result-set)

106

((inner-result-set :initarg :result-set)

107

(page 0 :accessor page)

108

(page-size 10 :accessor page-size)))

109

110

(defmethod element-count ((scroll result-set-scroll))

111

(record-count-of (inner-result-set-of scroll)))

112

113

(defmethod page-count ((scroll result-set-scroll))

114

(values (ceiling (/ (element-count scroll) (page-size scroll)))))

115

116

(defmethod elements ((scroll result-set-scroll))

117

(bind ((inner (inner-result-set-of scroll))

118

(start (* (page scroll) (page-size scroll)))

119

(end (min (+ start (page-size scroll)) (record-count-of inner)))

120

(records (when (> end start) (records-of inner start end))))

121

(coerce records 'vector)))

122

123

(defmethod revive-scroll! ((scroll result-set-scroll))

124

(revive-result-set! scroll))

125

126

(defmethod revive-result-set! ((result-set result-set-scroll))

127

(revive-result-set! (inner-result-set-of result-set)))

128

129

(defmethod close-result-set ((result-set result-set-scroll))

130

(close-result-set (inner-result-set-of result-set)))

131

132

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

133

;;; Transformers

134

135

;;;

136

;;; Base class for transformers

137

;;;

138

(defclass* result-set-transformer (result-set)

139

((inner :type result-set)))

140

141

(defmethod close-result-set ((result-set result-set-transformer))

142

(close-result-set (inner-of result-set)))

143

144

(defmethod revive-result-set! ((result-set result-set-transformer))

145

(revive-result-set! (inner-of result-set))

146

(update-contents! result-set))

147

148

(defgeneric update-contents! (result-set)

149

(:method (result-set)

150

(values)))

151

152

;;;

153

;;; Ordered result-set

154

;;;

155

;;; TODO: lazyness

156

157

(defclass* ordered-result-set (list-container result-set-transformer)

158

((lessp :type function)))

159

160

(defun make-ordered-result-set (result-set lessp)

161

(bind ((instance (make-instance 'ordered-result-set :inner result-set :lessp lessp)))

162

(update-contents! instance)

163

instance))

164

165

(defmethod update-contents! ((result-set ordered-result-set))

166

(with-slots (contents inner lessp) result-set

167

(setf contents (sort (records-of inner) lessp)))

168

(values))

169

170

;;;

171

;;; Filtered result-set

172

;;;

173

;;; TODO: lazyness

174

175

(defclass* filtered-result-set (list-container result-set-transformer)

176

((predicate :type function)))

177

178

(defun make-filtered-result-set (result-set predicate)

179

(bind ((instance (make-instance 'filtered-result-set :inner result-set :predicate predicate)))

180

(update-contents! instance)

181

instance))

182

183

(defmethod update-contents! ((result-set filtered-result-set))

184

(with-slots (contents inner predicate) result-set

185

(setf contents (collect-elements (records-of inner) :filter predicate)))

186

(values))

187

188

189

;;;

190

;;; Unique filtered result-set

191

;;;

192

;;; TODO: lazyness

193

(defclass* unique-result-set (list-container result-set-transformer)

194

((test-fn :type function)))

195

196

(defun make-unique-result-set (result-set &key (test #'equal))

197

(bind ((instance (make-instance 'unique-result-set :inner result-set :test-fn test)))

198

(update-contents! instance)

199

instance))

200

201

(defmethod update-contents! ((result-set unique-result-set))

202

(with-slots (contents inner test-fn) result-set

203

(setf contents

204

(with-iterator (iterator (records-of inner) :unique #t :test test-fn)

205

(collect-elements iterator)))))

206

207

;;;

208

;;; Mapped result-set

209

;;;

210

(defclass* mapped-result-set (result-set-transformer)

211

((map-fn :type function)))

212

213

(defun make-mapped-result-set (result-set map-fn)

214

(make-instance 'mapped-result-set :inner result-set :map-fn map-fn))

215

216

(defmethod record-count-of ((result-set mapped-result-set))

217

(record-count-of (inner-of result-set)))

218

219

(defmethod records-of ((result-set mapped-result-set) &optional start end)

220

(collect-elements (records-of (inner-of result-set) start end)

221

:transform (map-fn-of result-set)))

222

223

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

224

;;; Sources

225

226

;;;

227

;;; List result-set

228

;;;

229

(defclass* list-result-set (list-container result-set)

230

())

231

232

(defun make-list-result-set (list)

233

(aprog1

234

(make-instance 'list-result-set)

235

(setf (contents it) list)))

236

237

(defmethod revive-result-set! ((result-set list-result-set))

238

(dolist (record (contents result-set))

239

(mapl #L(when (persistent-object-p (car !1)) (revive-instance (car !1)))

240

record)))

241

242

243

;;;

244

;;; Simple SQL result set

245

;;;

246

(defclass* simple-result-set (list-container result-set)

247

((sql-query))

248

(:documentation "Retrieves all records at once as a list."))

249

250

(defmethod open-result-set ((type (eql 'list)) sql-query)

251

(bind ((instance (make-instance 'simple-result-set :sql-query sql-query)))

252

(revive-result-set! instance)

253

instance))

254

255

(defmethod revive-result-set! ((result-set simple-result-set))

256

(setf (contents result-set) (execute (sql-query-of result-set))))

257

258

;;;

259

;;; Scrolled SQL result set

260

;;;

261

(defclass* scrolled-result-set (result-set)

262

((record-count :type integer)

263

(sql-query))

264

(:documentation "Retrieves the records using OFFSET and LIMIT in the SQL query."))

265

266

(defmethod open-result-set ((type (eql 'scroll)) sql-query)

267

(bind ((instance (make-instance 'scrolled-result-set :sql-query sql-query)))

268

(revive-result-set! instance)

269

instance))

270

271

(defmethod revive-result-set! ((result-set scrolled-result-set))

272

(with-slots (sql-query) result-set

273

(bind ((columns (cl-rdbms::columns-of sql-query)))

274

(setf (cl-rdbms::columns-of sql-query) (list (cl-rdbms::sql-count-*))

275

(record-count-of result-set) (first (first (execute sql-query)))

276

(cl-rdbms::columns-of sql-query) columns)))

277

(values))

278

279

(defmethod records-of ((result-set scrolled-result-set) &optional start end)

280

(setf (cl-rdbms::offset-of (sql-query-of result-set)) start

281

(cl-rdbms::limit-of (sql-query-of result-set)) (- end start))

282

(execute (sql-query-of result-set)))

283

284

;;;

285

;;; Lazy SQL result-set (postgres only)

286

;;;

287

;; TODO: resurrect

288

#|

289

(defclass* lazy-result-set (result-set)

290

((clsql-result-set :type clsql-postgresql::postgresql-result-set)

291

(current-record :type list))

292

(:documentation "Retrieves the records using an SQL cursor."))

293

294

(defmethod open-result-set ((type (eql 'lazy)) sql-query)

295

(assert (typep *database* 'postgresql))

296

(bind (((values clsql-result-set num-of-columns num-of-rows)

297

(clsql-sys:database-query-result-set sql-query database

298

:full-set t

299

:result-types :auto)))

300

(make-instance 'lazy-result-set

301

:clsql-result-set clsql-result-set

302

:current-record (make-list num-of-columns))))

303

304

(defmethod close-result-set ((result-set lazy-result-set))

305

(clsql-sys:database-dump-result-set (clsql-result-set-of result-set)

306

(database-of result-set)))

307

308

(defmethod record-count-of ((result-set lazy-result-set))

309

(clsql-postgresql::postgresql-result-set-num-tuples (clsql-result-set-of result-set)))

310

311

(defmethod records-of ((result-set lazy-result-set) &optional start end)

312

(iter (for i from start below end)

313

(setf (clsql-postgresql::postgresql-result-set-tuple-index

314

(clsql-result-set-of result-set))

315

i)

316

(clsql-sys:database-store-next-row (clsql-result-set-of result-set)

317

(database-of result-set)

318

(current-record-of result-set))

319

(collect (copy-list (current-record-of result-set)))))

320

|#