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

Kind	Covered	All	%
expression	145	170	85.3
branch	12	12	100.0

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

;;; CLOS MOP extension for association ends

5

6

(defmethod propagate-cache-changes ((class persistent-class)

7

(object persistent-object)

8

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

9

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

10

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

11

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

12

;; BEFORE

13

;; object <-> old-other-object

14

;; new-value <-> old-other-new-value

15

;; AFTER

16

;; old-other-object -> nil

17

;; object <-> new-value

18

;; old-other-new-value -> nil

19

(when (slot-value-cached-p object slot)

20

(when-bind old-other-object (cached-slot-value-using-class class object slot)

21

(when (slot-value-cached-p old-other-object other-slot)

22

                  (setf (cached-slot-value-using-class (class-of old-other-object) old-other-object other-slot) nil))))

23

(when (and new-value

24

(slot-value-cached-p new-value other-slot))

25

(when-bind old-other-new-value

26

(cached-slot-value-using-class (class-of new-value) new-value other-slot)

27

(when old-other-new-value

28

                  (setf (cached-slot-value-using-class (class-of old-other-new-value) old-other-new-value slot) nil)))

29

              (setf (cached-slot-value-using-class (class-of new-value) new-value other-slot) object)))

30

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

31

;; invalidate all cached back references

32

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

33

(invalidate-cached-1-n-association-end-set-slot other-slot))))))

34

35

(defun invalidate-cached-1-n-association-end-set-slot (slot)

36

(bind ((class (slot-definition-class slot)))

37

(iter (for (id object) in-hashtable (current-objects))

38

(when (typep object class)

39

             (invalidate-cached-slot object (find-slot (class-of object) (slot-definition-name slot)))))))

40

41

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

42

;;; Lazy association end set containers

43

44

(defclass* persistent-association-end-set-container (persistent-slot-set-container)

45

())

46

47

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

48

;;; 1-n association end set

49

50

(defclass* persistent-1-n-association-end-set-container (persistent-association-end-set-container)

51

())

52

53

(defmethod insert-item :after ((set persistent-1-n-association-end-set-container) item)

54

(bind ((slot (slot-of set))

55

(class (class-of item))

56

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

57

(setf (cached-slot-value-using-class class item other-slot) (object-of set))))

58

59

(defmethod delete-item :after ((set persistent-1-n-association-end-set-container) item)

60

(bind ((class (class-of item))

61

(other-slot (other-effective-association-end-for class (slot-of set))))

62

(setf (cached-slot-value-using-class class item other-slot) nil)))

63

64

(defmethod empty! :after ((set persistent-1-n-association-end-set-container))

65

(invalidate-cached-1-n-association-end-set-slot (other-association-end-of (slot-of set))))

66

67

(defmethod list-of ((set persistent-1-n-association-end-set-container))

68

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

69

70

(defmethod (setf list-of) (new-value (set persistent-1-n-association-end-set-container))

71

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

72

73

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

74

;;; m-n association end set

75

76

(defclass* persistent-m-n-association-end-set-container (persistent-association-end-set-container)

77

())

78

79

(defmethod insert-item ((set persistent-m-n-association-end-set-container) item)

80

(insert-into-m-n-association-end-set (object-of set) (slot-of set) item))

81

82

(defmethod delete-item ((set persistent-m-n-association-end-set-container) item)

83

(bind ((slot (slot-of set))

84

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

85

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

86

(sql-and (id-column-matcher-where-clause item (id-column-of slot))

87

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

88

89

(defmethod size ((set persistent-m-n-association-end-set-container))

90

(bind ((slot (slot-of set))

91

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

92

(caar (execute (sql `(select (count *)

93

,(name-of (table-of (slot-of set)))

94

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

95

96

(defmethod empty! ((set persistent-m-n-association-end-set-container))

97

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

98

99

(defmethod list-of ((set persistent-m-n-association-end-set-container))

100

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

101

102

(defmethod (setf list-of) (new-value (set persistent-m-n-association-end-set-container))

103

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