1 ;;; eieio-testsinvoke.el -- eieio tests for method invocation
3 ;; Copyright (C) 2005, 2008, 2010, 2013 Free Software Foundation, Inc.
5 ;; Author: Eric. M. Ludlam <zappo@gnu.org>
7 ;; This file is part of GNU Emacs.
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.
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.
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/>.
24 ;; Test method invocation order. From the common lisp reference
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.
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
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.
48 ;; Also test behavior of `call-next-method'. From clos.org:
51 ;; When call-next-method is called with no arguments, it passes the
52 ;; current method's original arguments to the next method.
57 (defvar eieio-test-method-order-list nil
58 "List of symbols stored during method invocation.")
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
))))
68 (defun eieio-test-match (rightanswer)
70 (if (equal rightanswer eieio-test-method-order-list
)
72 (error "eieio-test-methodinvoke.el: Test Failed!")))
74 (defvar eieio-test-call-next-method-arguments nil
75 "List of passed to methods during execution of `call-next-method'.")
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
)))
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
) ())
88 (defmethod eitest-F :BEFORE
((p eitest-B-base1
))
89 (eieio-test-method-store))
91 (defmethod eitest-F :BEFORE
((p eitest-B-base2
))
92 (eieio-test-method-store))
94 (defmethod eitest-F :BEFORE
((p eitest-B
))
95 (eieio-test-method-store))
97 (defmethod eitest-F ((p eitest-B
))
98 (eieio-test-method-store)
101 (defmethod eitest-F ((p eitest-B-base1
))
102 (eieio-test-method-store)
105 (defmethod eitest-F ((p eitest-B-base2
))
106 (eieio-test-method-store)
107 (when (next-method-p)
111 (defmethod eitest-F :AFTER
((p eitest-B-base1
))
112 (eieio-test-method-store))
114 (defmethod eitest-F :AFTER
((p eitest-B-base2
))
115 (eieio-test-method-store))
117 (defmethod eitest-F :AFTER
((p eitest-B
))
118 (eieio-test-method-store))
120 (ert-deftest eieio-test-method-order-list-3
()
121 (let ((eieio-test-method-order-list nil
)
123 (eitest-F :BEFORE eitest-B
)
124 (eitest-F :BEFORE eitest-B-base1
)
125 (eitest-F :BEFORE eitest-B-base2
)
127 (eitest-F :PRIMARY eitest-B
)
128 (eitest-F :PRIMARY eitest-B-base1
)
129 (eitest-F :PRIMARY eitest-B-base2
)
131 (eitest-F :AFTER eitest-B-base2
)
132 (eitest-F :AFTER eitest-B-base1
)
133 (eitest-F :AFTER eitest-B
)
135 (eitest-F (eitest-B nil
))
136 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
137 (eieio-test-match ans
)))
139 ;;; Test static invocation
141 (defmethod eitest-H :STATIC
((class eitest-A
))
142 "No need to do work in here."
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
))))
150 ;;; Return value from :PRIMARY
152 (defmethod eitest-I :BEFORE
((a eitest-A
))
153 (eieio-test-method-store)
156 (defmethod eitest-I :PRIMARY
((a eitest-A
))
157 (eieio-test-method-store)
160 (defmethod eitest-I :AFTER
((a eitest-A
))
161 (eieio-test-method-store)
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"))))
169 ;;; Multiple inheritance and the 'constructor' method.
171 ;; Constructor is a static method, so this is really testing
172 ;; static method invocation and multiple inheritance.
174 (defclass C-base1
() ())
175 (defclass C-base2
() ())
176 (defclass C
(C-base1 C-base2
) ())
178 (defmethod constructor :STATIC
((p C-base1
) &rest args
)
179 (eieio-test-method-store)
180 (if (next-method-p) (call-next-method))
183 (defmethod constructor :STATIC
((p C-base2
) &rest args
)
184 (eieio-test-method-store)
185 (if (next-method-p) (call-next-method))
188 (defmethod constructor :STATIC
((p C
) &rest args
)
189 (eieio-test-method-store)
193 (ert-deftest eieio-test-method-order-list-6
()
194 (let ((eieio-test-method-order-list nil
)
196 (constructor :STATIC C
)
197 (constructor :STATIC C-base1
)
198 (constructor :STATIC C-base2
)
201 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
202 (eieio-test-match ans
)))
206 ;; For a diamond shaped inheritance structure, (call-next-method) can break.
207 ;; As such, there are two possible orders.
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
)
214 (defmethod eitest-F ((p D
))
216 (eieio-test-method-store)
219 (defmethod eitest-F ((p D-base0
))
221 (eieio-test-method-store)
222 ;; This should have no next
223 ;; (when (next-method-p) (call-next-method))
226 (defmethod eitest-F ((p D-base1
))
228 (eieio-test-method-store)
231 (defmethod eitest-F ((p D-base2
))
233 (eieio-test-method-store)
234 (when (next-method-p)
238 (ert-deftest eieio-test-method-order-list-7
()
239 (let ((eieio-test-method-order-list nil
)
241 (eitest-F :PRIMARY D
)
242 (eitest-F :PRIMARY D-base1
)
243 ;; (eitest-F :PRIMARY D-base2)
244 (eitest-F :PRIMARY D-base0
)
247 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
248 (eieio-test-match ans
)))
250 ;;; Other invocation order
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
)
257 (defmethod eitest-F ((p E
))
258 (eieio-test-method-store)
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))
267 (defmethod eitest-F ((p E-base1
))
268 (eieio-test-method-store)
271 (defmethod eitest-F ((p E-base2
))
272 (eieio-test-method-store)
273 (when (next-method-p)
277 (ert-deftest eieio-test-method-order-list-8
()
278 (let ((eieio-test-method-order-list nil
)
280 (eitest-F :PRIMARY E
)
281 (eitest-F :PRIMARY E-base1
)
282 (eitest-F :PRIMARY E-base2
)
283 (eitest-F :PRIMARY E-base0
)
286 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
287 (eieio-test-match ans
)))
289 ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
291 (defclass eitest-Ja
()
294 (defmethod initialize-instance :after
((this eitest-Ja
) &rest slots
)
296 (when (next-method-p)
301 (defclass eitest-Jb
()
304 (defmethod initialize-instance :after
((this eitest-Jb
) &rest slots
)
306 (when (next-method-p)
311 (defclass eitest-Jc
(eitest-Jb)
314 (defclass eitest-Jd
(eitest-Jc eitest-Ja
)
317 (defmethod initialize-instance ((this eitest-Jd
) &rest slots
)
319 (when (next-method-p)
324 (ert-deftest eieio-test-method-order-list-9
()
325 (should (eitest-Jd "test")))
327 ;;; call-next-method with replacement arguments across a simple class hierarchy.
333 (defclass CNM-1-1
(CNM-0)
336 (defclass CNM-1-2
(CNM-0)
339 (defclass CNM-2
(CNM-1-1 CNM-1-2
)
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)
347 this
(cons 'CNM-0 args
))))
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)
354 this
(cons 'CNM-1-1 args
))))
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)
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)
367 this
(cons 'CNM-2 args
))))
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
)
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
)