1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-TEST")
14 ;;; Basic serialization unit tests
16 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (deftype user-integer () 'integer)
20 (defclass basic-test1 ()
21 ((intval :type (signed-byte 32)
24 (defclass basic-test2 ()
25 ((intval :type (or null (signed-byte 32))
28 (strval :type (or null string)
32 (defclass basic-test3 ()
33 ((intval :type (or null (signed-byte 32))
36 (strval :type (or null string)
39 (recval :type (or null basic-test1)
43 (defclass basic-test4 ()
44 ((intval :type (or null (signed-byte 32))
47 (strval :type (or null string)
50 (recval :type (or null basic-test2)
54 (defclass basic-test5 ()
55 ((color :type (member :red :green :blue)
57 (intvals :type (proto:list-of integer)
60 (strvals :type (proto:list-of string)
64 (defclass basic-test6 ()
65 ((intvals :type (proto:list-of integer)
68 (strvals :type (proto:list-of string)
71 (recvals :type (proto:list-of basic-test2)
75 (defclass basic-test7 ()
76 ((intval :type (or null user-integer)
82 (defvar *basic-test-schema*
83 (generate-schema-for-classes
84 '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6 basic-test7)
87 (define-test basic-serialization ()
88 (let* ((test1 (make-instance 'basic-test1 :intval 150))
89 (test1b (make-instance 'basic-test1 :intval -150))
90 (test2 (make-instance 'basic-test2 :strval "testing"))
91 (test2b (make-instance 'basic-test2 :strval "1 2 3"))
92 (test3 (make-instance 'basic-test3 :recval test1))
93 (test4 (make-instance 'basic-test4 :recval test2))
94 (test5 (make-instance 'basic-test5
95 :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
96 (test6 (make-instance 'basic-test6
97 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
98 (test7 (make-instance 'basic-test7 :intval 150))
100 (let ((tser1 (serialize-object-to-bytes test1 'basic-test1))
101 (tser1b (serialize-object-to-bytes test1b 'basic-test1))
102 (tser2 (serialize-object-to-bytes test2 'basic-test2))
103 (tser3 (serialize-object-to-bytes test3 'basic-test3))
104 (tser4 (serialize-object-to-bytes test4 'basic-test4))
105 (tser5 (serialize-object-to-bytes test5 'basic-test5))
106 (tser6 (serialize-object-to-bytes test6 'basic-test6))
107 (tser7 (serialize-object-to-bytes test7 'basic-test7)))
108 (assert-true (equalp tser1 #(#x08 #x96 #x01)))
109 (assert-true (equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)))
110 (assert-true (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
111 (assert-true (equalp tser3 #(#x1A #x03 #x08 #x96 #x01)))
112 (assert-true (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
113 (assert-true (equalp tser5 #(#x08 #x00
114 #x10 #x04 #x02 #x03 #x05 #x07
115 #x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E)))
116 (assert-true (equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33)))
117 (assert-true (equalp tser7 #(#x08 #x96 #x01)))
118 (macrolet ((slots-equalp (obj1 obj2 &rest slots)
119 (proto-impl::with-gensyms (vobj1 vobj2)
120 (proto-impl::with-collectors ((forms collect-form))
122 (collect-form `(assert-true
123 (equalp (slot-value ,vobj1 ',slot) (slot-value ,vobj2 ',slot)))))
124 `(let ((,vobj1 ,obj1)
127 (slots-equalp test1 (deserialize-object 'basic-test1 tser1)
129 (slots-equalp test1b (deserialize-object 'basic-test1 tser1b)
131 (slots-equalp test2 (deserialize-object 'basic-test2 tser2)
133 (slots-equalp test3 (deserialize-object 'basic-test3 tser3)
135 (slots-equalp (slot-value test3 'recval)
136 (slot-value (deserialize-object 'basic-test3 tser3) 'recval)
138 (slots-equalp test4 (deserialize-object 'basic-test4 tser4)
140 (slots-equalp (slot-value test4 'recval)
141 (slot-value (deserialize-object 'basic-test4 tser4) 'recval)
143 (slots-equalp test5 (deserialize-object 'basic-test5 tser5)
144 color intvals strvals)
145 (slots-equalp test6 (deserialize-object 'basic-test6 tser6)
147 (slots-equalp (first (slot-value test6 'recvals))
148 (first (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
150 (slots-equalp (second (slot-value test6 'recvals))
151 (second (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
153 (slots-equalp test7 (deserialize-object 'basic-test7 tser7)
156 (define-test basic-optimized-serialization ()
157 (dolist (class '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6))
158 (let ((message (find-message *basic-test-schema* class)))
159 (handler-bind ((style-warning #'muffle-warning))
160 (eval (generate-object-size message))
161 (eval (generate-serializer message))
162 (eval (generate-deserializer message)))))
163 (let* ((test1 (make-instance 'basic-test1 :intval 150))
164 (test1b (make-instance 'basic-test1 :intval -150))
165 (test2 (make-instance 'basic-test2 :strval "testing"))
166 (test2b (make-instance 'basic-test2 :strval "1 2 3"))
167 (test3 (make-instance 'basic-test3 :recval test1))
168 (test4 (make-instance 'basic-test4 :recval test2))
169 (test5 (make-instance 'basic-test5
170 :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
171 (test6 (make-instance 'basic-test6
172 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
173 (test7 (make-instance 'basic-test7 :intval 150)))
174 (let ((tser1 (serialize-object-to-bytes test1 'basic-test1))
175 (tser1b (serialize-object-to-bytes test1b 'basic-test1))
176 (tser2 (serialize-object-to-bytes test2 'basic-test2))
177 (tser3 (serialize-object-to-bytes test3 'basic-test3))
178 (tser4 (serialize-object-to-bytes test4 'basic-test4))
179 (tser5 (serialize-object-to-bytes test5 'basic-test5))
180 (tser6 (serialize-object-to-bytes test6 'basic-test6))
181 (tser7 (serialize-object-to-bytes test7 'basic-test7)))
182 (assert-true (equalp tser1 #(#x08 #x96 #x01)))
183 (assert-true (equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)))
184 (assert-true (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
185 (assert-true (equalp tser3 #(#x1A #x03 #x08 #x96 #x01)))
186 (assert-true (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
187 (assert-true (equalp tser5 #(#x08 #x00
188 #x10 #x04 #x02 #x03 #x05 #x07
189 #x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E)))
190 (assert-true (equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33)))
191 (assert-true (equalp tser7 #(#x08 #x96 #x01)))
192 (macrolet ((slots-equalp (obj1 obj2 &rest slots)
193 (proto-impl::with-gensyms (vobj1 vobj2)
194 (proto-impl::with-collectors ((forms collect-form))
196 (collect-form `(assert-true
197 (equalp (slot-value ,vobj1 ',slot) (slot-value ,vobj2 ',slot)))))
198 `(let ((,vobj1 ,obj1)
201 (slots-equalp test1 (deserialize-object 'basic-test1 tser1)
203 (slots-equalp test1b (deserialize-object 'basic-test1 tser1b)
205 (slots-equalp test2 (deserialize-object 'basic-test2 tser2)
207 (slots-equalp test3 (deserialize-object 'basic-test3 tser3)
209 (slots-equalp (slot-value test3 'recval)
210 (slot-value (deserialize-object 'basic-test3 tser3) 'recval)
212 (slots-equalp test4 (deserialize-object 'basic-test4 tser4)
214 (slots-equalp (slot-value test4 'recval)
215 (slot-value (deserialize-object 'basic-test4 tser4) 'recval)
217 (slots-equalp test5 (deserialize-object 'basic-test5 tser5)
218 color intvals strvals)
219 (slots-equalp test6 (deserialize-object 'basic-test6 tser6)
221 (slots-equalp (first (slot-value test6 'recvals))
222 (first (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
224 (slots-equalp (second (slot-value test6 'recvals))
225 (second (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
227 (slots-equalp test7 (deserialize-object 'basic-test7 tser7)
230 (define-test text-serialization ()
231 (let* ((test1 (make-instance 'basic-test1 :intval 150))
232 (test1b (make-instance 'basic-test1 :intval -150))
233 (test2 (make-instance 'basic-test2 :strval "testing"))
234 (test2b (make-instance 'basic-test2 :strval "1 2 3"))
235 (test3 (make-instance 'basic-test3 :recval test1))
236 (test4 (make-instance 'basic-test4 :recval test2))
237 (test5 (make-instance 'basic-test5
238 :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
239 (test6 (make-instance 'basic-test6
240 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
241 (test7 (make-instance 'basic-test7 :intval 150)))
242 (let ((tser1 (serialize-object-to-bytes test1 'basic-test1))
243 (tser1b (serialize-object-to-bytes test1b 'basic-test1))
244 (tser2 (serialize-object-to-bytes test2 'basic-test2))
245 (tser3 (serialize-object-to-bytes test3 'basic-test3))
246 (tser4 (serialize-object-to-bytes test4 'basic-test4))
247 (tser5 (serialize-object-to-bytes test5 'basic-test5))
248 (tser6 (serialize-object-to-bytes test6 'basic-test6))
249 (tser7 (serialize-object-to-bytes test7 'basic-test7)))
250 (macrolet ((slots-equalp (obj1 obj2 &rest slots)
251 (proto-impl::with-gensyms (vobj1 vobj2)
252 (proto-impl::with-collectors ((forms collect-form))
254 (collect-form `(assert-true
255 (equalp (slot-value ,vobj1 ',slot) (slot-value ,vobj2 ',slot)))))
256 `(let ((,vobj1 ,obj1)
259 (let ((text (with-output-to-string (s)
260 (print-text-format test1 'basic-test1 :stream s))))
261 (assert-true (string= text (with-output-to-string (s)
263 (deserialize-object 'basic-test1 tser1) 'basic-test1 :stream s))))
264 (slots-equalp test1 (with-input-from-string (s text)
265 (parse-text-format 'basic-test1 :stream s))
267 (let ((text (with-output-to-string (s)
268 (print-text-format test1b 'basic-test1 :stream s))))
269 (assert-true (string= text (with-output-to-string (s)
271 (deserialize-object 'basic-test1 tser1b) 'basic-test1 :stream s))))
272 (slots-equalp test1b (with-input-from-string (s text)
273 (parse-text-format 'basic-test1 :stream s))
275 (let ((text (with-output-to-string (s)
276 (print-text-format test2 'basic-test2 :stream s))))
277 (assert-true (string= text (with-output-to-string (s)
279 (deserialize-object 'basic-test2 tser2) 'basic-test2 :stream s))))
280 (slots-equalp test2 (with-input-from-string (s text)
281 (parse-text-format 'basic-test2 :stream s))
283 (let ((text (with-output-to-string (s)
284 (print-text-format test3 'basic-test3 :stream s))))
285 (assert-true (string= text (with-output-to-string (s)
287 (deserialize-object 'basic-test3 tser3) 'basic-test3 :stream s))))
288 (slots-equalp test3 (with-input-from-string (s text)
289 (parse-text-format 'basic-test3 :stream s))
291 (slots-equalp (slot-value test3 'recval)
292 (slot-value (with-input-from-string (s text)
293 (parse-text-format 'basic-test3 :stream s)) 'recval)
295 (let ((text (with-output-to-string (s)
296 (print-text-format test4 'basic-test4 :stream s))))
297 (assert-true (string= text (with-output-to-string (s)
299 (deserialize-object 'basic-test4 tser4) 'basic-test4 :stream s))))
300 (slots-equalp test4 (with-input-from-string (s text)
301 (parse-text-format 'basic-test4 :stream s))
303 (slots-equalp (slot-value test4 'recval)
304 (slot-value (with-input-from-string (s text)
305 (parse-text-format 'basic-test4 :stream s)) 'recval)
307 (let ((text (with-output-to-string (s)
308 (print-text-format test5 'basic-test5 :stream s))))
309 (assert-true (string= text (with-output-to-string (s)
311 (deserialize-object 'basic-test5 tser5) 'basic-test5 :stream s))))
312 (slots-equalp test5 (with-input-from-string (s text)
313 (parse-text-format 'basic-test5 :stream s))
314 color intvals strvals))
315 (let ((text (with-output-to-string (s)
316 (print-text-format test6 'basic-test6 :stream s))))
317 (assert-true (string= text (with-output-to-string (s)
319 (deserialize-object 'basic-test6 tser6) 'basic-test6 :stream s))))
320 (slots-equalp test6 (with-input-from-string (s text)
321 (parse-text-format 'basic-test6 :stream s))
323 (slots-equalp (first (slot-value test6 'recvals))
325 (with-input-from-string (s text)
326 (parse-text-format 'basic-test6 :stream s)) 'recvals))
328 (slots-equalp (second (slot-value test6 'recvals))
330 (with-input-from-string (s text)
331 (parse-text-format 'basic-test6 :stream s)) 'recvals))
333 (let ((text (with-output-to-string (s)
334 (print-text-format test7 'basic-test7 :stream s))))
335 (assert-true (string= text (with-output-to-string (s)
337 (deserialize-object 'basic-test7 tser7) 'basic-test7 :stream s))))
338 (slots-equalp test7 (with-input-from-string (s text)
339 (parse-text-format 'basic-test7 :stream s))
343 (proto:define-schema integrity-test
344 (:package proto_test)
345 (proto:define-message inner ()
346 (i :type (or null integer)))
347 (proto:define-message outer ()
348 (inner :type (proto:list-of inner))
349 (simple :type (or null inner))
350 (i :type (or null integer))))
352 (define-test serialization-integrity ()
353 (flet ((do-test (message)
354 (let* ((type (type-of message))
355 (buf (proto:serialize-object-to-bytes message type))
356 (new (proto:deserialize-object type buf))
357 (newbuf (proto:serialize-object-to-bytes new type)))
358 (assert-true (equalp (length buf) (length newbuf)))
359 (assert-true (equalp buf newbuf))
360 (assert-true (string= (with-output-to-string (s)
361 (proto:print-text-format message nil :stream s))
362 (with-output-to-string (s)
363 (proto:print-text-format new nil :stream s)))))))
364 (do-test (make-instance 'outer :i 4))
365 (do-test (make-instance 'outer :i -4))
366 (do-test (make-instance 'outer
367 :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(1 2 3))))
368 (do-test (make-instance 'outer
369 :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(-1 -2 -3))))
370 (do-test (make-instance 'outer
371 :simple (make-instance 'inner :i 4)))
372 (do-test (make-instance 'outer
373 :simple (make-instance 'inner :i -4)))))
375 (proto:define-schema empty-message-optimize-speed-test
376 (:package proto_test :optimize :speed)
377 (proto:define-message speed-empty ())
378 (proto:define-message speed-optional ()
379 (foo :type (or null speed-empty)))
380 (proto:define-message speed-repeated ()
381 (foo :type (proto:list-of speed-empty))))
383 (proto:define-schema empty-message-optimize-space-test
384 (:package proto_test :optimize :space)
385 (proto:define-message space-empty ())
386 (proto:define-message space-optional ()
387 (foo :type (or null space-empty)))
388 (proto:define-message space-repeated ()
389 (foo :type (proto:list-of space-empty))))
391 (define-test empty-message-serialization ()
392 (let ((speed0 (make-instance 'speed-empty))
393 (speed1 (make-instance 'speed-optional))
394 (speed2 (make-instance 'speed-repeated))
395 (space0 (make-instance 'space-empty))
396 (space1 (make-instance 'space-optional))
397 (space2 (make-instance 'space-repeated)))
398 (setf (slot-value speed1 'foo) speed0)
399 (setf (slot-value space1 'foo) space0)
400 (push speed0 (slot-value speed2 'foo))
401 (push space0 (slot-value space2 'foo))
402 (let ((ser-speed0 (serialize-object-to-bytes speed0 (type-of speed0)))
403 (ser-speed1 (serialize-object-to-bytes speed1 (type-of speed1)))
404 (ser-speed2 (serialize-object-to-bytes speed2 (type-of speed2)))
405 (ser-space0 (serialize-object-to-bytes space0 (type-of space0)))
406 (ser-space1 (serialize-object-to-bytes space1 (type-of space1)))
407 (ser-space2 (serialize-object-to-bytes space2 (type-of space2))))
408 (assert-true (equalp ser-speed0 #()))
409 (assert-true (equalp ser-speed1 #(#x0A #x00)))
410 (assert-true (equalp ser-speed2 #(#x0A #x00)))
411 (assert-true (equalp ser-space0 #()))
412 (assert-true (equalp ser-space1 #(#x0A #x00)))
413 (assert-true (equalp ser-space2 #(#x0A #x00))))))
418 (eval-when (:compile-toplevel :load-toplevel :execute)
421 ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries)
422 (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions)
423 (cities :type (proto:list-of qres-core::city) :initform () :initarg :cities)
424 (airports :type (proto:list-of qres-core::airport) :initform () :initarg :airports)))
428 (defvar *geodata-schema*
429 (proto:generate-schema-for-classes
430 '(qres-core::country qres-core::region qres-core::region-key
431 qres-core::city qres-core::airport
432 qres-core::timezone qres-core::tz-variation
433 qres-core::currency qres-core::country-currencies
438 (define-test geodata-serialization ()
439 (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
440 (regions (loop for v being the hash-values of (qres-core::region-business-data) collect v))
441 (cities (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
442 (airports (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v)))
443 (geodata (make-instance 'geodata
447 :airports airports)))
448 (let ((gser (proto:serialize-object-to-bytes geodata 'geodata)))
449 (assert-true (equalp gser (proto:serialize-object-to-bytes
450 (proto:deserialize-object 'geodata gser) 'geodata))))))
452 (define-test geodata-optimized-serialization ()
453 (dolist (class '(qres-core::country qres-core::region qres-core::region-key
454 qres-core::city qres-core::airport
455 qres-core::timezone qres-core::tz-variation
456 qres-core::currency qres-core::country-currencies
459 (let ((message (find-message *geodata-schema* class)))
460 (eval (generate-object-size message))
461 (eval (generate-serializer message))
462 (eval (generate-deserializer message))))
463 (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
464 (regions (loop for v being the hash-values of (qres-core::region-business-data) collect v))
465 (cities (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
466 (airports (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v)))
467 (geodata (make-instance 'geodata
471 :airports airports)))
472 (let ((gser (proto:serialize-object-to-bytes geodata 'geodata)))
473 (assert-true (equalp gser (proto:serialize-object-to-bytes
474 (proto:deserialize-object 'geodata gser) 'geodata))))))
480 (proto:define-schema automobile
483 (proto:define-enum auto-status ()
486 (proto:define-enum paint-type ()
489 (proto:define-message automobile
492 (color :type auto-color)
493 (status :type auto-status :default :new))
494 (proto:define-message auto-color
495 (:conc-name auto-color-)
496 (name :type (or string null))
497 (r-value :type integer)
498 (g-value :type integer)
499 (b-value :type integer)
500 (proto:define-extension 1000 max))
501 (proto:define-extend auto-color
502 (:conc-name auto-color-)
503 ((paint-type 1000) :type (or paint-type null)))
504 (proto:define-message buy-car-request ()
505 (auto :type automobile))
506 (proto:define-message buy-car-response ()
507 (price :type (or null uint32)))
508 (proto:define-service buy-car ()
509 (buy-car (buy-car-request => buy-car-response)
510 :options (:deadline 1.0))))
512 (define-test extension-serialization ()
513 (let* ((color1 (make-instance 'auto-color :r-value 100 :g-value 0 :b-value 100))
514 (car1 (make-instance 'automobile :model "Audi" :color color1))
515 (rqst1 (make-instance 'buy-car-request :auto car1))
516 (color2 (make-instance 'auto-color :r-value 100 :g-value 0 :b-value 100))
517 (car2 (make-instance 'automobile :model "Audi" :color color2))
518 (rqst2 (make-instance 'buy-car-request :auto car2)))
519 (setf (auto-color-paint-type color2) :metallic)
520 (let ((ser1 (proto:serialize-object-to-bytes rqst1 'buy-car-request)))
521 (assert-true (string= (with-output-to-string (s)
522 (proto:print-text-format rqst1 nil :stream s))
523 (with-output-to-string (s)
524 (proto:print-text-format
525 (proto:deserialize-object 'buy-car-request ser1) nil :stream s)))))
526 (let ((ser2 (proto:serialize-object-to-bytes rqst2 'buy-car-request)))
527 (assert-true (string= (with-output-to-string (s)
528 (proto:print-text-format rqst2 nil :stream s))
529 (with-output-to-string (s)
530 (proto:print-text-format
531 (proto:deserialize-object 'buy-car-request ser2) nil :stream s)))))
532 (let ((str1 (with-output-to-string (s)
533 (proto:print-text-format rqst1 nil :stream s)))
534 (str2 (with-output-to-string (s)
535 (proto:print-text-format rqst2 nil :stream s))))
536 (assert-false (string= str1 str2))
537 (assert-false (search "paint_type:" str1 :test #'char=))
538 (assert-true (search "paint_type:" str2 :test #'char=)))))
542 ;; Supply :name to keep the names stable for string= below
543 (proto:define-schema submessage-color-wheel
544 (:package proto_test)
545 (proto:define-message color-wheel1
546 (:conc-name color-wheel- :name "ColorWheel")
547 (proto:define-message metadata1 ;'metadata1' so we don't get class redefinition
548 (:conc-name metadata- :name "Metadata")
549 (author :type (or null string))
550 (revision :type (or null string))
551 (date :type (or null string)))
553 (colors :type (list-of color1))
554 (metadata :type (or null metadata1)))
555 (proto:define-message color1
556 (:conc-name color- :name "Color")
557 (name :type (or null string))
558 (r-value :type integer)
559 (g-value :type integer)
560 (b-value :type integer))
561 (proto:define-message add-color1
563 (wheel :type color-wheel1)
564 (color :type color1)))
566 ;; Supply :name to keep the names stable for string= below
567 (proto:define-schema group-color-wheel
568 (:package proto_test)
569 (proto:define-message color-wheel2
570 (:conc-name color-wheel- :name "ColorWheel")
572 (colors :type (list-of color2))
573 (proto:define-group metadata
574 (:conc-name metadata-
578 (author :type (or null string))
579 (revision :type (or null string))
580 (date :type (or null string))))
581 (proto:define-message color2
582 (:conc-name color- :name "Color")
583 (name :type (or null string))
584 (r-value :type integer)
585 (g-value :type integer)
586 (b-value :type integer))
587 (proto:define-message add-color2
589 (wheel :type color-wheel2)
590 (color :type color2)))
592 (define-test group-serialization ()
593 (let* ((meta1 (make-instance 'metadata1 :revision "1.0"))
594 (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata meta1))
595 (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
596 (rqst1 (make-instance 'add-color1 :wheel wheel1 :color color1))
597 (meta2 (make-instance 'metadata :revision "1.0"))
598 (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata meta2))
599 (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
600 (rqst2 (make-instance 'add-color2 :wheel wheel2 :color color2)))
601 (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color1))
602 (ser2 (proto:serialize-object-to-bytes rqst2 'add-color2)))
603 (assert-true (string= (with-output-to-string (s)
604 (proto:print-text-format rqst1 nil :stream s))
605 (with-output-to-string (s)
606 (proto:print-text-format rqst2 nil :stream s))))
607 (assert-true (string= (with-output-to-string (s)
608 (proto:print-text-format
609 (proto:deserialize-object 'add-color1 ser1) nil :stream s))
610 (with-output-to-string (s)
611 (proto:print-text-format
612 (proto:deserialize-object 'add-color2 ser2) nil :stream s)))))))
616 (proto:define-schema type-alias-test
617 (:package proto_test)
618 (proto:define-type-alias lisp-integer-as-string ()
621 :serializer princ-to-string
622 :deserializer parse-integer)
623 (proto:define-message type-alias-test-message ()
624 (test-field :type (or null lisp-integer-as-string))))
626 (define-test type-aliases ()
628 (proto-impl:proto-type
629 (first (proto-impl:proto-fields
630 (proto:find-message (proto:find-schema 'type-alias-test)
631 'proto-test::type-alias-test-message))))
633 (let* ((msg1 (make-instance 'type-alias-test-message :test-field 5))
634 (ser1 (proto:serialize-object-to-bytes msg1 'type-alias-test-message))
635 (dser1 (deserialize-object 'type-alias-test-message ser1)))
636 (assert-equal ser1 #(10 1 53) :test #'equalp)
637 (assert-equal (slot-value msg1 'test-field)
638 (slot-value dser1 'test-field))))
640 (define-test-suite serialization-tests ()
642 basic-optimized-serialization
644 serialization-integrity
645 #+qres geodata-serialization
646 #+qres geodata-optimized-serialization
647 extension-serialization
649 empty-message-serialization
652 (register-test 'serialization-tests)