-
-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathtests.lisp
297 lines (249 loc) · 11.1 KB
/
tests.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
;;; -*- Mode:LISP; Syntax: COMMON-LISP; Package: CL-MARSHAL-TEST; Base: 10; indent-tabs-mode: nil -*-
;;; ***********************************************************
;;;
;;; Project: marshal
;;; Simple (de)serialization of Lisp datastructures.
;;;
;;; File: tests.lisp
;;;
;;; Provides a decent test suite.
;;; Not included in asdf system definition.
;;; Requires unit test suite xpunit (available via quicklisp e.g.)
;;;
;;; ***********************************************************
(defpackage :cl-marshal-test
(:use :cl
:marshal
:xlunit))
(in-package :cl-marshal-test)
;;; ***********************************************************
;; definition of test classes
(defclass ship ()
((name :initform "" :initarg :name :accessor name)
(dimensions :initform '(:width 0 :length 0) :initarg :dimensions :accessor dimensions)
(course :initform 0 :initarg :course :accessor course)
(cruise :initform 0 :initarg :cruise :accessor cruise) ; shall be transient
(dinghy :initform nil :initarg :dinghy :accessor dinghy)) ; another ship -> ref
(:documentation "A democlass. Some 'persistent slots', one transient.
Some numbers, string, lists and object references."))
(defgeneric ttostring (ship))
(defmethod ttostring ((self ship))
(format nil "Vessel: ~a~%Fitting ~a degrees at ~a knots~% Length: ~a m~% Width: ~a m"
(name self) (course self) (cruise self)
(getf (dimensions self):length)
(getf (dimensions self):width)))
(defmethod ms:class-persistent-slots ((self ship))
'(name dimensions course dinghy))
(defclass sailingship (ship)
((sailarea :initform 0 :initarg :sailarea :accessor sailarea))
)
(defmethod ttostring ((self sailingship))
(format nil "~a~% Sail area: ~a sqm" (call-next-method) (sailarea self))
)
(defclass motorship (ship)
((enginepower :initform 0 :initarg :enginepower :accessor enginepower))
)
(defmethod ttostring ((self motorship))
(format nil "~a~% Engine power: ~a hp" (call-next-method) (enginepower self))
)
(defclass motorsailor (motorship sailingship)
()
)
(defclass dinghy (ship)
((aboard :initform nil :initarg :aboard :accessor aboard)) ; another ship -> circular ref
)
;; note: intentionally misspelled
(defmethod ms:class-persistant-slots ((self dinghy))
(append (call-next-method) '(aboard)))
;;; ***********************************************************
(defclass basetest (test-case)
((ship1 :accessor ship1 :initarg :ship1)
(ship2 :accessor ship2 :initarg :ship2)
(ship3 :accessor ship3 :initarg :ship3)
(ship4 :accessor ship4 :initarg :ship4)
(ship5 :accessor ship5 :initarg :ship5)
(ship6 :accessor ship6 :initarg :ship6)
(ships :accessor ships :initarg :ships))
)
(defmethod set-up ((self basetest))
(setf (ship1 self) (make-instance 'ship :name "Ark" :course 360 :dimensions '(:width 30 :length 90)))
(setf (ship2 self) (make-instance 'sailingship :name "Pinta" :course 270 :cruise 9
:dimensions '(:width 7 :length 21) :sailarea 400))
(setf (ship3 self) (make-instance 'motorship :name "Titanic" :course 320 :cruise 21
:dimensions '(:width 28 :length 269) :enginepower 51000))
(setf (ship4 self) (make-instance 'motorsailor :name "Gorch Fock" :course 180
:cruise 18 :dimensions '(:width 12 :length 82)
:sailarea 2037 :enginepower 1660))
(setf (ship5 self) (make-instance 'dinghy :name "Gig" :course 320 :cruise 5
:dimensions '(:width 2 :length 6)))
(setf (ship6 self) (make-instance 'dinghy :name "Gig" :course 320 :cruise 5
:dimensions '(:width 2 :length 6) :aboard (ship4 self)))
(setf (dinghy (ship3 self)) (ship5 self)) ; ref only
(setf (dinghy (ship4 self)) (ship6 self)) ; -> circle
(setf (ships self) (list (ship1 self) (ship2 self) (ship4 self) (ship6 self)))
)
(defclass objecttest (basetest)
()
)
(def-test-method test-objectref ((self objecttest) :run nil)
(assert-equal '(:pcode 1
(:object 1 motorship :cl-marshal-test (:simple-string 2 "Titanic")
(:list 3 :width 28 :length 269) 320
(:object 4 dinghy :cl-marshal-test (:simple-string 5 "Gig")
(:list 6 :width 2 :length 6) 320 (:list 7) (:reference 7))))
(marshal (ship3 self))))
(def-test-method test-objectcircle ((self objecttest) :run nil)
(let ((uma (unmarshal (marshal (ship4 self)))))
(assert-eql uma
(aboard (dinghy uma)))
))
(def-test-method test-listednestedobjects ((self objecttest) :run nil)
(let ((umshs (unmarshal (marshal (ships self)))))
(assert-eql (fourth umshs)
(dinghy (third umshs)))
(assert-eql (third umshs)
(aboard (fourth umshs))))
)
(defclass typestest (basetest)
()
)
(def-test-method simplearraytest ((self typestest) :run nil)
(let* ((arr (make-array '(10) :initial-contents '(0 1 2 3 4 5 6 7 8 9)))
(umarr (unmarshal (marshal arr))))
(assert-eql 2 (aref umarr 2))
(assert-eql 8 (aref umarr 8))
(assert-eql 9 (aref umarr 9))
(assert-not-eql arr umarr)
))
(def-test-method complexarraytest ((self typestest) :run nil)
(let* ((arr (make-array '(4 3 2) :initial-contents '(((1 2) (2 3) (3 4))
((11 12) (12 13) (13 14))
((21 22) (22 23) (23 24))
((31 32) (32 33) (33 34)) )))
(umarr (unmarshal (marshal arr))))
(assert-eql 24 (aref umarr 2 2 1))
(assert-eql 1 (aref umarr 0 0 0))
(assert-eql 12 (aref umarr 1 1 0))
(assert-not-eql arr umarr)
))
(def-test-method objectarraytest ((self typestest) :run nil)
(let* ((arr (make-array '(2 3) :initial-contents (list (list (ship1 self) (ship2 self) (ship3 self))
(list (ship4 self) (ship5 self) (ship6 self)) )))
(umarr (unmarshal (marshal arr))))
(assert-eql (dinghy (aref umarr 1 0)) (aref umarr 1 2))
(assert-eql (aref umarr 1 0) (aboard (aref umarr 1 2)))
(assert-not-eql arr umarr)
))
(def-test-method hashtabletest ((self typestest) :run nil)
(let* ((ht (make-hash-table))
(umht (unmarshal (marshal ht))))
(setf (gethash 1 ht) (ship1 self))
(setf (gethash 2 ht) (ship2 self))
(setf (gethash 3 ht) (ship3 self))
(setf (gethash 4 ht) (ship4 self))
(setf (gethash 5 ht) (ship5 self))
(setf (gethash 6 ht) (ship6 self))
(assert-eql (dinghy (gethash 4 ht)) (gethash 6 ht))
(assert-eql (gethash 4 ht) (aboard (gethash 6 ht)))
(assert-not-eql ht umht)))
(def-test-method function-lists-test ((self typestest) :run nil)
(let* ((list (list 2 3 4 #'+ #'*))
(uml (unmarshal (marshal list))))
(assert-true (functionp (elt uml 3)))
(assert-true (functionp (elt uml 4)))
(assert-true (= (funcall (elt uml 4)
(funcall (elt uml 3) (elt uml 2) (elt uml 1))
(elt uml 0))
14))))
(def-test-method dotlisttest ((self typestest) :run nil)
(let* ((dl '((3 #(1 2) . 4) ((5 . #(1 2)))))
(umdl (unmarshal (marshal dl))))
(assert-equal (cddr (first umdl)) 4)
(assert-equal (caar (second umdl)) 5)
(assert-true (equalp dl umdl))))
(def-test-method dotlisttest-2 ((self typestest) :run nil)
(let* ((dl (cons 1 (cons 2 3)))
(umdl (unmarshal (marshal dl))))
(assert-equal (cddr umdl) 3)
(assert-equal (cadr umdl) 2)))
(def-test-method simple-circular-list ((self typestest) :run nil)
(let ((orig (list 2 2 3 4 5 6)))
(setf (cdr (last orig)) orig)
(let ((restored (unmarshal (marshal orig))))
(assert-true (utils:circular-list-p restored))
(assert-equal (elt restored 8) 3))))
(def-test-method simple-circular-list-2 ((self typestest) :run nil)
(let ((orig (list (vector 1.0 2.0) (vector 3.0 4.0) 2 2 3 4 5 6)))
(setf (cdr (last orig)) orig)
(let ((restored (unmarshal (marshal orig))))
(assert-true (utils:circular-list-p restored))
(assert-true (vectorp (elt restored 0)))
(assert-true (vectorp (elt restored 1)))
(assert-true (floatp (elt (elt restored 0) 0))))))
(def-test-method object-circular-list ((self typestest) :run nil)
(let ((orig (list (make-instance 'ship :name "a")
(make-instance 'ship :name "b")
(make-instance 'ship :name "c"))))
(setf (cdr (last orig)) orig)
(let ((restored (unmarshal (marshal orig))))
(assert-true (utils:circular-list-p restored))
(assert-true (string= (name (elt restored 0)) "a")))))
(def-test-method object-circular-list-w-reference ((self typestest) :run nil)
(let* ((object (list (make-instance 'ship :name "a")))
(orig (list object 2 object 3)))
(setf (cdr (last orig)) orig)
(let ((restored (unmarshal (marshal orig))))
(assert-true (utils:circular-list-p restored))
(assert-true (eq (elt restored 0) (elt restored 2))))))
(defparameter *nested-circular-list* '#1=(2 2 #2=(a b) (#1# #1# (#1# #2#)) 5 #2# c . #1#))
(def-test-method nested-circular-list ((self typestest) :run nil)
(let ((restored (unmarshal (marshal *nested-circular-list*))))
(assert-true (utils:circular-list-p restored))
(assert-true (eq (caaddr *nested-circular-list*)
(caaddr restored)))
(assert-true (eq (caaddr restored)
'a))))
(def-test-method string-vector-fill-pointer-nil ((self typestest) :run nil)
(let* ((test-string (make-array 8
:element-type 'character
:initial-element #\a
:adjustable t
:fill-pointer nil))
(restored (unmarshal (marshal test-string))))
(assert-true (string= restored "aaaaaaaa"))))
(def-test-method string-vector-fill-pointer-t ((self typestest) :run nil)
(let* ((test-string (make-array 8
:element-type 'character
:initial-element #\a
:adjustable t
:fill-pointer t))
(restored (unmarshal (marshal test-string))))
(assert-true (string= restored "aaaaaaaa"))))
(defclass unserializable ()
((some-slot
:initform :default-value
:accessor some-slot
:initarg :some-slot)))
(defclass unserializable-wrapper ()
((unserializable-slot
:accessor unserializable-slot
:initarg :unserializable-slot
:initform (make-instance 'unserializable))))
(defmethod ms:class-persistent-slots ((object unserializable-wrapper))
'(unserializable-slot))
(def-test-method nil-value-slots-when-unserializable ((self typestest) :run nil)
(assert-true
(let ((instance (make-instance 'unserializable-wrapper
:unserializable-slot (make-instance 'unserializable))))
(typep (unserializable-slot (ms:unmarshal (ms:marshal instance)))
'unserializable)))
(assert-true
(let ((instance (make-instance 'unserializable-wrapper
:unserializable-slot (make-instance 'unserializable))))
(eq (some-slot (unserializable-slot (ms:unmarshal (ms:marshal instance))))
:default-value))))
(progn
(print "Testcase Objecttest")
(textui-test-run (get-suite objecttest))
(print "Testcase Typestest")
(textui-test-run (get-suite typestest)))