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

Kind	Covered	All	%
expression	15	317	4.7
branch	3	12	25.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

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

10

;;; defpclass

11

12

(defmacro defpclass (name superclasses slots &rest options)

13

   "Defines a persistent class. Slots may have an additional :persistent slot option which is true by default. For standard options see defclass."

14

`(defclass ,name ,superclasses , slots

15

,@(append (unless (find :metaclass options :key 'first)

16

'((:metaclass persistent-class)))

17

options)))

18

19

(defmacro defpclass* (name superclasses slots &rest options)

20

"Same as defpclass but uses defclass*."

21

`(defclass* ,name ,superclasses , slots

22

,@(append (unless (find :metaclass options :key 'first)

23

'((:metaclass persistent-class)))

24

options)))

25

26

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

27

;;; defassociation

28

29

(defmacro defassociation (&body association-ends)

30

(flet ((process-association-end (association-end)

31

(bind ((initarg (getf association-end :initarg))

32

(accessor (getf association-end :accessor))

33

(reader (or (getf association-end :reader) accessor))

34

(writer (or (getf association-end :writer) `(setf ,accessor))))

35

(append `(:readers (,reader)

36

:writers (,writer)

37

:initargs (,initarg))

38

association-end)))

39

(add-initfunction (association-end)

40

(let ((initform (getf association-end :initform)))

41

`(list ,@(mapcar #L`',!1 association-end)

42

:initfunction

43

(lambda ()

44

,initform)))))

45

(bind ((options (cdr association-ends))

46

(metaclass (or (second (find :metaclass options :key #'first))

47

'persistent-association))

48

(export-accessors-names-p (second (find :export-accessor-names-p options :key #'first)))

49

(processed-association-ends (mapcar #'process-association-end (first association-ends)))

50

            (final-association-ends (cons 'list (mapcar #'add-initfunction processed-association-ends)))

51

(primary-association-end (first processed-association-ends))

52

(primary-class (getf primary-association-end :class))

53

(primary-slot (getf primary-association-end :slot))

54

(primary-reader (first (getf primary-association-end :readers)))

55

(lazy-primary-reader (concatenate-symbol primary-reader "*"))

56

(primary-writer (first (getf primary-association-end :writers)))

57

(secondary-association-end (second processed-association-ends))

58

(secondary-class (getf secondary-association-end :class))

59

(secondary-slot (getf secondary-association-end :slot))

60

(secondary-reader (first (getf secondary-association-end :readers)))

61

(lazy-secondary-reader (concatenate-symbol secondary-reader "*"))

62

(secondary-writer (first (getf secondary-association-end :writers)))

63

(association-name (concatenate-symbol primary-class "-" primary-slot "-"

64

                                                  secondary-class "-" secondary-slot)))

65

`(progn

66

(eval-when (:compile-toplevel)

67

(flet ((ensure-reader-function (name)

68

(ensure-generic-function name :lambda-list '(instance)))

69

(ensure-writer-function (name)

70

(ensure-generic-function name :lambda-list '(new-value instance))))

71

(ensure-reader-function ',primary-reader)

72

(ensure-reader-function ',lazy-primary-reader)

73

(ensure-writer-function ',primary-writer)

74

(ensure-reader-function ',secondary-reader)

75

(ensure-reader-function ',lazy-secondary-reader)

76

(ensure-writer-function ',secondary-writer)))

77

(eval-when (:load-toplevel :execute)

78

(flet ((ensure-persistent-class (name)

79

(bind ((class (find-class name)))

80

(ensure-class name

81

:metaclass (class-of class)

82

                                    :direct-superclasses (class-direct-superclasses class)

83

:direct-slots (mapcar

84

                                                   #L(list :instance !1)

85

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

86

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

87

(prog1

88

(aif (find-association ',association-name)

89

                      (reinitialize-instance it :association-end-definitions ,final-association-ends)

90

(setf (find-association ',association-name)

91

(make-instance ',metaclass

92

:name ',association-name

93

                                           :association-end-definitions ,final-association-ends)))

94

(ensure-persistent-class ',primary-class)

95

(ensure-persistent-class ',secondary-class))))

96

,(when export-accessors-names-p

97

                `(export '(,primary-reader ,lazy-primary-reader ,secondary-reader ,lazy-secondary-reader)

98

,*package*))))))

99

100

(defmacro defassociation* (&body association-ends)

101

`(defassociation

102

,(mapcar #L(append !1

103

(unless (getf !1 :accessor)

104

                          `(:accessor ,(default-accessor-name-transformer (getf !1 :slot) nil)))

105

(unless (getf !1 :initarg)

106

                          `(:initarg ,(default-initarg-name-transformer (getf !1 :slot) nil))))

107

(first association-ends))

108

,@(cdr association-ends)))

109

110

;;;;;;;;;

111

;;; types

112

113

;;; see types.lisp

114

115

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

116

;;; with-transaction

117

118

;;; inherited from cl-rdbms

119

120

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

121

;;; with-database

122

123

;;; inherited from cl-rdbms

124

125

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

126

;;; persistence

127

128

(defgeneric make-persistent (instance)

129

(:documentation "Makes an instance persistent without making its associated instances persistent.")

130

131

(:method :around (instance)

132

(unless (persistent-p instance)

133

(call-next-method))))

134

135

(defgeneric make-transient (instance)

136

(:documentation "Makes an instance transient without making its associated instances transient.")

137

138

(:method :around (instance)

139

(when (persistent-p instance)

140

(call-next-method))))

141

142

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

143

;;; collection

144

145

;;; insert-item, delete-item, empty-p, empty!, search-for-item are inherited from cl-containers

146

147

(defgeneric iterate-items (persistent-collection fn)

148

(:documentation "Applies function to each item in the persistent container."))

149

150

(defgeneric list-of (persistent-collection)

151

(:documentation "Returns a non lazy list of items present in the persistent collection."))

152

153

(defgeneric (setf list-of) (new-value persistent-collection)

154

(:documentation "Returns a non lazy list of items present in the persistent collection."))

155

156

;;;;;;;;;

157

;;; cache

158

159

(defmacro with-caching-slot-values (&body body)

160

`(bind ((*cache-slot-values* #t))

161

,@body))

162

163

(defmacro without-caching-slot-values (&body body)

164

`(bind ((*cache-slot-values* #f))

165

,@body))

166

167

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

168

;;; laziness

169

170

(defmacro with-lazy-collections (&body body)

171

`(bind ((*lazy-collections* #t))

172

,@body))

173

174

(defmacro without-lazy-collections (&body body)

175

`(bind ((*lazy-collections* #f))

176

,@body))

177

178

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

179

;;; database access

180

181

(defmacro with-bypassing-database-access (&body body)

182

`(bind ((*bypass-database-access* #t))

183

,@body))

184

185

(defmacro without-bypassing-database-access (&body body)

186

`(bind ((*bypass-database-access* #f))

187

,@body))