test/automated/eieio-test-methodinvoke.el

   1 ;;; eieio-testsinvoke.el -- eieio tests for method invocation
   2
   3 ;; Copyright (C) 2005, 2008, 2010, 2013-2014 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 ()
  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          (c (list eieio-generic-call-methodname keysym (eieio--scoped-class))))
  66     (setq eieio-test-method-order-list
  67           (cons c eieio-test-method-order-list))))
  68
  69 (defun eieio-test-match (rightanswer)
  70   "Do a test match."
  71   (if (equal rightanswer eieio-test-method-order-list)
  72       t
  73     (error "eieio-test-methodinvoke.el: Test Failed!")))
  74
  75 (defvar eieio-test-call-next-method-arguments nil
  76   "List of passed to methods during execution of `call-next-method'.")
  77
  78 (defun eieio-test-arguments-for (class)
  79   "Returns arguments passed to method of CLASS during `call-next-method'."
  80   (cdr (assoc class eieio-test-call-next-method-arguments)))
  81
  82 (defclass eitest-A () ())
  83 (defclass eitest-AA (eitest-A) ())
  84 (defclass eitest-AAA (eitest-AA) ())
  85 (defclass eitest-B-base1 () ())
  86 (defclass eitest-B-base2 () ())
  87 (defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
  88
  89 (defmethod eitest-F :BEFORE ((p eitest-B-base1))
  90   (eieio-test-method-store))
  91
  92 (defmethod eitest-F :BEFORE ((p eitest-B-base2))
  93   (eieio-test-method-store))
  94
  95 (defmethod eitest-F :BEFORE ((p eitest-B))
  96   (eieio-test-method-store))
  97
  98 (defmethod eitest-F ((p eitest-B))
  99   (eieio-test-method-store)
 100   (call-next-method))
 101
 102 (defmethod eitest-F ((p eitest-B-base1))
 103   (eieio-test-method-store)
 104   (call-next-method))
 105
 106 (defmethod eitest-F ((p eitest-B-base2))
 107   (eieio-test-method-store)
 108   (when (next-method-p)
 109     (call-next-method))
 110   )
 111
 112 (defmethod eitest-F :AFTER ((p eitest-B-base1))
 113   (eieio-test-method-store))
 114
 115 (defmethod eitest-F :AFTER ((p eitest-B-base2))
 116   (eieio-test-method-store))
 117
 118 (defmethod eitest-F :AFTER ((p eitest-B))
 119   (eieio-test-method-store))
 120
 121 (ert-deftest eieio-test-method-order-list-3 ()
 122   (let ((eieio-test-method-order-list nil)
 123         (ans '(
 124                (eitest-F :BEFORE eitest-B)
 125                (eitest-F :BEFORE eitest-B-base1)
 126                (eitest-F :BEFORE eitest-B-base2)
 127
 128                (eitest-F :PRIMARY eitest-B)
 129                (eitest-F :PRIMARY eitest-B-base1)
 130                (eitest-F :PRIMARY eitest-B-base2)
 131
 132                (eitest-F :AFTER eitest-B-base2)
 133                (eitest-F :AFTER eitest-B-base1)
 134                (eitest-F :AFTER eitest-B)
 135                )))
 136     (eitest-F (eitest-B nil))
 137     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 138     (eieio-test-match ans)))
 139
 140 ;;; Test static invocation
 141 ;;
 142 (defmethod eitest-H :STATIC ((class eitest-A))
 143   "No need to do work in here."
 144   'moose)
 145
 146 (ert-deftest eieio-test-method-order-list-4 ()
 147   ;; Both of these situations should succeed.
 148   (should (eitest-H eitest-A))
 149   (should (eitest-H (eitest-A nil))))
 150
 151 ;;; Return value from :PRIMARY
 152 ;;
 153 (defmethod eitest-I :BEFORE ((a eitest-A))
 154   (eieio-test-method-store)
 155   ":before")
 156
 157 (defmethod eitest-I :PRIMARY ((a eitest-A))
 158   (eieio-test-method-store)
 159   ":primary")
 160
 161 (defmethod eitest-I :AFTER ((a eitest-A))
 162   (eieio-test-method-store)
 163   ":after")
 164
 165 (ert-deftest eieio-test-method-order-list-5 ()
 166   (let ((eieio-test-method-order-list nil)
 167         (ans  (eitest-I (eitest-A nil))))
 168     (should (string= ans ":primary"))))
 169
 170 ;;; Multiple inheritance and the 'constructor' method.
 171 ;;
 172 ;; Constructor is a static method, so this is really testing
 173 ;; static method invocation and multiple inheritance.
 174 ;;
 175 (defclass C-base1 () ())
 176 (defclass C-base2 () ())
 177 (defclass C (C-base1 C-base2) ())
 178
 179 (defmethod constructor :STATIC ((p C-base1) &rest args)
 180   (eieio-test-method-store)
 181   (if (next-method-p) (call-next-method))
 182   )
 183
 184 (defmethod constructor :STATIC ((p C-base2) &rest args)
 185   (eieio-test-method-store)
 186   (if (next-method-p) (call-next-method))
 187   )
 188
 189 (defmethod constructor :STATIC ((p C) &rest args)
 190   (eieio-test-method-store)
 191   (call-next-method)
 192   )
 193
 194 (ert-deftest eieio-test-method-order-list-6 ()
 195   (let ((eieio-test-method-order-list nil)
 196         (ans '(
 197                (constructor :STATIC C)
 198                (constructor :STATIC C-base1)
 199                (constructor :STATIC C-base2)
 200                )))
 201     (C nil)
 202     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 203     (eieio-test-match ans)))
 204
 205 ;;; Diamond Test
 206 ;;
 207 ;; For a diamond shaped inheritance structure, (call-next-method) can break.
 208 ;; As such, there are two possible orders.
 209
 210 (defclass D-base0 () () :method-invocation-order :depth-first)
 211 (defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
 212 (defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
 213 (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
 214
 215 (defmethod eitest-F ((p D))
 216   "D"
 217   (eieio-test-method-store)
 218   (call-next-method))
 219
 220 (defmethod eitest-F ((p D-base0))
 221   "D-base0"
 222   (eieio-test-method-store)
 223   ;; This should have no next
 224   ;; (when (next-method-p) (call-next-method))
 225   )
 226
 227 (defmethod eitest-F ((p D-base1))
 228   "D-base1"
 229   (eieio-test-method-store)
 230   (call-next-method))
 231
 232 (defmethod eitest-F ((p D-base2))
 233   "D-base2"
 234   (eieio-test-method-store)
 235   (when (next-method-p)
 236     (call-next-method))
 237   )
 238
 239 (ert-deftest eieio-test-method-order-list-7 ()
 240   (let ((eieio-test-method-order-list nil)
 241         (ans '(
 242                (eitest-F :PRIMARY D)
 243                (eitest-F :PRIMARY D-base1)
 244                ;; (eitest-F :PRIMARY D-base2)
 245                (eitest-F :PRIMARY D-base0)
 246                )))
 247     (eitest-F (D nil))
 248     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 249     (eieio-test-match ans)))
 250
 251 ;;; Other invocation order
 252
 253 (defclass E-base0 () () :method-invocation-order :breadth-first)
 254 (defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
 255 (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
 256 (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
 257
 258 (defmethod eitest-F ((p E))
 259   (eieio-test-method-store)
 260   (call-next-method))
 261
 262 (defmethod eitest-F ((p E-base0))
 263   (eieio-test-method-store)
 264   ;; This should have no next
 265   ;; (when (next-method-p) (call-next-method))
 266   )
 267
 268 (defmethod eitest-F ((p E-base1))
 269   (eieio-test-method-store)
 270   (call-next-method))
 271
 272 (defmethod eitest-F ((p E-base2))
 273   (eieio-test-method-store)
 274   (when (next-method-p)
 275     (call-next-method))
 276   )
 277
 278 (ert-deftest eieio-test-method-order-list-8 ()
 279   (let ((eieio-test-method-order-list nil)
 280         (ans '(
 281                (eitest-F :PRIMARY E)
 282                (eitest-F :PRIMARY E-base1)
 283                (eitest-F :PRIMARY E-base2)
 284                (eitest-F :PRIMARY E-base0)
 285                )))
 286     (eitest-F (E nil))
 287     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 288     (eieio-test-match ans)))
 289
 290 ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
 291 ;;
 292 (defclass eitest-Ja ()
 293   ())
 294
 295 (defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
 296   ;(message "+Ja")
 297   (when (next-method-p)
 298     (call-next-method))
 299   ;(message "-Ja")
 300   )
 301
 302 (defclass eitest-Jb ()
 303   ())
 304
 305 (defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
 306   ;(message "+Jb")
 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)))))