Commit | Line | Data |
---|---|---|
b73517d9 | 1 | ;;; eieio-testsinvoke.el -- eieio tests for method invocation |
6ee60310 | 2 | |
812a0930 | 3 | ;; Copyright (C) 2005, 2008, 2010, 2013-2014 Free Software Foundation, Inc. |
6ee60310 | 4 | |
812a0930 | 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
6ee60310 DE |
6 | |
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | ;;; Commentary: | |
23 | ;; | |
24 | ;; Test method invocation order. From the common lisp reference | |
25 | ;; manual: | |
26 | ;; | |
27 | ;; QUOTE: | |
28 | ;; - All the :before methods are called, in most-specific-first | |
29 | ;; order. Their values are ignored. An error is signaled if | |
30 | ;; call-next-method is used in a :before method. | |
31 | ;; | |
32 | ;; - The most specific primary method is called. Inside the body of a | |
33 | ;; primary method, call-next-method may be used to call the next | |
34 | ;; most specific primary method. When that method returns, the | |
35 | ;; previous primary method can execute more code, perhaps based on | |
36 | ;; the returned value or values. The generic function no-next-method | |
37 | ;; is invoked if call-next-method is used and there are no more | |
38 | ;; applicable primary methods. The function next-method-p may be | |
39 | ;; used to determine whether a next method exists. If | |
40 | ;; call-next-method is not used, only the most specific primary | |
41 | ;; method is called. | |
42 | ;; | |
43 | ;; - All the :after methods are called, in most-specific-last order. | |
44 | ;; Their values are ignored. An error is signaled if | |
45 | ;; call-next-method is used in a :after method. | |
46 | ;; | |
47 | ;; | |
48 | ;; Also test behavior of `call-next-method'. From clos.org: | |
49 | ;; | |
50 | ;; QUOTE: | |
51 | ;; When call-next-method is called with no arguments, it passes the | |
52 | ;; current method's original arguments to the next method. | |
53 | ||
54 | (require 'eieio) | |
55 | (require 'ert) | |
56 | ||
57 | (defvar eieio-test-method-order-list nil | |
58 | "List of symbols stored during method invocation.") | |
59 | ||
60 | (defun eieio-test-method-store () | |
61 | "Store current invocation class symbol in the invocation order list." | |
62 | (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ] | |
63 | (or eieio-generic-call-key 0))) | |
64 | (c (list eieio-generic-call-methodname keysym (eieio--scoped-class)))) | |
65 | (setq eieio-test-method-order-list | |
66 | (cons c eieio-test-method-order-list)))) | |
67 | ||
68 | (defun eieio-test-match (rightanswer) | |
69 | "Do a test match." | |
70 | (if (equal rightanswer eieio-test-method-order-list) | |
71 | t | |
72 | (error "eieio-test-methodinvoke.el: Test Failed!"))) | |
73 | ||
74 | (defvar eieio-test-call-next-method-arguments nil | |
75 | "List of passed to methods during execution of `call-next-method'.") | |
76 | ||
77 | (defun eieio-test-arguments-for (class) | |
78 | "Returns arguments passed to method of CLASS during `call-next-method'." | |
79 | (cdr (assoc class eieio-test-call-next-method-arguments))) | |
80 | ||
81 | (defclass eitest-A () ()) | |
82 | (defclass eitest-AA (eitest-A) ()) | |
83 | (defclass eitest-AAA (eitest-AA) ()) | |
84 | (defclass eitest-B-base1 () ()) | |
85 | (defclass eitest-B-base2 () ()) | |
86 | (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) | |
87 | ||
88 | (defmethod eitest-F :BEFORE ((p eitest-B-base1)) | |
89 | (eieio-test-method-store)) | |
90 | ||
91 | (defmethod eitest-F :BEFORE ((p eitest-B-base2)) | |
92 | (eieio-test-method-store)) | |
93 | ||
94 | (defmethod eitest-F :BEFORE ((p eitest-B)) | |
95 | (eieio-test-method-store)) | |
96 | ||
97 | (defmethod eitest-F ((p eitest-B)) | |
98 | (eieio-test-method-store) | |
99 | (call-next-method)) | |
100 | ||
101 | (defmethod eitest-F ((p eitest-B-base1)) | |
102 | (eieio-test-method-store) | |
103 | (call-next-method)) | |
104 | ||
105 | (defmethod eitest-F ((p eitest-B-base2)) | |
106 | (eieio-test-method-store) | |
107 | (when (next-method-p) | |
108 | (call-next-method)) | |
109 | ) | |
110 | ||
111 | (defmethod eitest-F :AFTER ((p eitest-B-base1)) | |
112 | (eieio-test-method-store)) | |
113 | ||
114 | (defmethod eitest-F :AFTER ((p eitest-B-base2)) | |
115 | (eieio-test-method-store)) | |
116 | ||
117 | (defmethod eitest-F :AFTER ((p eitest-B)) | |
118 | (eieio-test-method-store)) | |
119 | ||
120 | (ert-deftest eieio-test-method-order-list-3 () | |
121 | (let ((eieio-test-method-order-list nil) | |
122 | (ans '( | |
123 | (eitest-F :BEFORE eitest-B) | |
124 | (eitest-F :BEFORE eitest-B-base1) | |
125 | (eitest-F :BEFORE eitest-B-base2) | |
126 | ||
127 | (eitest-F :PRIMARY eitest-B) | |
128 | (eitest-F :PRIMARY eitest-B-base1) | |
129 | (eitest-F :PRIMARY eitest-B-base2) | |
130 | ||
131 | (eitest-F :AFTER eitest-B-base2) | |
132 | (eitest-F :AFTER eitest-B-base1) | |
133 | (eitest-F :AFTER eitest-B) | |
134 | ))) | |
135 | (eitest-F (eitest-B nil)) | |
136 | (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) | |
137 | (eieio-test-match ans))) | |
138 | ||
b73517d9 | 139 | ;;; Test static invocation |
6ee60310 DE |
140 | ;; |
141 | (defmethod eitest-H :STATIC ((class eitest-A)) | |
142 | "No need to do work in here." | |
143 | 'moose) | |
144 | ||
145 | (ert-deftest eieio-test-method-order-list-4 () | |
146 | ;; Both of these situations should succeed. | |
147 | (should (eitest-H eitest-A)) | |
148 | (should (eitest-H (eitest-A nil)))) | |
149 | ||
150 | ;;; Return value from :PRIMARY | |
151 | ;; | |
152 | (defmethod eitest-I :BEFORE ((a eitest-A)) | |
153 | (eieio-test-method-store) | |
154 | ":before") | |
155 | ||
156 | (defmethod eitest-I :PRIMARY ((a eitest-A)) | |
157 | (eieio-test-method-store) | |
158 | ":primary") | |
159 | ||
160 | (defmethod eitest-I :AFTER ((a eitest-A)) | |
161 | (eieio-test-method-store) | |
162 | ":after") | |
163 | ||
164 | (ert-deftest eieio-test-method-order-list-5 () | |
165 | (let ((eieio-test-method-order-list nil) | |
166 | (ans (eitest-I (eitest-A nil)))) | |
167 | (should (string= ans ":primary")))) | |
168 | ||
169 | ;;; Multiple inheritance and the 'constructor' method. | |
170 | ;; | |
171 | ;; Constructor is a static method, so this is really testing | |
172 | ;; static method invocation and multiple inheritance. | |
173 | ;; | |
174 | (defclass C-base1 () ()) | |
175 | (defclass C-base2 () ()) | |
176 | (defclass C (C-base1 C-base2) ()) | |
177 | ||
178 | (defmethod constructor :STATIC ((p C-base1) &rest args) | |
179 | (eieio-test-method-store) | |
180 | (if (next-method-p) (call-next-method)) | |
181 | ) | |
182 | ||
183 | (defmethod constructor :STATIC ((p C-base2) &rest args) | |
184 | (eieio-test-method-store) | |
185 | (if (next-method-p) (call-next-method)) | |
186 | ) | |
187 | ||
188 | (defmethod constructor :STATIC ((p C) &rest args) | |
189 | (eieio-test-method-store) | |
190 | (call-next-method) | |
191 | ) | |
192 | ||
193 | (ert-deftest eieio-test-method-order-list-6 () | |
194 | (let ((eieio-test-method-order-list nil) | |
195 | (ans '( | |
196 | (constructor :STATIC C) | |
197 | (constructor :STATIC C-base1) | |
198 | (constructor :STATIC C-base2) | |
199 | ))) | |
200 | (C nil) | |
201 | (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) | |
202 | (eieio-test-match ans))) | |
203 | ||
204 | ;;; Diamond Test | |
205 | ;; | |
206 | ;; For a diamond shaped inheritance structure, (call-next-method) can break. | |
207 | ;; As such, there are two possible orders. | |
208 | ||
209 | (defclass D-base0 () () :method-invocation-order :depth-first) | |
210 | (defclass D-base1 (D-base0) () :method-invocation-order :depth-first) | |
211 | (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) | |
212 | (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) | |
213 | ||
214 | (defmethod eitest-F ((p D)) | |
215 | "D" | |
216 | (eieio-test-method-store) | |
217 | (call-next-method)) | |
218 | ||
219 | (defmethod eitest-F ((p D-base0)) | |
220 | "D-base0" | |
221 | (eieio-test-method-store) | |
222 | ;; This should have no next | |
223 | ;; (when (next-method-p) (call-next-method)) | |
224 | ) | |
225 | ||
226 | (defmethod eitest-F ((p D-base1)) | |
227 | "D-base1" | |
228 | (eieio-test-method-store) | |
229 | (call-next-method)) | |
230 | ||
231 | (defmethod eitest-F ((p D-base2)) | |
232 | "D-base2" | |
233 | (eieio-test-method-store) | |
234 | (when (next-method-p) | |
235 | (call-next-method)) | |
236 | ) | |
237 | ||
238 | (ert-deftest eieio-test-method-order-list-7 () | |
239 | (let ((eieio-test-method-order-list nil) | |
240 | (ans '( | |
241 | (eitest-F :PRIMARY D) | |
242 | (eitest-F :PRIMARY D-base1) | |
243 | ;; (eitest-F :PRIMARY D-base2) | |
244 | (eitest-F :PRIMARY D-base0) | |
245 | ))) | |
246 | (eitest-F (D nil)) | |
247 | (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) | |
248 | (eieio-test-match ans))) | |
249 | ||
250 | ;;; Other invocation order | |
251 | ||
252 | (defclass E-base0 () () :method-invocation-order :breadth-first) | |
253 | (defclass E-base1 (E-base0) () :method-invocation-order :breadth-first) | |
254 | (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) | |
255 | (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) | |
256 | ||
257 | (defmethod eitest-F ((p E)) | |
258 | (eieio-test-method-store) | |
259 | (call-next-method)) | |
260 | ||
261 | (defmethod eitest-F ((p E-base0)) | |
262 | (eieio-test-method-store) | |
263 | ;; This should have no next | |
264 | ;; (when (next-method-p) (call-next-method)) | |
265 | ) | |
266 | ||
267 | (defmethod eitest-F ((p E-base1)) | |
268 | (eieio-test-method-store) | |
269 | (call-next-method)) | |
270 | ||
271 | (defmethod eitest-F ((p E-base2)) | |
272 | (eieio-test-method-store) | |
273 | (when (next-method-p) | |
274 | (call-next-method)) | |
275 | ) | |
276 | ||
277 | (ert-deftest eieio-test-method-order-list-8 () | |
278 | (let ((eieio-test-method-order-list nil) | |
279 | (ans '( | |
280 | (eitest-F :PRIMARY E) | |
281 | (eitest-F :PRIMARY E-base1) | |
282 | (eitest-F :PRIMARY E-base2) | |
283 | (eitest-F :PRIMARY E-base0) | |
284 | ))) | |
285 | (eitest-F (E nil)) | |
286 | (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) | |
287 | (eieio-test-match ans))) | |
288 | ||
289 | ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods. | |
290 | ;; | |
291 | (defclass eitest-Ja () | |
292 | ()) | |
293 | ||
294 | (defmethod initialize-instance :after ((this eitest-Ja) &rest slots) | |
295 | ;(message "+Ja") | |
296 | (when (next-method-p) | |
297 | (call-next-method)) | |
298 | ;(message "-Ja") | |
299 | ) | |
300 | ||
301 | (defclass eitest-Jb () | |
302 | ()) | |
303 | ||
304 | (defmethod initialize-instance :after ((this eitest-Jb) &rest slots) | |
305 | ;(message "+Jb") | |
306 | (when (next-method-p) | |
307 | (call-next-method)) | |
308 | ;(message "-Jb") | |
309 | ) | |
310 | ||
311 | (defclass eitest-Jc (eitest-Jb) | |
312 | ()) | |
313 | ||
314 | (defclass eitest-Jd (eitest-Jc eitest-Ja) | |
315 | ()) | |
316 | ||
317 | (defmethod initialize-instance ((this eitest-Jd) &rest slots) | |
318 | ;(message "+Jd") | |
319 | (when (next-method-p) | |
320 | (call-next-method)) | |
321 | ;(message "-Jd") | |
322 | ) | |
323 | ||
324 | (ert-deftest eieio-test-method-order-list-9 () | |
325 | (should (eitest-Jd "test"))) | |
326 | ||
327 | ;;; call-next-method with replacement arguments across a simple class hierarchy. | |
328 | ;; | |
329 | ||
330 | (defclass CNM-0 () | |
331 | ()) | |
332 | ||
333 | (defclass CNM-1-1 (CNM-0) | |
334 | ()) | |
335 | ||
336 | (defclass CNM-1-2 (CNM-0) | |
337 | ()) | |
338 | ||
339 | (defclass CNM-2 (CNM-1-1 CNM-1-2) | |
340 | ()) | |
341 | ||
342 | (defmethod CNM-M ((this CNM-0) args) | |
343 | (push (cons 'CNM-0 (copy-sequence args)) | |
344 | eieio-test-call-next-method-arguments) | |
345 | (when (next-method-p) | |
346 | (call-next-method | |
347 | this (cons 'CNM-0 args)))) | |
348 | ||
349 | (defmethod CNM-M ((this CNM-1-1) args) | |
350 | (push (cons 'CNM-1-1 (copy-sequence args)) | |
351 | eieio-test-call-next-method-arguments) | |
352 | (when (next-method-p) | |
353 | (call-next-method | |
354 | this (cons 'CNM-1-1 args)))) | |
355 | ||
356 | (defmethod CNM-M ((this CNM-1-2) args) | |
357 | (push (cons 'CNM-1-2 (copy-sequence args)) | |
358 | eieio-test-call-next-method-arguments) | |
359 | (when (next-method-p) | |
360 | (call-next-method))) | |
361 | ||
362 | (defmethod CNM-M ((this CNM-2) args) | |
363 | (push (cons 'CNM-2 (copy-sequence args)) | |
364 | eieio-test-call-next-method-arguments) | |
365 | (when (next-method-p) | |
366 | (call-next-method | |
367 | this (cons 'CNM-2 args)))) | |
368 | ||
369 | (ert-deftest eieio-test-method-order-list-10 () | |
370 | (let ((eieio-test-call-next-method-arguments nil)) | |
371 | (CNM-M (CNM-2 "") '(INIT)) | |
372 | (should (equal (eieio-test-arguments-for 'CNM-0) | |
373 | '(CNM-1-1 CNM-2 INIT))) | |
374 | (should (equal (eieio-test-arguments-for 'CNM-1-1) | |
375 | '(CNM-2 INIT))) | |
376 | (should (equal (eieio-test-arguments-for 'CNM-1-2) | |
377 | '(CNM-1-1 CNM-2 INIT))) | |
378 | (should (equal (eieio-test-arguments-for 'CNM-2) | |
379 | '(INIT))))) |