1 ;;; eieio-testsinvoke.el -- eieio tests for method invocation
3 ;; Copyright (C) 2005, 2008, 2010, 2013-2015 Free Software Foundation,
6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; Test method invocation order. From the common lisp reference
29 ;; - All the :before methods are called, in most-specific-first
30 ;; order. Their values are ignored. An error is signaled if
31 ;; call-next-method is used in a :before method.
33 ;; - The most specific primary method is called. Inside the body of a
34 ;; primary method, call-next-method may be used to call the next
35 ;; most specific primary method. When that method returns, the
36 ;; previous primary method can execute more code, perhaps based on
37 ;; the returned value or values. The generic function no-next-method
38 ;; is invoked if call-next-method is used and there are no more
39 ;; applicable primary methods. The function next-method-p may be
40 ;; used to determine whether a next method exists. If
41 ;; call-next-method is not used, only the most specific primary
44 ;; - All the :after methods are called, in most-specific-last order.
45 ;; Their values are ignored. An error is signaled if
46 ;; call-next-method is used in a :after method.
49 ;; Also test behavior of `call-next-method'. From clos.org:
52 ;; When call-next-method is called with no arguments, it passes the
53 ;; current method's original arguments to the next method.
58 (defvar eieio-test-method-order-list nil
59 "List of symbols stored during method invocation.")
61 (defun eieio-test-method-store ()
62 "Store current invocation class symbol in the invocation order list."
63 (let* ((keysym (aref [ :STATIC
:BEFORE
:PRIMARY
:AFTER
]
64 (or eieio--generic-call-key
0)))
65 ;; FIXME: Don't depend on `eieio--scoped-class'!
66 (c (list keysym
(eieio--class-symbol (eieio--scoped-class)))))
67 (push c eieio-test-method-order-list
)))
69 (defun eieio-test-match (rightanswer)
71 (if (equal rightanswer eieio-test-method-order-list
)
73 (error "eieio-test-methodinvoke.el: Test Failed: %S != %S"
74 rightanswer eieio-test-method-order-list
)))
76 (defvar eieio-test-call-next-method-arguments nil
77 "List of passed to methods during execution of `call-next-method'.")
79 (defun eieio-test-arguments-for (class)
80 "Returns arguments passed to method of CLASS during `call-next-method'."
81 (cdr (assoc class eieio-test-call-next-method-arguments
)))
83 (defclass eitest-A
() ())
84 (defclass eitest-AA
(eitest-A) ())
85 (defclass eitest-AAA
(eitest-AA) ())
86 (defclass eitest-B-base1
() ())
87 (defclass eitest-B-base2
() ())
88 (defclass eitest-B
(eitest-B-base1 eitest-B-base2
) ())
90 (defmethod eitest-F :BEFORE
((p eitest-B-base1
))
91 (eieio-test-method-store))
93 (defmethod eitest-F :BEFORE
((p eitest-B-base2
))
94 (eieio-test-method-store))
96 (defmethod eitest-F :BEFORE
((p eitest-B
))
97 (eieio-test-method-store))
99 (defmethod eitest-F ((p eitest-B
))
100 (eieio-test-method-store)
103 (defmethod eitest-F ((p eitest-B-base1
))
104 (eieio-test-method-store)
107 (defmethod eitest-F ((p eitest-B-base2
))
108 (eieio-test-method-store)
109 (when (next-method-p)
113 (defmethod eitest-F :AFTER
((p eitest-B-base1
))
114 (eieio-test-method-store))
116 (defmethod eitest-F :AFTER
((p eitest-B-base2
))
117 (eieio-test-method-store))
119 (defmethod eitest-F :AFTER
((p eitest-B
))
120 (eieio-test-method-store))
122 (ert-deftest eieio-test-method-order-list-3
()
123 (let ((eieio-test-method-order-list nil
)
126 (:BEFORE eitest-B-base1
)
127 (:BEFORE eitest-B-base2
)
130 (:PRIMARY eitest-B-base1
)
131 (:PRIMARY eitest-B-base2
)
133 (:AFTER eitest-B-base2
)
134 (:AFTER eitest-B-base1
)
137 (eitest-F (eitest-B nil
))
138 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
139 (eieio-test-match ans
)))
141 ;;; Test static invocation
143 (defmethod eitest-H :STATIC
((class eitest-A
))
144 "No need to do work in here."
147 (ert-deftest eieio-test-method-order-list-4
()
148 ;; Both of these situations should succeed.
149 (should (eitest-H 'eitest-A
))
150 (should (eitest-H (eitest-A nil
))))
152 ;;; Return value from :PRIMARY
154 (defmethod eitest-I :BEFORE
((a eitest-A
))
155 (eieio-test-method-store)
158 (defmethod eitest-I :PRIMARY
((a eitest-A
))
159 (eieio-test-method-store)
162 (defmethod eitest-I :AFTER
((a eitest-A
))
163 (eieio-test-method-store)
166 (ert-deftest eieio-test-method-order-list-5
()
167 (let ((eieio-test-method-order-list nil
)
168 (ans (eitest-I (eitest-A nil
))))
169 (should (string= ans
":primary"))))
171 ;;; Multiple inheritance and the 'constructor' method.
173 ;; Constructor is a static method, so this is really testing
174 ;; static method invocation and multiple inheritance.
176 (defclass C-base1
() ())
177 (defclass C-base2
() ())
178 (defclass C
(C-base1 C-base2
) ())
180 ;; Just use the obsolete name once, to make sure it also works.
181 (defmethod constructor :STATIC
((p C-base1
) &rest args
)
182 (eieio-test-method-store)
183 (if (next-method-p) (call-next-method))
186 (defmethod eieio-constructor :STATIC
((p C-base2
) &rest args
)
187 (eieio-test-method-store)
188 (if (next-method-p) (call-next-method))
191 (defmethod eieio-constructor :STATIC
((p C
) &rest args
)
192 (eieio-test-method-store)
196 (ert-deftest eieio-test-method-order-list-6
()
197 (let ((eieio-test-method-order-list nil
)
204 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
205 (eieio-test-match ans
)))
209 ;; For a diamond shaped inheritance structure, (call-next-method) can break.
210 ;; As such, there are two possible orders.
212 (defclass D-base0
() () :method-invocation-order
:depth-first
)
213 (defclass D-base1
(D-base0) () :method-invocation-order
:depth-first
)
214 (defclass D-base2
(D-base0) () :method-invocation-order
:depth-first
)
215 (defclass D
(D-base1 D-base2
) () :method-invocation-order
:depth-first
)
217 (defmethod eitest-F ((p D
))
219 (eieio-test-method-store)
222 (defmethod eitest-F ((p D-base0
))
224 (eieio-test-method-store)
225 ;; This should have no next
226 ;; (when (next-method-p) (call-next-method))
229 (defmethod eitest-F ((p D-base1
))
231 (eieio-test-method-store)
234 (defmethod eitest-F ((p D-base2
))
236 (eieio-test-method-store)
237 (when (next-method-p)
241 (ert-deftest eieio-test-method-order-list-7
()
242 (let ((eieio-test-method-order-list nil
)
246 ;; (:PRIMARY D-base2)
250 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
251 (eieio-test-match ans
)))
253 ;;; Other invocation order
255 (defclass E-base0
() () :method-invocation-order
:breadth-first
)
256 (defclass E-base1
(E-base0) () :method-invocation-order
:breadth-first
)
257 (defclass E-base2
(E-base0) () :method-invocation-order
:breadth-first
)
258 (defclass E
(E-base1 E-base2
) () :method-invocation-order
:breadth-first
)
260 (defmethod eitest-F ((p E
))
261 (eieio-test-method-store)
264 (defmethod eitest-F ((p E-base0
))
265 (eieio-test-method-store)
266 ;; This should have no next
267 ;; (when (next-method-p) (call-next-method))
270 (defmethod eitest-F ((p E-base1
))
271 (eieio-test-method-store)
274 (defmethod eitest-F ((p E-base2
))
275 (eieio-test-method-store)
276 (when (next-method-p)
280 (ert-deftest eieio-test-method-order-list-8
()
281 (let ((eieio-test-method-order-list nil
)
289 (setq eieio-test-method-order-list
(nreverse eieio-test-method-order-list
))
290 (eieio-test-match ans
)))
292 ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
294 (defclass eitest-Ja
()
297 (defmethod initialize-instance :after
((this eitest-Ja
) &rest slots
)
299 (when (next-method-p)
304 (defclass eitest-Jb
()
307 (defmethod initialize-instance :after
((this eitest-Jb
) &rest slots
)
309 (when (next-method-p)
314 (defclass eitest-Jc
(eitest-Jb)
317 (defclass eitest-Jd
(eitest-Jc eitest-Ja
)
320 (defmethod initialize-instance ((this eitest-Jd
) &rest slots
)
322 (when (next-method-p)
327 (ert-deftest eieio-test-method-order-list-9
()
328 (should (eitest-Jd "test")))
330 ;;; call-next-method with replacement arguments across a simple class hierarchy.
336 (defclass CNM-1-1
(CNM-0)
339 (defclass CNM-1-2
(CNM-0)
342 (defclass CNM-2
(CNM-1-1 CNM-1-2
)
345 (defmethod CNM-M ((this CNM-0
) args
)
346 (push (cons 'CNM-0
(copy-sequence args
))
347 eieio-test-call-next-method-arguments
)
348 (when (next-method-p)
350 this
(cons 'CNM-0 args
))))
352 (defmethod CNM-M ((this CNM-1-1
) args
)
353 (push (cons 'CNM-1-1
(copy-sequence args
))
354 eieio-test-call-next-method-arguments
)
355 (when (next-method-p)
357 this
(cons 'CNM-1-1 args
))))
359 (defmethod CNM-M ((this CNM-1-2
) args
)
360 (push (cons 'CNM-1-2
(copy-sequence args
))
361 eieio-test-call-next-method-arguments
)
362 (when (next-method-p)
365 (defmethod CNM-M ((this CNM-2
) args
)
366 (push (cons 'CNM-2
(copy-sequence args
))
367 eieio-test-call-next-method-arguments
)
368 (when (next-method-p)
370 this
(cons 'CNM-2 args
))))
372 (ert-deftest eieio-test-method-order-list-10
()
373 (let ((eieio-test-call-next-method-arguments nil
))
374 (CNM-M (CNM-2 "") '(INIT))
375 (should (equal (eieio-test-arguments-for 'CNM-0
)
376 '(CNM-1-1 CNM-2 INIT
)))
377 (should (equal (eieio-test-arguments-for 'CNM-1-1
)
379 (should (equal (eieio-test-arguments-for 'CNM-1-2
)
380 '(CNM-1-1 CNM-2 INIT
)))
381 (should (equal (eieio-test-arguments-for 'CNM-2
)