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

Kind	Covered	All	%
expression	141	146	96.6
branch	13	14	92.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :cl-perec)

2

3

 ;; TODO: make sure that 1-1 and 1-n associations both store the foreign key in the primary-association-end's table

4

5

(defcclass* persistent-association (exportable)

6

((name

7

:type symbol

8

     :documentation "Unique name of the association. This name can be used to find the association using find-association.")

9

(association-end-definitions

10

(compute-as nil)

11

:type list

12

:documentation "Canonical form of the persistent association end direct slot definitions.")

13

(primary-association-end

14

(compute-as nil)

15

:type persistent-association-end-direct-slot-definition)

16

(secondary-association-end

17

(compute-as nil)

18

:type persistent-association-end-direct-slot-definition)

19

(association-ends

20

(compute-as (list (primary-association-end-of -self-) (secondary-association-end-of -self-)))

21

:type (list persistent-association-end-direct-slot-definition))

22

(associated-classes

23

(compute-as (list (find-class (getf (first (association-end-definitions-of -self-)) :class))

24

                       (find-class (getf (second (association-end-definitions-of -self-)) :class))))

25

:type (list persistent-class))

26

(association-kind

27

(compute-as (let ((cardinality-kinds (mapcar 'cardinality-kind-of (association-ends-of -self-))))

28

(cond ((equal cardinality-kinds '(:1 :1)) :1-1)

29

((equal cardinality-kinds '(:n :n)) :m-n)

30

(t :1-n))))

31

:type symbol

32

:documentation "Valid values are :1-1, :1-n or :m-n according to association end cardinalities.")

33

(primary-table

34

(compute-as (compute-primary-table -self- -current-value-))

35

:type table

36

:documentation "The table which holds the oids of the associated instances.")))

37

38

(defcclass* persistent-association-end-slot-definition (persistent-slot-definition)

39

((association

40

(compute-as nil)

41

:type persistent-association)

42

(associated-class

43

(compute-as (awhen (normalized-type-for (slot-definition-type -self-))

44

(if (set-type-p it)

45

(find-class (set-type-class-for it))

46

(find-class it))))

47

:type persistent-class)

48

(min-cardinality

49

(compute-as 0)

50

:type integer

51

:documentation "The minimum number of objects present in an association for this end.")

52

(max-cardinality

53

(compute-as (if (set-type-p (slot-definition-type -self-))

54

:n

55

1))

56

:type integer

57

     :documentation "The maximum number of objects present in an association for this end. Unbound means the maximum number is not defined.")

58

(cardinality-kind

59

(compute-as (if (and (slot-boundp -self- 'max-cardinality)

60

(eq (max-cardinality-of -self-) 1))

61

:1

62

:n))

63

:type symbol

64

:documentation "Valid values are :1, :n according to min a max cardinality.")

65

(primary-association-end

66

(compute-as (eq (slot-definition-name -self-)

67

                     (slot-definition-name (primary-association-end-of (association-of -self-)))))

68

:type boolean

69

:documentation "True iff this end is the primary association end of its association.")

70

(secondary-association-end

71

(compute-as (eq (slot-definition-name -self-)

72

                     (slot-definition-name (secondary-association-end-of (association-of -self-)))))

73

:type boolean

74

:documentation "True iff this end is the secondary association end of its association.")))

75

76

(defcclass* persistent-association-end-direct-slot-definition

77

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

78

((other-association-end

79

(compute-as (if (primary-association-end-p -self-)

80

(secondary-association-end-of (association-of -self-))

81

(primary-association-end-of (association-of -self-))))

82

:type persistent-association-end-direct-slot-definition))

83

(:metaclass identity-preserving-class))

84

85

(defcclass* persistent-association-end-effective-slot-definition

86

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

87

((other-association-end

88

     (compute-as (other-effective-association-end-for (associated-class-of (first (direct-slots-of -self-))) -self-))

89

:type persistent-association-end-direct-slot-definition)))

90

91

;;;;;;;;;;

92

;;; Export

93

94

(defmethod export-to-rdbms ((association persistent-association))

95

(mapc #'ensure-exported (remove-if #'null (mapcar #'primary-table-of (associated-classes-of association))))

96

(awhen (primary-table-of association)

97

(ensure-exported it)))

98

99

;;;;;;;;;;;

100

;;; Compute

101

102

(defmethod compute-primary-table ((association persistent-association) current-table)

103

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

104

(make-instance 'association-primary-table

105

:name (rdbms-name-for (name-of association))

106

:columns (compute-as

107

(mappend #'columns-of

108

                                        (mapcar #'effective-association-end-for (association-ends-of association)))))))

109

110

(defmethod compute-primary-class ((slot persistent-association-end-effective-slot-definition))

111

(bind ((association (association-of slot)))

112

(ecase (association-kind-of association)

113

(:1-1 (if (primary-association-end-p slot)

114

(call-next-method)

115

(slot-definition-class (other-association-end-of slot))))

116

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

117

(call-next-method)

118

(slot-definition-class (other-association-end-of slot))))

119

(:m-n nil))))

120

121

(defmethod compute-table ((slot persistent-association-end-effective-slot-definition))

122

(bind ((association (association-of slot)))

123

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

124

(primary-table-of association)

125

(call-next-method))))

126

127

(defmethod compute-columns ((slot persistent-association-end-effective-slot-definition))

128

(bind ((association (association-of slot)))

129

(ecase (association-kind-of association)

130

(:1-1 (if (primary-association-end-p slot)

131

(call-next-method)

132

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

133

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

134

(call-next-method)

135

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

136

(:m-n (make-columns-for-reference-slot (class-name (slot-definition-class slot))

137

                                              (set-type-class-for (normalized-type-for (slot-definition-type slot))))))))

138

139

(defcclass* association-primary-table (table)

140

()

141

(:documentation "This is a special table related to a persistent association."))

142

143

;;;;;;;;;;;

144

;;; Utility

145

146

(defparameter *persistent-associations* (make-hash-table)

147

"A mapping from association names to association objects.")

148

149

(defun find-association (name)

150

(gethash name *persistent-associations*))

151

152

(defun (setf find-association) (new-value name)

153

(setf (gethash name *persistent-associations*) new-value))

154

155

(defun to-one-association-end-p (association-end)

156

(eq (cardinality-kind-of association-end) :1))

157

158

(defun to-many-association-end-p (association-end)

159

(eq (cardinality-kind-of association-end) :n))

160

161

(defun effective-association-end-for (direct-association-end)

162

(find-slot (slot-definition-class direct-association-end) (slot-definition-name direct-association-end)))

163

164

(defun other-effective-association-end-for (class slot)

165

(find-slot class (slot-definition-name (some #'other-association-end-of (direct-slots-of slot)))))

166

167

(defun association-end-accessor-p (name)

168

(and (symbolp name)

169

(effective-association-ends-for-accessor name)))

170

171

(defun effective-association-ends-for-accessor (name)

172

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

173

(effective-slots-for-accessor name)))