code.delx.au - gnu-emacs/blob - 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 ()
  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)))
  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: %S != %S"
  74            rightanswer eieio-test-method-order-list)))
  75
  76 (defvar eieio-test-call-next-method-arguments nil
  77   "List of passed to methods during execution of `call-next-method'.")
  78
  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)))
  82
  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) ())
  89
  90 (defmethod eitest-F :BEFORE ((p eitest-B-base1))
  91   (eieio-test-method-store))
  92
  93 (defmethod eitest-F :BEFORE ((p eitest-B-base2))
  94   (eieio-test-method-store))
  95
  96 (defmethod eitest-F :BEFORE ((p eitest-B))
  97   (eieio-test-method-store))
  98
  99 (defmethod eitest-F ((p eitest-B))
 100   (eieio-test-method-store)
 101   (call-next-method))
 102
 103 (defmethod eitest-F ((p eitest-B-base1))
 104   (eieio-test-method-store)
 105   (call-next-method))
 106
 107 (defmethod eitest-F ((p eitest-B-base2))
 108   (eieio-test-method-store)
 109   (when (next-method-p)
 110     (call-next-method))
 111   )
 112
 113 (defmethod eitest-F :AFTER ((p eitest-B-base1))
 114   (eieio-test-method-store))
 115
 116 (defmethod eitest-F :AFTER ((p eitest-B-base2))
 117   (eieio-test-method-store))
 118
 119 (defmethod eitest-F :AFTER ((p eitest-B))
 120   (eieio-test-method-store))
 121
 122 (ert-deftest eieio-test-method-order-list-3 ()
 123   (let ((eieio-test-method-order-list nil)
 124         (ans '(
 125                (:BEFORE eitest-B)
 126                (:BEFORE eitest-B-base1)
 127                (:BEFORE eitest-B-base2)
 128
 129                (:PRIMARY eitest-B)
 130                (:PRIMARY eitest-B-base1)
 131                (:PRIMARY eitest-B-base2)
 132
 133                (:AFTER eitest-B-base2)
 134                (:AFTER eitest-B-base1)
 135                (:AFTER eitest-B)
 136                )))
 137     (eitest-F (eitest-B nil))
 138     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 139     (eieio-test-match ans)))
 140
 141 ;;; Test static invocation
 142 ;;
 143 (defmethod eitest-H :STATIC ((class eitest-A))
 144   "No need to do work in here."
 145   'moose)
 146
 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))))
 151
 152 ;;; Return value from :PRIMARY
 153 ;;
 154 (defmethod eitest-I :BEFORE ((a eitest-A))
 155   (eieio-test-method-store)
 156   ":before")
 157
 158 (defmethod eitest-I :PRIMARY ((a eitest-A))
 159   (eieio-test-method-store)
 160   ":primary")
 161
 162 (defmethod eitest-I :AFTER ((a eitest-A))
 163   (eieio-test-method-store)
 164   ":after")
 165
 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"))))
 170
 171 ;;; Multiple inheritance and the 'constructor' method.
 172 ;;
 173 ;; Constructor is a static method, so this is really testing
 174 ;; static method invocation and multiple inheritance.
 175 ;;
 176 (defclass C-base1 () ())
 177 (defclass C-base2 () ())
 178 (defclass C (C-base1 C-base2) ())
 179
 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))
 184   )
 185
 186 (defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
 187   (eieio-test-method-store)
 188   (if (next-method-p) (call-next-method))
 189   )
 190
 191 (defmethod eieio-constructor :STATIC ((p C) &rest args)
 192   (eieio-test-method-store)
 193   (call-next-method)
 194   )
 195
 196 (ert-deftest eieio-test-method-order-list-6 ()
 197   (let ((eieio-test-method-order-list nil)
 198         (ans '(
 199                (:STATIC C)
 200                (:STATIC C-base1)
 201                (:STATIC C-base2)
 202                )))
 203     (C nil)
 204     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 205     (eieio-test-match ans)))
 206
 207 ;;; Diamond Test
 208 ;;
 209 ;; For a diamond shaped inheritance structure, (call-next-method) can break.
 210 ;; As such, there are two possible orders.
 211
 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)
 216
 217 (defmethod eitest-F ((p D))
 218   "D"
 219   (eieio-test-method-store)
 220   (call-next-method))
 221
 222 (defmethod eitest-F ((p D-base0))
 223   "D-base0"
 224   (eieio-test-method-store)
 225   ;; This should have no next
 226   ;; (when (next-method-p) (call-next-method))
 227   )
 228
 229 (defmethod eitest-F ((p D-base1))
 230   "D-base1"
 231   (eieio-test-method-store)
 232   (call-next-method))
 233
 234 (defmethod eitest-F ((p D-base2))
 235   "D-base2"
 236   (eieio-test-method-store)
 237   (when (next-method-p)
 238     (call-next-method))
 239   )
 240
 241 (ert-deftest eieio-test-method-order-list-7 ()
 242   (let ((eieio-test-method-order-list nil)
 243         (ans '(
 244                (:PRIMARY D)
 245                (:PRIMARY D-base1)
 246                ;; (:PRIMARY D-base2)
 247                (:PRIMARY D-base0)
 248                )))
 249     (eitest-F (D nil))
 250     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 251     (eieio-test-match ans)))
 252
 253 ;;; Other invocation order
 254
 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)
 259
 260 (defmethod eitest-F ((p E))
 261   (eieio-test-method-store)
 262   (call-next-method))
 263
 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))
 268   )
 269
 270 (defmethod eitest-F ((p E-base1))
 271   (eieio-test-method-store)
 272   (call-next-method))
 273
 274 (defmethod eitest-F ((p E-base2))
 275   (eieio-test-method-store)
 276   (when (next-method-p)
 277     (call-next-method))
 278   )
 279
 280 (ert-deftest eieio-test-method-order-list-8 ()
 281   (let ((eieio-test-method-order-list nil)
 282         (ans '(
 283                (:PRIMARY E)
 284                (:PRIMARY E-base1)
 285                (:PRIMARY E-base2)
 286                (:PRIMARY E-base0)
 287                )))
 288     (eitest-F (E nil))
 289     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 290     (eieio-test-match ans)))
 291
 292 ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
 293 ;;
 294 (defclass eitest-Ja ()
 295   ())
 296
 297 (defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
 298   ;(message "+Ja")
 299   (when (next-method-p)
 300     (call-next-method))
 301   ;(message "-Ja")
 302   )
 303
 304 (defclass eitest-Jb ()
 305   ())
 306
 307 (defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
 308   ;(message "+Jb")
 309   (when (next-method-p)
 310     (call-next-method))
 311   ;(message "-Jb")
 312   )
 313
 314 (defclass eitest-Jc (eitest-Jb)
 315   ())
 316
 317 (defclass eitest-Jd (eitest-Jc eitest-Ja)
 318   ())
 319
 320 (defmethod initialize-instance ((this eitest-Jd) &rest slots)
 321   ;(message "+Jd")
 322   (when (next-method-p)
 323     (call-next-method))
 324   ;(message "-Jd")
 325   )
 326
 327 (ert-deftest eieio-test-method-order-list-9 ()
 328   (should (eitest-Jd "test")))
 329
 330 ;;; call-next-method with replacement arguments across a simple class hierarchy.
 331 ;;
 332
 333 (defclass CNM-0 ()
 334   ())
 335
 336 (defclass CNM-1-1 (CNM-0)
 337   ())
 338
 339 (defclass CNM-1-2 (CNM-0)
 340   ())
 341
 342 (defclass CNM-2 (CNM-1-1 CNM-1-2)
 343   ())
 344
 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)
 349     (call-next-method
 350      this (cons 'CNM-0 args))))
 351
 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)
 356     (call-next-method
 357      this (cons 'CNM-1-1 args))))
 358
 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)
 363     (call-next-method)))
 364
 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)
 369     (call-next-method
 370      this (cons 'CNM-2 args))))
 371
 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)
 378                    '(CNM-2 INIT)))
 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)
 382                    '(INIT)))))