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

KindCoveredAll%
expression270479 56.4
branch3568 51.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
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;;;;;;;;;;
10
 ;;; Unbound
11
 
12
 (defun equaln (value-1 value-2 count)
13
   (iter (repeat count)
14
         (for v-1 in value-1)
15
         (for v-2 in value-2)
16
         (unless (eq v-1 v-2)
17
           (return-from equaln #f)))
18
   #t)
19
 
20
 (defcondition* slot-type-error (type-error)
21
   ((slot
22
     :type persistent-effective-slot-definition))
23
   (:report
24
    (lambda (condition stream)
25
      (format stream
26
              "~@<The value ~2I~:_~S ~I~_in slot ~A is not of type ~2I~_~S.~:>"
27
              (type-error-datum condition)
28
              (slot-definition-name (slot-of condition))
29
              (type-error-expected-type condition)))))
30
 
31
 (defmacro def-transformer-wrapper (name &body forms)
32
   `(defun ,name (slot type function column-number)
33
     (declare (ignorable slot type column-number))
34
     ,@forms))
35
 
36
 (def-transformer-wrapper unbound-reader
37
   (bind ((unbound-rdbms-value (iter (repeat column-number) (collect nil))))
38
     (lambda (rdbms-values)
39
       (if (equaln unbound-rdbms-value rdbms-values column-number)
40
           +unbound-slot-value+
41
           (funcall function rdbms-values)))))
42
 
43
 (def-transformer-wrapper non-unbound-reader
44
   (lambda (rdbms-values)
45
     (prog1-bind slot-value (funcall function rdbms-values)
46
       (when (eq +unbound-slot-value+ slot-value)
47
         (if slot
48
             (error 'unbound-slot :instance nil :name (slot-definition-name slot))
49
             (error 'type-error :datum slot-value :expected-type type))))))
50
 
51
 (def-transformer-wrapper unbound-writer
52
   (bind ((unbound-rdbms-value (iter (repeat column-number) (collect nil))))
53
     (lambda (slot-value)
54
       (if (eq +unbound-slot-value+ slot-value)
55
           unbound-rdbms-value
56
           (funcall function slot-value)))))
57
 
58
 (def-transformer-wrapper non-unbound-writer
59
   (lambda (slot-value)
60
     (if (eq +unbound-slot-value+ slot-value)
61
         (if slot
62
             (error 'unbound-slot :instance nil :name (slot-definition-name slot))
63
             (error 'type-error :datum slot-value :expected-type type))
64
         (funcall function slot-value))))
65
 
66
 ;;;;;;;;
67
 ;;; Null
68
 
69
 (def-transformer-wrapper null-reader
70
   (bind ((nil-rdbms-value (iter (repeat column-number) (collect nil))))
71
     (lambda (rdbms-values)
72
       (if (equaln nil-rdbms-value rdbms-values column-number)
73
           nil
74
           (funcall function rdbms-values)))))
75
 
76
 (def-transformer-wrapper non-null-reader
77
   (lambda (rdbms-values)
78
     (prog1-bind slot-value (funcall function rdbms-values)
79
       (unless slot-value
80
         (if slot
81
             (error 'slot-type-error :slot slot :datum slot-value :expected-type type)
82
             (error 'type-error :datum slot-value :expected-type type))))))
83
 
84
 (def-transformer-wrapper null-writer
85
   (bind ((nil-rdbms-value (iter (repeat column-number) (collect nil))))
86
     (lambda (slot-value)
87
       (if slot-value
88
           (funcall function slot-value)
89
           nil-rdbms-value))))
90
 
91
 (def-transformer-wrapper non-null-writer
92
   (lambda (slot-value)
93
     (if slot-value
94
         (funcall function slot-value)
95
         (if slot
96
             (error 'slot-type-error :slot slot :datum slot-value :expected-type type)
97
             (error 'type-error :datum slot-value :expected-type type)))))
98
 
99
 ;;;;;;;;;;;;;;;;;;;
100
 ;;; Unbound or null
101
 
102
 (def-transformer-wrapper unbound-or-null-reader
103
   (bind ((unbound-rdbms-value (iter (repeat column-number) (collect nil)))
104
          (nil-rdbms-value (list* #t (cdr unbound-rdbms-value))))
105
     (lambda (rdbms-values)
106
       (cond ((equaln unbound-rdbms-value rdbms-values column-number)
107
              +unbound-slot-value+)
108
             ((equaln nil-rdbms-value rdbms-values column-number)
109
              nil)
110
             (t (funcall function (cdr rdbms-values)))))))
111
 
112
 (def-transformer-wrapper unbound-or-null-writer
113
   (bind ((unbound-rdbms-value (iter (repeat column-number) (collect nil)))
114
          (nil-rdbms-value (list* #t (cdr unbound-rdbms-value))))
115
     (lambda (slot-value)
116
       (cond ((eq +unbound-slot-value+ slot-value)
117
              unbound-rdbms-value)
118
             ((null slot-value)
119
              nil-rdbms-value)
120
             (t (list* #t (funcall function slot-value)))))))
121
 
122
 ;;;;;;;;;;;;;;
123
 ;;; Serialized
124
 
125
 (defun base64->object-reader (rdbms-values)
126
   (with-input-from-sequence (stream
127
     (with-input-from-string (base64 (first rdbms-values))
128
       (decode-base64-bytes base64)))
129
     (restore stream)))
130
 
131
 (defun object->base64-writer (slot-value)
132
   (list
133
    (with-output-to-string (base64)
134
      (encode-base64-bytes
135
       (with-output-to-sequence (stream)
136
         (store slot-value stream))
137
       base64))))
138
 
139
 ;;;;;;;;;;;;
140
 ;;; Identity
141
 
142
 (defun identity-reader (rdbms-values)
143
   (first rdbms-values))
144
 
145
 (defun identity-writer (slot-value)
146
   (list slot-value))
147
 
148
 ;;;;;;;;;;
149
 ;;; Number
150
 
151
 (defun object->number-reader (rdbms-values)
152
   (bind ((value (first rdbms-values)))
153
     (if (typep value 'number)
154
         value
155
         (parse-number value))))
156
 
157
 ;;;;;;;;;;;
158
 ;;; Integer
159
 
160
 (defun object->integer-reader (rdbms-values)
161
   (bind ((value (first rdbms-values)))
162
     (if (typep value 'number)
163
         value
164
         (parse-integer value))))
165
 
166
 ;;;;;;;;;;
167
 ;;; Symbol
168
 
169
 (defun string->symbol-reader (rdbms-values)
170
   (symbol-from-canonical-name (first rdbms-values)))
171
 
172
 (defun symbol->string-writer (slot-value)
173
   (list (canonical-symbol-name slot-value)))
174
 
175
 ;;;;;;;;
176
 ;;; List
177
 
178
 (defun string->list-reader (rdbms-values)
179
   (read-from-string (first rdbms-values)))
180
 
181
 (defun list->string-writer (slot-value)
182
   (list (write-to-string slot-value)))
183
 
184
 ;;;;;;;;;;;
185
 ;;; Boolean
186
 
187
 (defun char->boolean-reader (rdbms-values)
188
   (bind ((value (first rdbms-values)))
189
     (cond ((eq #\t value) #t)
190
           ((eq #\f value) #f)
191
           (t (error 'type-error :datum value :expected-type 'boolean)))))
192
 
193
 (defun boolean->char-writer (slot-value)
194
   (if slot-value
195
       (list #\t)
196
       (list #\f)))
197
 
198
 (defun integer->boolean-reader (rdbms-values)
199
   (bind ((value (first rdbms-values)))
200
     (cond ((= 0 value) #t)
201
           ((= 1 value) #f)
202
           (t (error 'type-error :datum value :expected-type 'boolean)))))
203
 
204
 (defun boolean->integer-writer (slot-value)
205
   (if slot-value
206
       (list 1)
207
       (list 0)))
208
 
209
 (defun string->boolean-reader (rdbms-values)
210
   (bind ((value (first rdbms-values)))
211
     (cond ((equal "t" value) #t)
212
           ((equal "f" value) #f)
213
           (t (error 'type-error :datum value :expected-type 'boolean)))))
214
 
215
 (defun boolean->string-writer (slot-value)
216
   (if slot-value
217
       (list "TRUE")
218
       (list "FALSE")))
219
 
220
 (defun object->boolean-reader (rdbms-values)
221
   (bind ((value (first rdbms-values)))
222
     (cond ((eq #t value) #t)
223
           ((eq #f value) #f)
224
           ((eq #\t value) #t)
225
           ((eq #\f value) #f)
226
           ((and (typep value 'integer)
227
                 (= 0 value)) #f)
228
           ((and (typep value 'integer)
229
                 (= 1 value)) #t)
230
           ((equal "t" value) #t)
231
           ((equal "f" value) #f)
232
           ((equal "TRUE" value) #t)
233
           ((equal "FALSE" value) #f)
234
           (t (error 'type-error :datum value :expected-type 'boolean)))))
235
 
236
 ;;;;;;;;;;
237
 ;;; Member
238
 
239
 (defun slot-definition-type-member-elements (type)
240
   (cdr (if (eq 'member (first type))
241
            type
242
            (find 'member type
243
                  :key #L(when (listp !1)
244
                           (first !1))))))
245
 
246
 (defun integer->member-reader (type)
247
   (bind ((member-elements (slot-definition-type-member-elements type)))
248
     (lambda (rdbms-values)
249
       (bind ((value (first rdbms-values)))
250
         (aif (nth value member-elements)
251
              it
252
              (error 'type-error :datum value :expected-type type))))))
253
 
254
 (defun member->integer-writer (type)
255
   (bind ((member-elements (slot-definition-type-member-elements type)))
256
     (lambda (slot-value)
257
       (block found
258
         (loop for i from 0
259
               for value in member-elements
260
               when (eq value slot-value)
261
               do (return-from found (list i)))
262
         (error 'type-error :datum slot-value :expected-type type)))))
263
 
264
 (defun string->member-reader (type)
265
   (bind ((member-elements (slot-definition-type-member-elements type)))
266
     (lambda (rdbms-values)
267
       (aprog1 (string->symbol-reader rdbms-values)
268
         (assert (member it member-elements))))))
269
 
270
 (defun member->string-writer (type)
271
   (bind ((member-elements (slot-definition-type-member-elements type)))
272
     (lambda (slot-value)
273
       (assert (member slot-value member-elements))
274
       (symbol->string-writer slot-value))))
275
 
276
 ;;;;;;;;;;;;;;;;;
277
 ;;; Date and time
278
 
279
 (defun string->local-time-reader (rdbms-values)
280
   (bind ((*default-timezone* +utc-zone+))
281
     (parse-timestring (first rdbms-values) :date-time-separator #\Space)))
282
 
283
 (defun local-time->string-writer (slot-value)
284
   (list
285
    (format-timestring slot-value :date-time-separator #\Space :use-zulu-p #f)))
286
 
287
 (defun integer->local-time-reader (rdbms-values)
288
   (local-time :universal (first rdbms-values) :timezone +utc-zone+))
289
 
290
 (defun local-time->integer-writer (slot-value)
291
   (list
292
    (universal-time slot-value)))
293
 
294
 ;;;;;;;;;;
295
 ;;; Object
296
 
297
 (defun object-reader (rdbms-values)
298
   (load-instance (make-oid :id (first rdbms-values) :class-name (symbol-from-canonical-name (second rdbms-values)))
299
                  :skip-existence-check #t))
300
 
301
 (defun object-writer (slot-value)
302
   (oid-values slot-value))