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

Kind	Covered	All	%
expression	83	108	76.9
branch	10	16	62.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

;;; Persistent object base class

11

12

(defvar *make-persistent-instances* #t

13

"True means make-instance will make the new instance persistent by default.")

14

15

(defpclass* persistent-object ()

16

((oid

17

nil

18

:type (or null oid)

19

:persistent #f

20

     :documentation "Life time unique identifier of the object which can be remembered and may be used the load the object later.")

21

(persistent

22

:type boolean

23

:persistent #f

24

     :documentation "True means the object is known to be persistent, false means the object is known to be transient, unbound means the state is not yet determined. Actually, in the latter case slot-value-using-class will automatically determine whether the object is in the database or not. Therefore reading the persistent slot will always return either true or false.")

25

(transaction

26

nil

27

:accessor #f

28

:type t

29

:persistent #f

30

:documentation "A weak reference to the transaction to this object is currently attached to.")

31

(created

32

#f

33

:type boolean

34

:persistent #f

35

:documentation "True means the object was created in the current transaction.")

36

(modified

37

#f

38

:type boolean

39

:persistent #f

40

:documentation "True means the object was modified in the current transaction.")

41

(deleted

42

#f

43

:type boolean

44

:persistent #f

45

:documentation "True means the object was deleted in the current transaction.")

46

(cached-slots

47

nil

48

:type (list persistent-effective-slot-definition)

49

:persistent #f

50

     :documentation "A list of slots for which the slot values are currently cached in the object in the lisp VM. This list must be updated when database update happens outside of slot access (batch update, trigger, etc."))

51

(:default-initargs :persistent *make-persistent-instances*)

52

(:abstract #t)

53

   (:documentation "Base class for all persistent classes. If this class is not inherited by a persistent class then it is automatically added to the direct superclasses. There is only one persistent object instance in a transaction with a give oid therefore eq will return true iff the oids are equal."))

54

55

(defmacro with-making-persistent-instances (&body forms)

56

`(let ((*make-persistent-instances* #t))

57

,@forms))

58

59

(defmacro with-making-transient-instances (&body forms)

60

`(let ((*make-persistent-instances* #f))

61

,@forms))

62

63

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

64

;;; MOP methods

65

66

 (defmethod initialize-instance :around ((object persistent-object) &rest args &key persistent &allow-other-keys)

67

(when persistent

68

(ensure-exported (class-of object)))

69

(prog1 (apply #'call-next-method object :persistent #f args)

70

(when (eq persistent #t)

71

(make-persistent object)

72

(setf (created-p object) #t)

73

(setf (cached-slots-of object)

74

(collect-if #'cache-p (persistent-effective-slots-of (class-of object)))))))

75

76

(defmethod make-instance :before ((class persistent-class) &key &allow-other-keys)

77

(when (abstract-p class)

78

(error "Cannot make instances of abstract class ~A" class)))

79

80

;;;;;;;;;;;

81

;;; Utility

82

83

(defvar +persistent-object-class+ (find-class 'persistent-object))

84

85

(defun persistent-object-p (object)

86

(typep object 'persistent-object))

87

88

(defun p-eq (object-1 object-2)

89

   "Tests if two object references the same persistent object. Normally there at most one persistent object for each oid in a transaction so eq may be safely used. On the other hand huge transactions may require to throw away objects form the object cache which results in several instances for the same oid within the same transaction."

90

(or (eq object-1 object-2)

91

(= (id-of object-1)

92

(id-of object-2))))

93

94

(defun print-persistent-instance (object)

95

(declare (type persistent-object object))

96

(princ ":persistent ")

97

(princ (cond ((not (slot-boundp object 'persistent))

98

"#? ")

99

((persistent-p object)

100

"#t ")

101

(t "#f ")))

102

(if (and (slot-boundp object 'oid)

103

(oid-of object))

104

(princ (id-of object))

105

(princ "nil")))

106

107

(defprint-object (self persistent-object)

108

"Prints the oid of the object and whether the object is known to be persistent or transient."

109

(print-persistent-instance self))

110

111

(defun ensure-oid (object)

112

"Makes sure that the object has a valid oid."

113

(unless (oid-of object)

114

(setf (oid-of object) (make-new-oid (class-name-of object)))))

115

116

(defun id-of (object)

117

"Shortcut for the unique identifier number of the object."

118

(oid-id (oid-of object)))

119

120

(defun (setf class-name-of) (new-value object)

121

"Shortcut for the setter of the class name of the object."

122

(setf (oid-class-name (oid-of object)) new-value))

123

124

(defun id-value (object)

125

"Returns the RDBMS representation."

126

(id-of object))

127

128

(defun class-name-value (object)

129

"Returns the RDBMS representation."

130

(canonical-symbol-name (class-name-of object)))

131

132

(defun oid-values (object)

133

"Returns a list representation of the object oid in the order of the corresponding RDBMS columns."

134

(list (id-value object) (class-name-value object)))