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

Kind	Covered	All	%
expression	497	513	96.9
branch	45	46	97.8

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :cl-perec)

2

3

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

4

;;; Constants

5

6

(defparameter *lazy-collections* #f

7

"True means slot-value-using-class will by default return lazy collections.")

8

9

(defstruct unbound-value)

10

11

(defparameter +unbound-slot-value+

12

(make-unbound-value)

13

"This value is used to signal unbound slot value returned from database.")

14

15

(defmethod make-load-form ((instance unbound-value) &optional environment)

16

(declare (ignore environment))

17

'(make-unbound-value))

18

19

(defun unbound-slot-value-p (value)

20

(eq +unbound-slot-value+ value))

21

22

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

23

;;; RDBMS slot restorers

24

25

(defun restore-slot-value (slot rdbms-values)

26

"Provides convenient access to the arguments in the debugger."

27

(declare (optimize (debug 3)))

28

(funcall (reader-of slot) rdbms-values))

29

30

(defun restore-slot-set (object slot)

31

"Restores the non lazy list without local side effects from the database."

32

(mapcar #'object-reader

33

(select-records (oid-columns-of (table-of slot))

34

(list (name-of (table-of slot)))

35

(id-column-matcher-where-clause object (id-column-of slot)))))

36

37

(defun restore-1-n-association-end-set (object slot)

38

"Restores the non lazy list association end value without local side effects from the database."

39

(restore-slot-set object slot))

40

41

(defun restore-m-n-association-end-set (object slot)

42

"Restores the non lazy list association end value without local side effects from the database."

43

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

44

(mapcar #'object-reader

45

(select-records (columns-of slot)

46

(list (name-of (table-of slot)))

47

                             (id-column-matcher-where-clause object (id-column-of other-slot))))))

48

49

