test.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
test.lisp (7810B)
---
1 (in-package :trivial-gray-streams-test)
2
3 ;;; assert-invoked - a tool to check that specified method with parameters has
4 ;;; been invoked during execution of a code body
5
6 (define-condition invoked ()
7 ((method :type (or symbol cons) ;; cons is for (setf method)
8 :accessor method
9 :initarg :method
10 :initform (error ":method is required"))
11 (args :type list
12 :accessor args
13 :initarg :args
14 :initform nil)))
15
16 (defun assert-invoked-impl (method args body-fn)
17 (let ((expected-invocation (cons method args))
18 (actual-invocations nil))
19 (handler-bind ((invoked (lambda (i)
20 (let ((invocation (cons (method i) (args i))))
21 (when (equalp invocation expected-invocation)
22 (return-from assert-invoked-impl nil))
23 (push invocation actual-invocations)))))
24 (funcall body-fn))
25 (let ((*package* (find-package :keyword))) ; ensures package prefixes are printed
26 (error "expected invocation: ~(~S~) actual: ~{~(~S~)~^, ~}"
27 expected-invocation (reverse actual-invocations)))))
28
29 (defmacro assert-invoked ((method &rest args) &body body)
30 "If during execution of the BODY the specified METHOD with ARGS
31 hasn't been invoked, signals an ERROR."
32 `(assert-invoked-impl (quote ,method) (list ,@args) (lambda () ,@body)))
33
34 (defun invoked (method &rest args)
35 (signal 'invoked :method method :args args))
36
37 ;;; The tests.
38
39 #|
40 We will define a gray stream class, specialise
41 the gray generic function methods on it and test that the methods
42 are invoked when we call functions from common-lisp package
43 on that stream.
44
45 Some of the gray generic functions are only invoked by default
46 methods of other generic functions:
47
48 cl:format ~t or cl:pprint -> stream-advance-to-column -> stream-line-column
49 stream-write-char
50 cl:fresh-line -> stream-fresh-line -> stream-start-line-p -> stream-line-column
51 stream-terpri
52
53
54 If we define our methods for stream-advance-to-column and stream-fresh-line,
55 then stream-start-line-p, stream-terpri, stram-line-column are not invoked.
56
57 Therefore we define another gray stream class. The first class is used
58 for all lower level functions (stream-terpri). The second class
59 is used to test methods for higher level functions (stream-fresh-line).
60 |#
61
62 (defclass test-stream (fundamental-binary-input-stream
63 fundamental-binary-output-stream
64 fundamental-character-input-stream
65 fundamental-character-output-stream)
66 ())
67
68 (defclass test-stream2 (test-stream) ())
69
70 (defmethod stream-read-char ((stream test-stream))
71 (invoked 'stream-read-char stream))
72
73 (defmethod stream-unread-char ((stream test-stream) char)
74 (invoked 'stream-unread-char stream char))
75
76 (defmethod stream-read-char-no-hang ((stream test-stream))
77 (invoked 'stream-read-char-no-hang stream))
78
79 (defmethod stream-peek-char ((stream test-stream))
80 (invoked 'stream-peek-char stream))
81
82 (defmethod stream-listen ((stream test-stream))
83 (invoked 'stream-listen stream))
84
85 (defmethod stream-read-line ((stream test-stream))
86 (invoked 'stream-read-line stream))
87
88 (defmethod stream-clear-input ((stream test-stream))
89 (invoked 'stream-clear-input stream))
90
91 (defmethod stream-write-char ((stream test-stream) char)
92 (invoked 'stream-write-char stream char))
93
94 (defmethod stream-line-column ((stream test-stream))
95 (invoked 'stream-line-column stream))
96
97 (defmethod stream-start-line-p ((stream test-stream))
98 (invoked 'stream-start-line-p stream))
99
100 (defmethod stream-write-string ((stream test-stream) string &optional start end)
101 (invoked 'stream-write-string stream string start end))
102
103 (defmethod stream-terpri ((stream test-stream))
104 (invoked 'stream-terpri stream))
105
106 (defmethod stream-fresh-line ((stream test-stream2))
107 (invoked 'stream-fresh-line stream))
108
109 (defmethod stream-finish-output ((stream test-stream))
110 (invoked 'stream-finish-output stream))
111
112 (defmethod stream-force-output ((stream test-stream))
113 (invoked 'stream-force-output stream))
114
115 (defmethod stream-clear-output ((stream test-stream))
116 (invoked 'stream-clear-output stream))
117
118 (defmethod stream-advance-to-column ((stream test-stream2) column)
119 (invoked 'stream-advance-to-column stream column))
120
121 (defmethod stream-read-byte ((stream test-stream))
122 (invoked 'stream-read-byte stream))
123
124 (defmethod stream-write-byte ((stream test-stream) byte)
125 (invoked 'stream-write-byte stream byte))
126
127 (defmethod stream-read-sequence ((s test-stream) seq start end &key)
128 (invoked 'stream-read-sequence s seq :start start :end end))
129
130 (defmethod stream-write-sequence ((s test-stream) seq start end &key)
131 (invoked 'stream-write-sequence s seq :start start :end end))
132
133 (defmethod stream-file-position ((s test-stream))
134 (invoked 'stream-file-position s))
135
136 (defmethod (setf stream-file-position) (newval (s test-stream))
137 (invoked '(setf stream-file-position) newval s))
138
139 ;; Convinience macro, used when we want to name
140 ;; the test case with the same name as of the gray streams method we test.
141 (defmacro test-invoked ((method &rest args) &body body)
142 `(test (,method)
143 (assert-invoked (,method ,@args)
144 ,@body)))
145
146 (defun run-tests ()
147 (let ((s (make-instance 'test-stream))
148 (s2 (make-instance 'test-stream2)))
149 (list
150 (test-invoked (stream-read-char s)
151 (read-char s))
152 (test-invoked (stream-unread-char s #\a)
153 (unread-char #\a s))
154 (test-invoked (stream-read-char-no-hang s)
155 (read-char-no-hang s))
156 (test-invoked (stream-peek-char s)
157 (peek-char nil s))
158 (test-invoked (stream-listen s)
159 (listen s))
160 (test-invoked (stream-read-line s)
161 (read-line s))
162 (test-invoked (stream-clear-input s)
163 (clear-input s))
164 (test-invoked (stream-write-char s #\b)
165 (write-char #\b s))
166 (test-invoked (stream-line-column s)
167 (format s "~10,t"))
168 (test-invoked (stream-start-line-p s)
169 (fresh-line s))
170 (test-invoked (stream-write-string s "hello" 1 4)
171 (write-string "hello" s :start 1 :end 4))
172 (test-invoked (stream-terpri s)
173 (fresh-line s))
174 (test-invoked (stream-fresh-line s2)
175 (fresh-line s2))
176 (test-invoked (stream-finish-output s)
177 (finish-output s))
178 (test-invoked (stream-force-output s)
179 (force-output s))
180 (test-invoked (stream-clear-output s)
181 (clear-output s))
182 (test-invoked (stream-advance-to-column s2 10)
183 (format s2 "~10,t"))
184 (test-invoked (stream-read-byte s)
185 (read-byte s))
186 (test-invoked (stream-write-byte s 1)
187 (write-byte 1 s))
188 ;;; extensions
189 (let ((seq (vector 1 2)))
190 (test-invoked (stream-read-sequence s seq :start 0 :end 1)
191 (read-sequence seq s :start 0 :end 1))
192 (test-invoked (stream-write-sequence s seq :start 0 :end 1)
193 (write-sequence seq s :start 0 :end 1)))
194 (test-invoked (stream-file-position s)
195 (file-position s))
196 (test (setf-stream-file-position)
197 (assert-invoked ((setf stream-file-position) 9 s)
198 (file-position s 9))))))
199
200 (defun failed-tests (results)
201 (remove-if-not #'failed-p results))
202
203 (defun failed-test-names (results)
204 (mapcar (lambda (result)
205 (string-downcase (name result)))
206 (failed-tests results)))
207
208 #|
209 (failed-test-names (run-tests))
210
211 (setf *allow-debugger* nil))
212
213 |#