test/automated/eieio-test-methodinvoke.el

   1 ;;; eieio-testsinvoke.el -- eieio tests for method invocation
   2
   3 ;; Copyright (C) 2005, 2008, 2010, 2013-2015 Free Software Foundation,
   4 ;; Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  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.
  14
  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.
  19
  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/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; Test method invocation order.  From the common lisp reference
  26 ;; manual:
  27 ;;
  28 ;; QUOTE:
  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.
  32 ;;
  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
  42 ;;   method is called.
  43 ;;
  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.
  47 ;;
  48 ;;
  49 ;; Also test behavior of `call-next-method'. From clos.org:
  50 ;;
  51 ;; QUOTE:
  52 ;; When call-next-method is called with no arguments, it passes the
  53 ;; current method's original arguments to the next method.
  54
  55 (require 'eieio)
  56 (require 'ert)
  57
  58 (defvar eieio-test-method-order-list nil
  59   "List of symbols stored during method invocation.")
  60
  61 (defun eieio-test-method-store (&rest args)
  62   "Store current invocation class symbol in the invocation order list."
  63   (push args eieio-test-method-order-list))
  64
  65 (defun eieio-test-match (rightanswer)
  66   "Do a test match."
  67   (if (equal rightanswer eieio-test-method-order-list)
  68       t
  69     (error "eieio-test-methodinvoke.el: Test Failed: %S != %S"
  70            rightanswer eieio-test-method-order-list)))
  71
  72 (defvar eieio-test-call-next-method-arguments nil
  73   "List of passed to methods during execution of `call-next-method'.")
  74
  75 (defun eieio-test-arguments-for (class)
  76   "Returns arguments passed to method of CLASS during `call-next-method'."
  77   (cdr (assoc class eieio-test-call-next-method-arguments)))
  78
  79 (defclass eitest-A () ())
  80 (defclass eitest-AA (eitest-A) ())
  81 (defclass eitest-AAA (eitest-AA) ())
  82 (defclass eitest-B-base1 () ())
  83 (defclass eitest-B-base2 () ())
  84 (defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
  85
  86 (defmethod eitest-F :BEFORE ((p eitest-B-base1))
  87   (eieio-test-method-store :BEFORE 'eitest-B-base1))
  88
  89 (defmethod eitest-F :BEFORE ((p eitest-B-base2))
  90   (eieio-test-method-store :BEFORE 'eitest-B-base2))
  91
  92 (defmethod eitest-F :BEFORE ((p eitest-B))
  93   (eieio-test-method-store :BEFORE 'eitest-B))
  94
  95 (defmethod eitest-F ((p eitest-B))
  96   (eieio-test-method-store :PRIMARY 'eitest-B)
  97   (call-next-method))
  98
  99 (defmethod eitest-F ((p eitest-B-base1))
 100   (eieio-test-method-store :PRIMARY 'eitest-B-base1)
 101   (call-next-method))
 102
 103 (defmethod eitest-F ((p eitest-B-base2))
 104   (eieio-test-method-store :PRIMARY 'eitest-B-base2)
 105   (when (next-method-p)
 106     (call-next-method))
 107   )
 108
 109 (defmethod eitest-F :AFTER ((p eitest-B-base1))
 110   (eieio-test-method-store :AFTER 'eitest-B-base1))
 111
 112 (defmethod eitest-F :AFTER ((p eitest-B-base2))
 113   (eieio-test-method-store :AFTER 'eitest-B-base2))
 114
 115 (defmethod eitest-F :AFTER ((p eitest-B))
 116   (eieio-test-method-store :AFTER 'eitest-B))
 117
 118 (ert-deftest eieio-test-method-order-list-3 ()
 119   (let ((eieio-test-method-order-list nil)
 120         (ans '(
 121                (:BEFORE eitest-B)
 122                (:BEFORE eitest-B-base1)
 123                (:BEFORE eitest-B-base2)
 124
 125                (:PRIMARY eitest-B)
 126                (:PRIMARY eitest-B-base1)
 127                (:PRIMARY eitest-B-base2)
 128
 129                (:AFTER eitest-B-base2)
 130                (:AFTER eitest-B-base1)
 131                (:AFTER eitest-B)
 132                )))
 133     (eitest-F (eitest-B nil))
 134     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 135     (eieio-test-match ans)))
 136
 137 ;;; Test static invocation
 138 ;;
 139 (defmethod eitest-H :STATIC ((class eitest-A))
 140   "No need to do work in here."
 141   'moose)
 142
 143 (ert-deftest eieio-test-method-order-list-4 ()
 144   ;; Both of these situations should succeed.
 145   (should (eitest-H 'eitest-A))
 146   (should (eitest-H (eitest-A nil))))
 147
 148 ;;; Return value from :PRIMARY
 149 ;;
 150 (defmethod eitest-I :BEFORE ((a eitest-A))
 151   (eieio-test-method-store :BEFORE 'eitest-A)
 152   ":before")
 153
 154 (defmethod eitest-I :PRIMARY ((a eitest-A))
 155   (eieio-test-method-store :PRIMARY 'eitest-A)
 156   ":primary")
 157
 158 (defmethod eitest-I :AFTER ((a eitest-A))
 159   (eieio-test-method-store :AFTER 'eitest-A)
 160   ":after")
 161
 162 (ert-deftest eieio-test-method-order-list-5 ()
 163   (let ((eieio-test-method-order-list nil)
 164         (ans  (eitest-I (eitest-A nil))))
 165     (should (string= ans ":primary"))))
 166
 167 ;;; Multiple inheritance and the 'constructor' method.
 168 ;;
 169 ;; Constructor is a static method, so this is really testing
 170 ;; static method invocation and multiple inheritance.
 171 ;;
 172 (defclass C-base1 () ())
 173 (defclass C-base2 () ())
 174 (defclass C (C-base1 C-base2) ())
 175
 176 ;; Just use the obsolete name once, to make sure it also works.
 177 (defmethod constructor :STATIC ((p C-base1) &rest args)
 178   (eieio-test-method-store :STATIC 'C-base1)
 179   (if (next-method-p) (call-next-method))
 180   )
 181
 182 (defmethod make-instance :STATIC ((p C-base2) &rest args)
 183   (eieio-test-method-store :STATIC 'C-base2)
 184   (if (next-method-p) (call-next-method))
 185   )
 186
 187 (cl-defmethod make-instance ((p (subclass C)) &rest args)
 188   (eieio-test-method-store :STATIC 'C)
 189   (call-next-method)
 190   )
 191
 192 (ert-deftest eieio-test-method-order-list-6 ()
 193   (let ((eieio-test-method-order-list nil)
 194         (ans '(
 195                (:STATIC C)
 196                (:STATIC C-base1)
 197                (:STATIC C-base2)
 198                )))
 199     (C nil)
 200     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 201     (eieio-test-match ans)))
 202
 203 ;;; Diamond Test
 204 ;;
 205 ;; For a diamond shaped inheritance structure, (call-next-method) can break.
 206 ;; As such, there are two possible orders.
 207
 208 (defclass D-base0 () () :method-invocation-order :depth-first)
 209 (defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
 210 (defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
 211 (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
 212
 213 (defmethod eitest-F ((p D))
 214   "D"
 215   (eieio-test-method-store :PRIMARY 'D)
 216   (call-next-method))
 217
 218 (defmethod eitest-F ((p D-base0))
 219   "D-base0"
 220   (eieio-test-method-store :PRIMARY 'D-base0)
 221   ;; This should have no next
 222   ;; (when (next-method-p) (call-next-method))
 223   )
 224
 225 (defmethod eitest-F ((p D-base1))
 226   "D-base1"
 227   (eieio-test-method-store :PRIMARY 'D-base1)
 228   (call-next-method))
 229
 230 (defmethod eitest-F ((p D-base2))
 231   "D-base2"
 232   (eieio-test-method-store :PRIMARY 'D-base2)
 233   (when (next-method-p)
 234     (call-next-method))
 235   )
 236
 237 (ert-deftest eieio-test-method-order-list-7 ()
 238   (let ((eieio-test-method-order-list nil)
 239         (ans '(
 240                (:PRIMARY D)
 241                (:PRIMARY D-base1)
 242                ;; (:PRIMARY D-base2)
 243                (:PRIMARY D-base0)
 244                )))
 245     (eitest-F (D nil))
 246     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 247     (eieio-test-match ans)))
 248
 249 ;;; Other invocation order
 250
 251 (defclass E-base0 () () :method-invocation-order :breadth-first)
 252 (defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
 253 (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
 254 (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
 255
 256 (defmethod eitest-F ((p E))
 257   (eieio-test-method-store :PRIMARY 'E)
 258   (call-next-method))
 259
 260 (defmethod eitest-F ((p E-base0))
 261   (eieio-test-method-store :PRIMARY 'E-base0)
 262   ;; This should have no next
 263   ;; (when (next-method-p) (call-next-method))
 264   )
 265
 266 (defmethod eitest-F ((p E-base1))
 267   (eieio-test-method-store :PRIMARY 'E-base1)
 268   (call-next-method))
 269
 270 (defmethod eitest-F ((p E-base2))
 271   (eieio-test-method-store :PRIMARY 'E-base2)
 272   (when (next-method-p)
 273     (call-next-method))
 274   )
 275
 276 (ert-deftest eieio-test-method-order-list-8 ()
 277   (let ((eieio-test-method-order-list nil)
 278         (ans '(
 279                (:PRIMARY E)
 280                (:PRIMARY E-base1)
 281                (:PRIMARY E-base2)
 282                (:PRIMARY E-base0)
 283                )))
 284     (eitest-F (E nil))
 285     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 286     (eieio-test-match ans)))
 287
 288 ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
 289 ;;
 290 (defclass eitest-Ja ()
 291   ())
 292
 293 (defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
 294   ;(message "+Ja")
 295   ;; FIXME: Using next-method-p in an after-method is invalid!
 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   ;; FIXME: Using next-method-p in an after-method is invalid!
 307   (when (next-method-p)
 308     (call-next-method))
 309   ;(message "-Jb")
 310   )
 311
 312 (defclass eitest-Jc (eitest-Jb)
 313   ())
 314
 315 (defclass eitest-Jd (eitest-Jc eitest-Ja)
 316   ())
 317
 318 (defmethod initialize-instance ((this eitest-Jd) &rest slots)
 319   ;(message "+Jd")
 320   (when (next-method-p)
 321     (call-next-method))
 322   ;(message "-Jd")
 323   )
 324
 325 (ert-deftest eieio-test-method-order-list-9 ()
 326   (should (eitest-Jd "test")))
 327
 328 ;;; call-next-method with replacement arguments across a simple class hierarchy.
 329 ;;
 330
 331 (defclass CNM-0 ()
 332   ())
 333
 334 (defclass CNM-1-1 (CNM-0)
 335   ())
 336
 337 (defclass CNM-1-2 (CNM-0)
 338   ())
 339
 340 (defclass CNM-2 (CNM-1-1 CNM-1-2)
 341   ())
 342
 343 (defmethod CNM-M ((this CNM-0) args)
 344   (push (cons 'CNM-0 (copy-sequence args))
 345         eieio-test-call-next-method-arguments)
 346   (when (next-method-p)
 347     (call-next-method
 348      this (cons 'CNM-0 args))))
 349
 350 (defmethod CNM-M ((this CNM-1-1) args)
 351   (push (cons 'CNM-1-1 (copy-sequence args))
 352         eieio-test-call-next-method-arguments)
 353   (when (next-method-p)
 354     (call-next-method
 355      this (cons 'CNM-1-1 args))))
 356
 357 (defmethod CNM-M ((this CNM-1-2) args)
 358   (push (cons 'CNM-1-2 (copy-sequence args))
 359         eieio-test-call-next-method-arguments)
 360   (when (next-method-p)
 361     (call-next-method)))
 362
 363 (defmethod CNM-M ((this CNM-2) args)
 364   (push (cons 'CNM-2 (copy-sequence args))
 365         eieio-test-call-next-method-arguments)
 366   (when (next-method-p)
 367     (call-next-method
 368      this (cons 'CNM-2 args))))
 369
 370 (ert-deftest eieio-test-method-order-list-10 ()
 371   (let ((eieio-test-call-next-method-arguments nil))
 372     (CNM-M (CNM-2 "") '(INIT))
 373     (should (equal (eieio-test-arguments-for 'CNM-0)
 374                    '(CNM-1-1 CNM-2 INIT)))
 375     (should (equal (eieio-test-arguments-for 'CNM-1-1)
 376                    '(CNM-2 INIT)))
 377     (should (equal (eieio-test-arguments-for 'CNM-1-2)
 378                    '(CNM-1-1 CNM-2 INIT)))
 379     (should (equal (eieio-test-arguments-for 'CNM-2)
 380                    '(INIT)))))
 381
 382 ;;; Check cl-generic integration.
 383
 384 (cl-defgeneric eieio-test--1 (x y))
 385
 386 (ert-deftest eieio-test-cl-generic-1 ()
 387   (cl-defgeneric eieio-test--1 (x y))
 388   (cl-defmethod eieio-test--1 (x y) (list x y))
 389   (cl-defmethod eieio-test--1 ((_x CNM-0) y)
 390     (cons "CNM-0" (cl-call-next-method 7 y)))
 391   (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y)
 392     (cons "CNM-1-1" (cl-call-next-method)))
 393   (cl-defmethod eieio-test--1 ((_x CNM-1-2) _y)
 394     (cons "CNM-1-2" (cl-call-next-method)))
 395   (cl-defmethod eieio-test--1 ((_x (subclass CNM-1-2)) _y)
 396     (cons "subclass CNM-1-2" (cl-call-next-method)))
 397   (should (equal (eieio-test--1 4 5) '(4 5)))
 398   (should (equal (eieio-test--1 (make-instance 'CNM-0) 5)
 399                  '("CNM-0" 7 5)))
 400   (should (equal (eieio-test--1 (make-instance 'CNM-2) 5)
 401                  '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5)))
 402   (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6))))