444 lines
14 KiB
EmacsLisp
444 lines
14 KiB
EmacsLisp
;;; eieio-test-methodinvoke.el --- eieio tests for method invocation -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2005, 2008, 2010, 2013-2024 Free Software Foundation,
|
|
;; Inc.
|
|
|
|
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; Test method invocation order. From the Common Lisp Reference
|
|
;; Manual:
|
|
;;
|
|
;; QUOTE:
|
|
;; - All the :before methods are called, in most-specific-first
|
|
;; order. Their values are ignored. An error is signaled if
|
|
;; call-next-method is used in a :before method.
|
|
;;
|
|
;; - The most specific primary method is called. Inside the body of a
|
|
;; primary method, call-next-method may be used to call the next
|
|
;; most specific primary method. When that method returns, the
|
|
;; previous primary method can execute more code, perhaps based on
|
|
;; the returned value or values. The generic function no-next-method
|
|
;; is invoked if call-next-method is used and there are no more
|
|
;; applicable primary methods. The function next-method-p may be
|
|
;; used to determine whether a next method exists. If
|
|
;; call-next-method is not used, only the most specific primary
|
|
;; method is called.
|
|
;;
|
|
;; - All the :after methods are called, in most-specific-last order.
|
|
;; Their values are ignored. An error is signaled if
|
|
;; call-next-method is used in a :after method.
|
|
;;
|
|
;;
|
|
;; Also test behavior of `call-next-method'. From clos.org:
|
|
;;
|
|
;; QUOTE:
|
|
;; When call-next-method is called with no arguments, it passes the
|
|
;; current method's original arguments to the next method.
|
|
|
|
;;; Code:
|
|
|
|
(require 'eieio)
|
|
;; FIXME: See Bug#52971.
|
|
(with-no-warnings
|
|
(require 'eieio-compat))
|
|
(require 'ert)
|
|
|
|
(defvar eieio-test-method-order-list nil
|
|
"List of symbols stored during method invocation.")
|
|
|
|
(defun eieio-test-method-store (&rest args)
|
|
"Store current invocation class symbol in the invocation order list."
|
|
(push args eieio-test-method-order-list))
|
|
|
|
(defun eieio-test-match (rightanswer)
|
|
"Do a test match."
|
|
(if (equal rightanswer eieio-test-method-order-list)
|
|
t
|
|
(error "eieio-test-methodinvoke.el: Test Failed: %S != %S"
|
|
rightanswer eieio-test-method-order-list)))
|
|
|
|
(defvar eieio-test-call-next-method-arguments nil
|
|
"List of passed to methods during execution of `call-next-method'.")
|
|
|
|
(defun eieio-test-arguments-for (class)
|
|
"Returns arguments passed to method of CLASS during `call-next-method'."
|
|
(cdr (assoc class eieio-test-call-next-method-arguments)))
|
|
|
|
(defclass eitest-A () ())
|
|
(defclass eitest-AA (eitest-A) ())
|
|
(defclass eitest-AAA (eitest-AA) ())
|
|
(defclass eitest-B-base1 () ())
|
|
(defclass eitest-B-base2 () ())
|
|
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete call-next-method)
|
|
(obsolete next-method-p))
|
|
(defmethod eitest-F :BEFORE ((_p eitest-B-base1))
|
|
(eieio-test-method-store :BEFORE 'eitest-B-base1))
|
|
|
|
(defmethod eitest-F :BEFORE ((_p eitest-B-base2))
|
|
(eieio-test-method-store :BEFORE 'eitest-B-base2))
|
|
|
|
(defmethod eitest-F :BEFORE ((_p eitest-B))
|
|
(eieio-test-method-store :BEFORE 'eitest-B))
|
|
|
|
(defmethod eitest-F ((_p eitest-B))
|
|
(eieio-test-method-store :PRIMARY 'eitest-B)
|
|
(call-next-method))
|
|
|
|
(defmethod eitest-F ((_p eitest-B-base1))
|
|
(eieio-test-method-store :PRIMARY 'eitest-B-base1)
|
|
(call-next-method))
|
|
|
|
(defmethod eitest-F ((_p eitest-B-base2))
|
|
(eieio-test-method-store :PRIMARY 'eitest-B-base2)
|
|
(when (next-method-p)
|
|
(call-next-method)))
|
|
|
|
(defmethod eitest-F :AFTER ((_p eitest-B-base1))
|
|
(eieio-test-method-store :AFTER 'eitest-B-base1))
|
|
|
|
(defmethod eitest-F :AFTER ((_p eitest-B-base2))
|
|
(eieio-test-method-store :AFTER 'eitest-B-base2))
|
|
|
|
(defmethod eitest-F :AFTER ((_p eitest-B))
|
|
(eieio-test-method-store :AFTER 'eitest-B)))
|
|
|
|
(ert-deftest eieio-test-method-order-list-3 ()
|
|
(let ((eieio-test-method-order-list nil)
|
|
(ans '(
|
|
(:BEFORE eitest-B)
|
|
(:BEFORE eitest-B-base1)
|
|
(:BEFORE eitest-B-base2)
|
|
|
|
(:PRIMARY eitest-B)
|
|
(:PRIMARY eitest-B-base1)
|
|
(:PRIMARY eitest-B-base2)
|
|
|
|
(:AFTER eitest-B-base2)
|
|
(:AFTER eitest-B-base1)
|
|
(:AFTER eitest-B)
|
|
)))
|
|
(eitest-F (eitest-B nil))
|
|
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
|
(eieio-test-match ans)))
|
|
|
|
;;; Test static invocation
|
|
;;
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric))
|
|
(defmethod eitest-H :STATIC ((_class eitest-A))
|
|
"No need to do work in here."
|
|
'moose))
|
|
|
|
(ert-deftest eieio-test-method-order-list-4 ()
|
|
;; Both of these situations should succeed.
|
|
(should (eitest-H 'eitest-A))
|
|
(should (eitest-H (eitest-A nil))))
|
|
|
|
;;; Return value from :PRIMARY
|
|
;;
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric))
|
|
(defmethod eitest-I :BEFORE ((_a eitest-A))
|
|
(eieio-test-method-store :BEFORE 'eitest-A)
|
|
":before")
|
|
|
|
(defmethod eitest-I :PRIMARY ((_a eitest-A))
|
|
(eieio-test-method-store :PRIMARY 'eitest-A)
|
|
":primary")
|
|
|
|
(defmethod eitest-I :AFTER ((_a eitest-A))
|
|
(eieio-test-method-store :AFTER 'eitest-A)
|
|
":after"))
|
|
|
|
(ert-deftest eieio-test-method-order-list-5 ()
|
|
(let ((eieio-test-method-order-list nil)
|
|
(ans (eitest-I (eitest-A nil))))
|
|
(should (string= ans ":primary"))))
|
|
|
|
;;; Multiple inheritance and the 'constructor' method.
|
|
;;
|
|
;; Constructor is a static method, so this is really testing
|
|
;; static method invocation and multiple inheritance.
|
|
;;
|
|
(defclass C-base1 () ())
|
|
(defclass C-base2 () ())
|
|
(defclass C (C-base1 C-base2) ())
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete next-method-p)
|
|
(obsolete call-next-method))
|
|
;; Just use the obsolete name once, to make sure it also works.
|
|
(defmethod constructor :STATIC ((_p C-base1) &rest _args)
|
|
(eieio-test-method-store :STATIC 'C-base1)
|
|
(if (next-method-p) (call-next-method)))
|
|
|
|
(defmethod make-instance :STATIC ((_p C-base2) &rest _args)
|
|
(eieio-test-method-store :STATIC 'C-base2)
|
|
(if (next-method-p) (call-next-method))))
|
|
|
|
(cl-defmethod make-instance ((_p (subclass C)) &rest _args)
|
|
(eieio-test-method-store :STATIC 'C)
|
|
(cl-call-next-method)
|
|
)
|
|
|
|
(ert-deftest eieio-test-method-order-list-6 ()
|
|
;; FIXME repeated intermittent failures on hydra (bug#24503)
|
|
;; ((:STATIC C) (:STATIC C-base1) (:STATIC C-base2)) != ((:STATIC C))")
|
|
:tags '(:unstable)
|
|
(let ((eieio-test-method-order-list nil)
|
|
(ans '(
|
|
(:STATIC C)
|
|
(:STATIC C-base1)
|
|
(:STATIC C-base2)
|
|
)))
|
|
(C nil)
|
|
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
|
(eieio-test-match ans)))
|
|
|
|
;;; Diamond Test
|
|
;;
|
|
;; For a diamond shaped inheritance structure, (call-next-method) can break.
|
|
;; As such, there are two possible orders.
|
|
|
|
(defclass D-base0 () () :method-invocation-order :depth-first)
|
|
(defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
|
|
(defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
|
|
(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete call-next-method)
|
|
(obsolete next-method-p))
|
|
(defmethod eitest-F ((_p D))
|
|
"D"
|
|
(eieio-test-method-store :PRIMARY 'D)
|
|
(call-next-method))
|
|
|
|
(defmethod eitest-F ((_p D-base0))
|
|
"D-base0"
|
|
(eieio-test-method-store :PRIMARY 'D-base0)
|
|
;; This should have no next
|
|
;; (when (next-method-p) (call-next-method))
|
|
)
|
|
|
|
(defmethod eitest-F ((_p D-base1))
|
|
"D-base1"
|
|
(eieio-test-method-store :PRIMARY 'D-base1)
|
|
(call-next-method))
|
|
|
|
(defmethod eitest-F ((_p D-base2))
|
|
"D-base2"
|
|
(eieio-test-method-store :PRIMARY 'D-base2)
|
|
(when (next-method-p)
|
|
(call-next-method))))
|
|
|
|
(ert-deftest eieio-test-method-order-list-7 ()
|
|
(let ((eieio-test-method-order-list nil)
|
|
(ans '(
|
|
(:PRIMARY D)
|
|
(:PRIMARY D-base1)
|
|
(:PRIMARY D-base2)
|
|
(:PRIMARY D-base0)
|
|
)))
|
|
(eitest-F (D nil))
|
|
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
|
(eieio-test-match ans)))
|
|
|
|
;;; Other invocation order
|
|
|
|
(defclass E-base0 () () :method-invocation-order :breadth-first)
|
|
(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
|
|
(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
|
|
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete next-method-p)
|
|
(obsolete call-next-method))
|
|
(defmethod eitest-F ((_p E))
|
|
(eieio-test-method-store :PRIMARY 'E)
|
|
(call-next-method))
|
|
|
|
(defmethod eitest-F ((_p E-base0))
|
|
(eieio-test-method-store :PRIMARY 'E-base0)
|
|
;; This should have no next
|
|
;; (when (next-method-p) (call-next-method))
|
|
)
|
|
|
|
(defmethod eitest-F ((_p E-base1))
|
|
(eieio-test-method-store :PRIMARY 'E-base1)
|
|
(call-next-method))
|
|
|
|
(defmethod eitest-F ((_p E-base2))
|
|
(eieio-test-method-store :PRIMARY 'E-base2)
|
|
(when (next-method-p)
|
|
(call-next-method))))
|
|
|
|
(ert-deftest eieio-test-method-order-list-8 ()
|
|
(let ((eieio-test-method-order-list nil)
|
|
(ans '(
|
|
(:PRIMARY E)
|
|
(:PRIMARY E-base1)
|
|
(:PRIMARY E-base2)
|
|
(:PRIMARY E-base0)
|
|
)))
|
|
(eitest-F (E nil))
|
|
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
|
(eieio-test-match ans)))
|
|
|
|
;;; Jan's methodinvoke order with multiple inheritance and :after methods.
|
|
;;
|
|
(defclass eitest-Ja ()
|
|
())
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete next-method-p)
|
|
(obsolete call-next-method))
|
|
(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots)
|
|
;;(message "+Ja")
|
|
;; FIXME: Using next-method-p in an after-method is invalid!
|
|
(when (next-method-p)
|
|
(call-next-method))
|
|
;;(message "-Ja")
|
|
))
|
|
|
|
(defclass eitest-Jb ()
|
|
())
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete next-method-p)
|
|
(obsolete call-next-method))
|
|
(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots)
|
|
;;(message "+Jb")
|
|
;; FIXME: Using next-method-p in an after-method is invalid!
|
|
(when (next-method-p)
|
|
(call-next-method))
|
|
;;(message "-Jb")
|
|
))
|
|
|
|
(defclass eitest-Jc (eitest-Jb)
|
|
())
|
|
|
|
(defclass eitest-Jd (eitest-Jc eitest-Ja)
|
|
())
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete next-method-p)
|
|
(obsolete call-next-method))
|
|
(defmethod initialize-instance ((_this eitest-Jd) &rest _slots)
|
|
;;(message "+Jd")
|
|
(when (next-method-p)
|
|
(call-next-method))
|
|
;;(message "-Jd")
|
|
))
|
|
|
|
(ert-deftest eieio-test-method-order-list-9 ()
|
|
(should (eitest-Jd)))
|
|
|
|
;;; call-next-method with replacement arguments across a simple class hierarchy.
|
|
;;
|
|
|
|
(defclass CNM-0 ()
|
|
())
|
|
|
|
(defclass CNM-1-1 (CNM-0)
|
|
())
|
|
|
|
(defclass CNM-1-2 (CNM-0)
|
|
())
|
|
|
|
(defclass CNM-2 (CNM-1-1 CNM-1-2)
|
|
())
|
|
|
|
(with-suppressed-warnings ((obsolete defmethod)
|
|
(obsolete defgeneric)
|
|
(obsolete next-method-p)
|
|
(obsolete call-next-method))
|
|
(defmethod CNM-M ((this CNM-0) args)
|
|
(push (cons 'CNM-0 (copy-sequence args))
|
|
eieio-test-call-next-method-arguments)
|
|
(when (next-method-p)
|
|
(call-next-method
|
|
this (cons 'CNM-0 args))))
|
|
|
|
(defmethod CNM-M ((this CNM-1-1) args)
|
|
(push (cons 'CNM-1-1 (copy-sequence args))
|
|
eieio-test-call-next-method-arguments)
|
|
(when (next-method-p)
|
|
(call-next-method
|
|
this (cons 'CNM-1-1 args))))
|
|
|
|
(defmethod CNM-M ((_this CNM-1-2) args)
|
|
(push (cons 'CNM-1-2 (copy-sequence args))
|
|
eieio-test-call-next-method-arguments)
|
|
(when (next-method-p)
|
|
(call-next-method)))
|
|
|
|
(defmethod CNM-M ((this CNM-2) args)
|
|
(push (cons 'CNM-2 (copy-sequence args))
|
|
eieio-test-call-next-method-arguments)
|
|
(when (next-method-p)
|
|
(call-next-method
|
|
this (cons 'CNM-2 args)))))
|
|
|
|
(ert-deftest eieio-test-method-order-list-10 ()
|
|
(let ((eieio-test-call-next-method-arguments nil))
|
|
(CNM-M (CNM-2) '(INIT))
|
|
(should (equal (eieio-test-arguments-for 'CNM-0)
|
|
'(CNM-1-1 CNM-2 INIT)))
|
|
(should (equal (eieio-test-arguments-for 'CNM-1-1)
|
|
'(CNM-2 INIT)))
|
|
(should (equal (eieio-test-arguments-for 'CNM-1-2)
|
|
'(CNM-1-1 CNM-2 INIT)))
|
|
(should (equal (eieio-test-arguments-for 'CNM-2)
|
|
'(INIT)))))
|
|
|
|
;;; Check cl-generic integration.
|
|
|
|
(cl-defgeneric eieio-test--1 (x y))
|
|
|
|
(ert-deftest eieio-test-cl-generic-1 ()
|
|
(cl-defgeneric eieio-test--1 (x y))
|
|
(cl-defmethod eieio-test--1 (x y) (list x y))
|
|
(cl-defmethod eieio-test--1 ((_x CNM-0) y)
|
|
(cons "CNM-0" (cl-call-next-method 7 y)))
|
|
(cl-defmethod eieio-test--1 ((_x CNM-1-1) _y)
|
|
(cons "CNM-1-1" (cl-call-next-method)))
|
|
(cl-defmethod eieio-test--1 ((_x CNM-1-2) _y)
|
|
(cons "CNM-1-2" (cl-call-next-method)))
|
|
(cl-defmethod eieio-test--1 ((_x (subclass CNM-1-2)) _y)
|
|
(cons "subclass CNM-1-2" (cl-call-next-method)))
|
|
(should (equal (eieio-test--1 4 5) '(4 5)))
|
|
(should (equal (eieio-test--1 (make-instance 'CNM-0) 5)
|
|
'("CNM-0" 7 5)))
|
|
(should (equal (eieio-test--1 (make-instance 'CNM-2) 5)
|
|
'("CNM-1-1" "CNM-1-2" "CNM-0" 7 5)))
|
|
(should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6))))
|
|
|
|
;;; eieio-test-methodinvoke.el ends here
|