(defun restore-slot (object slot)

50

"Restores a single slot without local side effects from the database."

51

(values

52

(cond ((and (typep slot 'persistent-association-end-effective-slot-definition)

53

(eq (association-kind-of (association-of slot)) :1-1)

54

(secondary-association-end-p slot))

55

(restore-slot-value slot

56

(first

57

(select-records +oid-column-names+

58

(list (name-of (table-of slot)))

59

(sql-= (id-of object)

60

                                    (sql-identifier :name (id-column-of slot)))))))

61

((and (typep slot 'persistent-association-end-effective-slot-definition)

62

(eq (association-kind-of (association-of slot)) :1-n)

63

(eq (cardinality-kind-of slot) :n))

64

(if *lazy-collections*

65

               (make-instance 'persistent-1-n-association-end-set-container :object object :slot slot)

66

(restore-1-n-association-end-set object slot)))

67

((and (typep slot 'persistent-association-end-effective-slot-definition)

68

(eq (association-kind-of (association-of slot)) :m-n))

69

(if *lazy-collections*

70

               (make-instance 'persistent-m-n-association-end-set-container :object object :slot slot)

71

(restore-m-n-association-end-set object slot)))

72

((set-type-p (normalized-type-of slot))

73

(if *lazy-collections*

74

(make-instance 'persistent-slot-set-container :object object :slot slot)

75

(restore-slot-set object slot)))

76

(t

77

           ;; TODO enters and fails with #<DWIM-META-MODEL::EFFECTIVE-PROPERTY-AND-COMPUTED-EFFECTIVE-SLOT-DEFINITION-AND-PERSISTENT-EFFECTIVE-SLOT-DEFINITION FULL-NAME {F7BED59}>

78

(bind ((record

79

(first

80

(select-records (columns-of slot)

81

(list (name-of (table-of slot)))

82

(id-column-matcher-where-clause object)))))

83

(restore-slot-value slot record))))

84

slot))

85

86

(defun restore-prefetched-slots (object &optional (allow-missing #f))

87

   "Restores all prefetched slots at once without local side effects from the database. Executes a single select statement."

88

(if-bind slots (prefetched-slots-of (class-of object))

89

(bind ((tables (delete-duplicates (mapcar #'table-of slots)))

90

(record

91

(first

92

(select-records (mapcan (lambda (slot)

93

(mapcar (lambda (column)

94

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

95

(columns-of slot)))

96

slots)

97

                              (mapcar #L(sql-table-alias :name (name-of !1) :alias (name-of !1)) tables)

98

(apply #'sql-and

99

                                     (sql-= (sql-column-alias :table (name-of (first tables)) :column +id-column-name+)

100

                                            (sql-literal :type +oid-id-sql-type+ :value (id-of object)))

101

                                     (mapcar #L(sql-= (sql-column-alias :table (name-of (first tables)) :column +id-column-name+)

102

                                                      (sql-column-alias :table (name-of !1) :column +id-column-name+))

103

(rest tables)))))))

104

(assert (or record allow-missing))

105

(when record

106

(values

107

(iter (for i first 0 then (+ i (length (columns-of slot))))

108

(for slot in slots)

109

(collect (restore-slot-value slot (nthcdr i record))))

110

slots)))))

111

112

(defun restore-all-slots (object)

113

"Restores all slots wihtout local side effects from the database."

114

(bind (((values prefetched-slot-values prefetched-slots) (restore-prefetched-slots object))

115

(non-prefetched-slots (non-prefetched-slots-of (class-of object))))

116

(values (append prefetched-slot-values (mapcar #L(restore-slot object !1) non-prefetched-slots))

117

(append prefetched-slots non-prefetched-slots))))

118

119

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

120

;;; RDBMS slot storers

121

122

(defun store-slot-value (slot slot-value)

123

"Provides convenient access to the arguments in the debugger."

124

(declare (optimize (debug 3)))

125

(funcall (writer-of slot) slot-value))

126

127

(defun delete-slot-set (object slot)

128

(update-records (name-of (table-of slot))

129

(columns-of slot)

130

'(nil nil)

131

(id-column-matcher-where-clause object (id-column-of slot))))

132

133

(defun store-slot-set (object slot value)

134

"Stores the non lazy list without local side effects into the database."

135

(delete-slot-set object slot)

136

(when value

137

(update-records (name-of (table-of slot))

138

(columns-of slot)

139

(object-writer object)

140

(id-column-list-matcher-where-clause value))))

141

142

(defun store-1-n-association-end-set (object slot value)

143

"Stores the non lazy list association end value without local side effects into the database."

144

(store-slot-set object slot value))

145

146

(defun delete-m-n-association-end-set (object slot)

147

(delete-records (name-of (table-of slot))

148

(id-column-matcher-where-clause object (id-column-of slot))))

149

150

(defun insert-into-m-n-association-end-set (object slot value)

151

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

152

(insert-records (name-of (table-of slot))

153

(append (columns-of slot) (columns-of other-slot))

154

(append (object-writer value) (object-writer object)))))

155

156

(defun store-m-n-association-end-set (object slot value)

157

"Stores the non lazy list association end value without local side effects into the database."

158

(delete-m-n-association-end-set object slot)

159

(when value

160

(mapc #L(insert-into-m-n-association-end-set object slot !1) value)))

161

162

(defun store-slot (object slot value)

163

"Stores a single slot without local side effects into the database."

164

(cond ((and (typep slot 'persistent-association-end-effective-slot-definition)

165

(eq (association-kind-of (association-of slot)) :1-1)

166

(secondary-association-end-p slot))

167

(when-bind other-object (slot-value-using-class (class-of object) object slot)

168

(bind ((other-slot (other-effective-association-end-for (class-of other-object) slot)))

169

(store-slot other-object other-slot nil)))

170

(when value

171

(bind ((other-slot (other-effective-association-end-for (class-of value) slot)))

172

(store-slot value other-slot object))))

173

((and (typep slot 'persistent-association-end-effective-slot-definition)

174

(eq (association-kind-of (association-of slot)) :1-n)

175

(eq (cardinality-kind-of slot) :n))

176

(when (or value

177

(persistent-p object))

178

(store-1-n-association-end-set object slot value)))

179

((and (typep slot 'persistent-association-end-effective-slot-definition)

180

(eq (association-kind-of (association-of slot)) :m-n))

181

(when (or value

182

(persistent-p object))

183

(store-m-n-association-end-set object slot value)))

184

((set-type-p (normalized-type-of slot))

185

(store-slot-set object slot value))

186

(t

187

(when-bind columns (columns-of slot)

188

(update-records (name-of (table-of slot))

189

columns

190

(store-slot-value slot value)

191

(id-column-matcher-where-clause object))))))

192

193

(defun store-prefetched-slots (object)

194

   "Stores all prefetched slots without local side effects into the database. Executes one insert statement for each table."

195

(bind ((prefetched-slots (prefetched-slots-of (class-of object)))

196

(tables (delete-duplicates (mapcar #'table-of prefetched-slots))))

197

(dolist (table tables)

198

(bind ((slots (collect-if #L(eq (table-of !1) table) prefetched-slots))

199

              (slot-values (mapcar #L(cached-slot-boundp-or-value-using-class (class-of object) object !1) slots))

200

(oid-columns (oid-columns-of table))

201

(columns (mappend #'columns-of slots))

202

(oid-values (oid-values object))

203

(rdbms-values (mappend #L(store-slot-value !1 !2) slots slot-values)))

204

(if (persistent-p object)

205

             (update-records (name-of table) columns rdbms-values (id-column-matcher-where-clause object))

206

             (insert-records (name-of table) (append oid-columns columns) (append oid-values rdbms-values)))))

207

(unless (persistent-p object)

208

(dolist (table (set-difference (data-tables-of (class-of object)) tables))

209

(insert-records (name-of table) (oid-columns-of table) (oid-values object))))))

210

211

(defun store-all-slots (object)

212

"Stores all slots wihtout local side effects into the database."

213

(store-prefetched-slots object)

214

(mapc #L(store-slot object !1 (cached-slot-boundp-or-value-using-class (class-of object) object !1))

215

(non-prefetched-slots-of (class-of object))))

216

217

;;;;;;;;;;;

218

;;; Utility

219

220

(defun id-column-matcher-where-clause (object &optional (id-name +id-column-name+))

221

(sql-binary-operator :name '=

222

:left (sql-identifier :name id-name)

223

                        :right (sql-literal :type +oid-id-sql-type+ :value (id-of object))))

224

225

(defun id-column-list-matcher-where-clause (values &optional (id-name +id-column-name+))

226

(sql-binary-operator :name 'in

227

:left (sql-identifier :name id-name)

228

:right (mapcar (lambda (value)

229

                                         (sql-literal :type +oid-id-sql-type+ :value (id-of value)))

230

values)))