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

Kind	Covered	All	%
expression	199	276	72.1
branch	7	20	35.0

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

(defun object-exists-in-database-p (object)

10

"Returns true if the object can be found in the database"

11

(and (oid-of object)

12

(select-records '(1)

13

(list (name-of (primary-table-of (class-of object))))

14

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

15

16

(defun debug-persistent-p (object)

17

"Same as persistent-p except it never prefetches slot values. Use for debug purposes."

18

(if (slot-boundp object 'persistent)

19

(persistent-p object)

20

(progn

21

         ;; do not count this existence check as a select, because it will not execute in release code

22

(when (oid-of object)

23

(decf (select-counter-of (command-counter-of *transaction*))))

24

(setf (persistent-p object) (object-exists-in-database-p object)))))

25

26

(defgeneric initialize-revived-slot-p (slot)

27

   (:documentation "When a persistent instance is revived the slots marked here will be initialized by shared-initialize. The default implementation will not initialize persistent slots.")

28

29

(:method (slot)

30

#t)

31

32

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

33

#f))

34

35

(defgeneric initialize-revived-instance (instance &key &allow-other-keys)

36

   (:documentation "When a revived instance is initialized slots marked with initialize-revived-slot-p will be passed down to be initialized by shared-initialize.")

37

38

(:method ((instance persistent-object) &rest args &key oid &allow-other-keys)

39

(assert oid)

40

(bind ((slot-names

41

(iter (for slot in (class-slots (class-of instance)))

42

(when (initialize-revived-slot-p slot)

43

(collect (slot-definition-name slot))))))

44

(apply #'shared-initialize instance slot-names args))))

45

46

(defgeneric make-revived-instance (class &key &allow-other-keys)

47

   (:documentation "Creates a new instance representing the given oid as its identity. The instance will not be associated with the current transaction nor will it be stored in the database. The instance may or may not be known to be either persistent or transient. This generic function should not be called outside of cl-perec but methods may be defined on it.")

48

49

(:method ((class persistent-class) &rest args &key &allow-other-keys)

50

(apply #'initialize-revived-instance (allocate-instance class) args)))

51

52

(defgeneric cache-object (thing)

53

   (:documentation "Attaches an object to the current transaction. The object must be already present in the database, so load-instance would return an instance for it. The purpose of this method is to cache objects returned by a query or when the existence may be guaranteed by some other means.")

54

55

(:method ((values list))

56

(assert (= 2 (length values)))

57

            (cache-object (make-oid :id (first values) :class-name (symbol-from-canonical-name (second values)))))

58

59

(:method ((oid oid))

60

(aif (cached-object-of oid)

61

(prog1 it

62

(setf (persistent-p it) #t))

63

                 (setf (cached-object-of oid) (make-revived-instance (find-class (oid-class-name oid)) :oid oid :persistent #t))))

64

65

(:method ((object persistent-object))

66

(debug-only (assert (debug-persistent-p object)))

67

(setf (cached-object-of (oid-of object)) object)))

68

69

(define-condition object-not-found-error (error)

70

((oid :accessor oid-of :initarg :oid))

71

(:report (lambda (c stream)

72

(format stream "Object not found for oid ~A" (oid-of c)))))

73

74

(defgeneric load-instance (thing &key otherwise prefetch skip-existence-check)

75

   (:documentation "Loads an object with the given oid and attaches it with the current transaction if not yet attached. If no such object exists in the database then one of two things may happen. If the value of otherwise is a lambda function with one parameter then it is called with the given object. Otherwise the value of otherwise is returned. If prefetch is false then only the identity of the object is loaded, otherwise all slots are loaded. Note that the object may not yet be committed into the database and therefore may not be seen by other transactions. Also objects not yet committed by other transactions are not returned according to transaction isolation rules. The object returned will be kept for the duration of the transaction and any subsequent calls to load, select, etc. will return the exact same object for which eq is required to return #t.")

76

77

(:method ((object persistent-object) &rest args)

78

(apply #'load-instance (oid-of object) args))

79

80

(:method ((oid oid) &key (otherwise nil otherwise-provided-p) (prefetch #f) (skip-existence-check #f))

81

(declare (ignore prefetch))

82

(flet ((object-not-found ()

83

(cond ((not otherwise-provided-p)

84

(error 'object-not-found-error :oid oid))

85

((functionp otherwise)

86

(funcall otherwise oid))

87

(t otherwise))))

88

(aif (cached-object-of oid)

89

it

90

                   (let ((new-object (make-revived-instance (find-class (oid-class-name oid)) :oid oid)))

91

;; REVIEW: is this the correct thing to do?

92

;; we push the new-object into the cache first

93

;; even tough we are unsure if the object is persistent or not

94

                     ;; because prefetching slots may recursively call load-instance from persistent-p

95

;; we also want to have non persistent objects in the cache anyway

96

(setf (cached-object-of (oid-of new-object)) new-object)

97

(if (or skip-existence-check (persistent-p new-object))

98

new-object

99

(object-not-found)))))))

100

101

(defgeneric purge-instance (object)

102

(:documentation "Purges the given instance without respect to associations and references to it.")

103

104

(:method ((object persistent-object))

105

(ensure-exported (class-of object))

106

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

107

(delete-records (name-of table)

108

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

109

110

(defgeneric purge-instances (class)

111

   (:documentation "Purges all instances of the given class without respect to associations and references.")

112

113

(:method ((class-name symbol))

114

(purge-instances (find-class class-name)))

115

116

(:method ((class persistent-class))

117

(ensure-exported class)

118

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

119

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

120

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

121

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

122

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

123

(mapc #'ensure-exported super-classes)

124

(mapc #'ensure-exported sub-classes)

125

(when (primary-tables-of class)

126

                ;; delete instances from the primary tables of super classes and non primary data tables of sub classes

127

(dolist (table (delete-if #L(or (eq !1 class-primary-table)

128

                                                (member !1 sub-primary-tables))

129

(delete-duplicates

130

(append super-primary-tables

131

                                                   (mappend #'data-tables-of sub-classes)))))

132

(when table

133

(delete-records (name-of table)

134

                                    (sql-in (sql-identifier :name +id-column-name+)

135

(sql-subquery :query

136

                                                          (apply #'sql-union

137

                                                                 (mapcar #L(sql-select :columns (list +id-column-name+)

138

                                                                                       :tables (list (name-of !1)))

139

                                                                         (cdr (primary-tables-of class)))))))))

140

;; delete instances from the primary tables of sub classes

141

(dolist (table (list* class-primary-table sub-primary-tables))

142

(when table

143

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

144

145

(defmacro revive-instance (place &rest args)

146

"Load object found in PLACE into the current transaction, update PLACE if needed."

147

(with-unique-names (instance)

148

`(bind ((,instance ,place))

149

(when ,instance

150

(assert (or (not (instance-in-transaction-p ,instance))

151

(eq (transaction-of ,instance)

152

*transaction*)))

153

(setf ,place (load-instance ,instance ,@args))))))

154

155

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

156

;;; Making objects persistent and transient

157

158

(defmethod make-persistent ((object persistent-object))

159

(ensure-oid object)

160

(let ((created-objects (current-created-objects))

161

(deleted-objects (current-deleted-objects)))

162

(if (find-item deleted-objects object)

163

(delete-item deleted-objects object)

164

(insert-item created-objects object)))

165

(store-all-slots object)

166

(setf (persistent-p object) #t)

167

(setf (cached-object-of (oid-of object)) object))

168

169

(defmethod make-transient ((object persistent-object))

170

(let ((created-objects (current-created-objects))

171

(deleted-objects (current-deleted-objects)))

172

(if (find-item created-objects object)

173

(delete-item created-objects object)

174

(insert-item deleted-objects object)))

175

(with-caching-slot-values

176

(restore-all-slots object))

177

(purge-instance object)

178

(setf (persistent-p object) #f)

179

(remove-cached-object object))