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

Kind	Covered	All	%
expression	362	374	96.8
branch	39	40	97.5

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

;;; MOP methods

11

12

;; allows persistent keyword argument for persistent-direct-slot-definitions according to CLOS mop

13

;; even though there is no such slot in the class

14

(defmethod shared-initialize :around ((slot persistent-direct-slot-definition) slot-names

15

                                       &rest args &key persistent &allow-other-keys)

16

(declare (ignore persistent))

17

(apply #'call-next-method slot slot-names args))

18

19

(defmethod make-instance ((object identity-preserving-class) &key instance &allow-other-keys)

20

;; used in class finalization protocol when instantiating direct slot definitions

21

;; this allows associations to be defined independently of direct slot definitions

22

;; and ensure-class to be called without loosing the old non association direct slot definitions

23

(aif instance

24

it

25

(call-next-method)))

26

27

(defmethod initialize-instance :around ((class persistent-class) &rest args)

28

(apply #'shared-ininitialize-around-persistent-class class #'call-next-method args))

29

30

(defmethod reinitialize-instance :around ((class persistent-class) &rest args)

31

;; update type dependencies first

32

(mapc #L(delete! class (depends-on-of !1))

33

(depends-on-me-of class))

34

(setf (depends-on-me-of class) nil)

35

;; emulate shared initialize which is not allowed to be overridden

36

   (apply #'shared-ininitialize-around-persistent-class class #'call-next-method :name (class-name class) args))

37

38

(defmethod reinitialize-instance :before ((association persistent-association) &key &allow-other-keys)

39

(mapc #L(delete! association (depends-on-of !1))

40

(associated-classes-of association)))

41

42

(defmethod shared-initialize :after ((association persistent-association) slot-names &key &allow-other-keys)

43

(mapc #L(pushnew association (depends-on-of !1))

44

(associated-classes-of association)))

45

46

(defmethod validate-superclass ((class standard-class)

47

(superclass persistent-class))

48

t)

49

50

(defmethod validate-superclass ((class persistent-class)

51

(superclass standard-class))

52

t)

53

54

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

55

                                          &key instance persistent association &allow-other-keys)

56

(cond (instance

57

(class-of instance))

58

(association

59

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

60

(persistent

61

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

62

(t

63

(call-next-method))))

64

65

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

66

                                             &key instance persistent association &allow-other-keys)

67

(cond (instance

68

(class-of instance))

69

(association

70

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

71

(persistent

72

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

73

(t

74

(call-next-method))))

75

76

(defmethod compute-effective-slot-definition ((class persistent-class)

77

slot-name

78

direct-slot-definitions)

79

(if (some (lambda (slot)

80

(typep slot 'persistent-direct-slot-definition))

81

direct-slot-definitions)

82

       (bind ((standard-initargs (compute-standard-effective-slot-definition-initargs class direct-slot-definitions))

83

              (slot-initargs (compute-persistent-effective-slot-definition-initargs class direct-slot-definitions))

84

(initargs (append slot-initargs standard-initargs))

85

              (effective-slot-class (apply #'effective-slot-definition-class class :persistent #t initargs)))

86

(prog1-bind effective-slot-definition

87

             (apply #'make-instance effective-slot-class :direct-slots direct-slot-definitions initargs)

88

(bind ((type (slot-definition-type effective-slot-definition))

89

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

90

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

91

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

92

(unbound-subtype-p type)))

93

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

94

(null-subtype-p type)))

95

(initfunction (slot-definition-initfunction effective-slot-definition)))

96

(when (and (or null-subtype-p

97

(set-type-p type))

98

(not unbound-subtype-p)

99

(not initfunction))

100

(setf (slot-definition-initfunction effective-slot-definition)

101

(constantly nil))))))

102

(call-next-method)))

103

104

(defun compute-standard-effective-slot-definition-initargs (class direct-slot-definitions)

105

#+sbcl(sb-pcl::compute-effective-slot-definition-initargs class direct-slot-definitions)

106

#-sbcl(not-yet-implemented))

107

108

(defun compute-persistent-effective-slot-definition-initargs (class direct-slot-definitions)

109

(iter (for slot-option-name in (delete-duplicates

110

                                   (collect-if #L(not (eq (symbol-package !1) (find-package :common-lisp)))

111

                                               (mapcan #L(mapcar #'slot-definition-name

112

                                                                 (class-slots (class-of !1)))

113

                                                       direct-slot-definitions))))

114

(bind ((specific-direct-slot-definitions

115

                 (collect-if #L(find slot-option-name (class-slots (class-of !1)) :key 'slot-definition-name)

116

direct-slot-definitions)))

117

(appending

118

(compute-persistent-effective-slot-definition-option class

119

                                                                 (first (sort (copy-list specific-direct-slot-definitions)

120

                                                                              #L(subtypep (class-of !1) (class-of !2))))

121

                                                                 slot-option-name

122

                                                                 specific-direct-slot-definitions)))))

123

124

 (defgeneric compute-persistent-effective-slot-definition-option (class direct-slot slot-option-name direct-slot-definitions)

125

(:method ((class persistent-class)

126

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

127

slot-option-name

128

direct-slot-definitions)

129

(when (member slot-option-name '(cache prefetch index unique type-check))

130

(some #L(slot-initarg-and-value !1 slot-option-name) direct-slot-definitions)))

131

132

(:method ((class persistent-class)

133

(direct-slot persistent-association-end-direct-slot-definition)

134

slot-option-name

135

direct-slot-definitions)

136

(if (member slot-option-name '(min-cardinality max-cardinality association))

137

(some #L(slot-initarg-and-value !1 slot-option-name) direct-slot-definitions)

138

(call-next-method))))

139

140

(defmethod finalize-inheritance :after ((class persistent-class))

141

(invalidate-computed-slot class 'persistent-direct-super-classes)

142

(invalidate-computed-slot class 'persistent-effective-super-classes)

143

(invalidate-computed-slot class 'persistent-direct-sub-classes)

144

(invalidate-computed-slot class 'persistent-effective-sub-classes)

145

(mapc #L(ensure-slot-reader* class !1)

146

(collect-if #L(set-type-p (normalized-type-of !1))

147

(persistent-effective-slots-of class))))

148

149

(defmethod compute-slots :after ((class persistent-class))

150

   "Invalidates the cached slot value of persistent-effective-slots whenever the effective slots are recomputed, so that all dependent computed state will be invalidated and recomputed when requested."

151

(invalidate-computed-slot class 'persistent-effective-slots))

152

153

;;;;;;;;;;;

154

;;; Utility

155

156

(defun ensure-persistent-object-class (name direct-superclasses)

157

(if (eq 'persistent-object name)

158

direct-superclasses

159

(let ((persistent-object (find-class 'persistent-object))

160

(persistent-class (find-class 'persistent-class)))

161

(if (find-if (lambda (direct-superclass)

162

(member persistent-class

163

(compute-class-precedence-list

164

(class-of direct-superclass))))

165

direct-superclasses)

166

direct-superclasses

167

(append direct-superclasses (list persistent-object))))))

168

169

(defun process-direct-slot-definitions (direct-slots)

170

(loop for direct-slot :in direct-slots

171

collect (if (or (getf direct-slot :instance)

172

(getf direct-slot :persistent))

173

direct-slot

174

(if (hasf direct-slot :persistent)

175

;; remove :persistent nil

176

(remove-keywords direct-slot :persistent)

177

;; add default :persistent t

178

(append direct-slot '(:persistent t))))))

179

180

(defun association-direct-slot-definitions (class)

181

(when (slot-boundp class 'depends-on)

182

(let ((depends-on-associations

183

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

184

(depends-on-of class))))

185

(mappend (lambda (association)

186

(let ((association-end-definitions

187

(collect-if #L(eq (class-name class) (getf !1 :class))

188

(association-end-definitions-of association))))

189

(mapcar #L(append (list :name (getf !1 :slot)

190

:association association

191

:persistent #t)

192

                                     (remove-keywords !1 :slot :class :accessor))

193

association-end-definitions)))

194

depends-on-associations))))

195

196

;; this is not the real shared-initialize because portable programs are not allowed to override that

197

 ;; so we are somewhat emulating it by calling this function from both initialize-instance and reinitialize-instance

198

(defun shared-ininitialize-around-persistent-class (class call-next-method &rest args

199

                                                     &key name direct-slots direct-superclasses &allow-other-keys)

200

;; call initialize-instance or reinitialize-instance next method

201

(prog1

202

(apply call-next-method

203

class

204

:direct-slots (append (process-direct-slot-definitions direct-slots)

205

(association-direct-slot-definitions class))

206

:direct-superclasses (ensure-persistent-object-class name direct-superclasses)

207

:abstract (first (getf args :abstract))

208

(remove-keywords args :direct-slots :direct-superclasses :abstract))

209

(setf (find-persistent-class name) class)

210

(invalidate-computed-slot class 'persistent-direct-slots)

211

;; update type specific class dependencies

212

(mapc #L(bind ((type (normalized-type-for (slot-definition-type !1))))

213

(when (set-type-p type)

214

(bind ((associated-class (find-class (set-type-class-for type))))

215

(pushnew class (depends-on-of associated-class))

216

(pushnew associated-class (depends-on-me-of class)))))

217

(persistent-direct-slots-of class))

218

(mapc #L(bind ((association (association-of !1))

219

(association-end-position

220

                     (position (slot-definition-name !1) (association-end-definitions-of association)

221

:key #L(getf !1 :slot))))

222

(if (= 0 association-end-position)

223

(setf (primary-association-end-of association) !1)

224

(setf (secondary-association-end-of association) !1)))

225

(collect-if #L (typep !1 'persistent-association-end-direct-slot-definition)

226

(class-direct-slots class)))))

227

228

(defun ensure-slot-reader* (class slot)

229

(bind ((reader (concatenate-symbol (first (some #'slot-definition-readers (direct-slots-of slot))) "*"))

230

(reader-gf (ensure-generic-function reader :lambda-list '(object))))

231

(ensure-method reader-gf

232

`(lambda (object)

233

(with-lazy-collections

234

(slot-value-using-class ,class object ,slot)))

235

:specializers (list class))))

236

237

(defun slot-initarg-and-value (object slot-name)

238

(when (slot-boundp object slot-name)

239

(list (first (slot-definition-initargs (find-slot (class-of object) slot-name)))

240

(slot-value object slot-name))))