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-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Test method invocation order.  From the common lisp reference
  25 ;; manual:
  26 ;;
  27 ;; QUOTE:
  28 ;; - All the :before methods are called, in most-specific-first
  29 ;;   order.  Their values are ignored.  An error is signaled if
  30 ;;   call-next-method is used in a :before method.
  31 ;;
  32 ;; - The most specific primary method is called. Inside the body of a
  33 ;;   primary method, call-next-method may be used to call the next
  34 ;;   most specific primary method. When that method returns, the
  35 ;;   previous primary method can execute more code, perhaps based on
  36 ;;   the returned value or values. The generic function no-next-method
  37 ;;   is invoked if call-next-method is used and there are no more
  38 ;;   applicable primary methods. The function next-method-p may be
  39 ;;   used to determine whether a next method exists. If
  40 ;;   call-next-method is not used, only the most specific primary
  41 ;;   method is called.
  42 ;;
  43 ;; - All the :after methods are called, in most-specific-last order.
  44 ;;   Their values are ignored.  An error is signaled if
  45 ;;   call-next-method is used in a :after method.
  46 ;;
  47 ;;
  48 ;; Also test behavior of `call-next-method'. From clos.org:
  49 ;;
  50 ;; QUOTE:
  51 ;; When call-next-method is called with no arguments, it passes the
  52 ;; current method's original arguments to the next method.
  53
  54 (require 'eieio)
  55 (require 'ert)
  56
  57 (defvar eieio-test-method-order-list nil
  58   "List of symbols stored during method invocation.")
  59
  60 (defun eieio-test-method-store ()
  61   "Store current invocation class symbol in the invocation order list."
  62   (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
  63                        (or eieio-generic-call-key 0)))
  64          (c (list eieio-generic-call-methodname keysym (eieio--scoped-class))))
  65     (setq eieio-test-method-order-list
  66           (cons c eieio-test-method-order-list))))
  67
  68 (defun eieio-test-match (rightanswer)
  69   "Do a test match."
  70   (if (equal rightanswer eieio-test-method-order-list)
  71       t
  72     (error "eieio-test-methodinvoke.el: Test Failed!")))
  73
  74 (defvar eieio-test-call-next-method-arguments nil
  75   "List of passed to methods during execution of `call-next-method'.")
  76
  77 (defun eieio-test-arguments-for (class)
  78   "Returns arguments passed to method of CLASS during `call-next-method'."
  79   (cdr (assoc class eieio-test-call-next-method-arguments)))
  80
  81 (defclass eitest-A () ())
  82 (defclass eitest-AA (eitest-A) ())
  83 (defclass eitest-AAA (eitest-AA) ())
  84 (defclass eitest-B-base1 () ())
  85 (defclass eitest-B-base2 () ())
  86 (defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
  87
  88 (defmethod eitest-F :BEFORE ((p eitest-B-base1))
  89   (eieio-test-method-store))
  90
  91 (defmethod eitest-F :BEFORE ((p eitest-B-base2))
  92   (eieio-test-method-store))
  93
  94 (defmethod eitest-F :BEFORE ((p eitest-B))
  95   (eieio-test-method-store))
  96
  97 (defmethod eitest-F ((p eitest-B))
  98   (eieio-test-method-store)
  99   (call-next-method))
 100
 101 (defmethod eitest-F ((p eitest-B-base1))
 102   (eieio-test-method-store)
 103   (call-next-method))
 104
 105 (defmethod eitest-F ((p eitest-B-base2))
 106   (eieio-test-method-store)
 107   (when (next-method-p)
 108     (call-next-method))
 109   )
 110
 111 (defmethod eitest-F :AFTER ((p eitest-B-base1))
 112   (eieio-test-method-store))
 113
 114 (defmethod eitest-F :AFTER ((p eitest-B-base2))
 115   (eieio-test-method-store))
 116
 117 (defmethod eitest-F :AFTER ((p eitest-B))
 118   (eieio-test-method-store))
 119
 120 (ert-deftest eieio-test-method-order-list-3 ()
 121   (let ((eieio-test-method-order-list nil)
 122         (ans '(
 123                (eitest-F :BEFORE eitest-B)
 124                (eitest-F :BEFORE eitest-B-base1)
 125                (eitest-F :BEFORE eitest-B-base2)
 126
 127                (eitest-F :PRIMARY eitest-B)
 128                (eitest-F :PRIMARY eitest-B-base1)
 129                (eitest-F :PRIMARY eitest-B-base2)
 130
 131                (eitest-F :AFTER eitest-B-base2)
 132                (eitest-F :AFTER eitest-B-base1)
 133                (eitest-F :AFTER eitest-B)
 134                )))
 135     (eitest-F (eitest-B nil))
 136     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 137     (eieio-test-match ans)))
 138
 139 ;;; Test static invocation
 140 ;;
 141 (defmethod eitest-H :STATIC ((class eitest-A))
 142   "No need to do work in here."
 143   'moose)
 144
 145 (ert-deftest eieio-test-method-order-list-4 ()
 146   ;; Both of these situations should succeed.
 147   (should (eitest-H eitest-A))
 148   (should (eitest-H (eitest-A nil))))
 149
 150 ;;; Return value from :PRIMARY
 151 ;;
 152 (defmethod eitest-I :BEFORE ((a eitest-A))
 153   (eieio-test-method-store)
 154   ":before")
 155
 156 (defmethod eitest-I :PRIMARY ((a eitest-A))
 157   (eieio-test-method-store)
 158   ":primary")
 159
 160 (defmethod eitest-I :AFTER ((a eitest-A))
 161   (eieio-test-method-store)
 162   ":after")
 163
 164 (ert-deftest eieio-test-method-order-list-5 ()
 165   (let ((eieio-test-method-order-list nil)
 166         (ans  (eitest-I (eitest-A nil))))
 167     (should (string= ans ":primary"))))
 168
 169 ;;; Multiple inheritance and the 'constructor' method.
 170 ;;
 171 ;; Constructor is a static method, so this is really testing
 172 ;; static method invocation and multiple inheritance.
 173 ;;
 174 (defclass C-base1 () ())
 175 (defclass C-base2 () ())
 176 (defclass C (C-base1 C-base2) ())
 177
 178 (defmethod constructor :STATIC ((p C-base1) &rest args)
 179   (eieio-test-method-store)
 180   (if (next-method-p) (call-next-method))
 181   )
 182
 183 (defmethod constructor :STATIC ((p C-base2) &rest args)
 184   (eieio-test-method-store)
 185   (if (next-method-p) (call-next-method))
 186   )
 187
 188 (defmethod constructor :STATIC ((p C) &rest args)
 189   (eieio-test-method-store)
 190   (call-next-method)
 191   )
 192
 193 (ert-deftest eieio-test-method-order-list-6 ()
 194   (let ((eieio-test-method-order-list nil)
 195         (ans '(
 196                (constructor :STATIC C)
 197                (constructor :STATIC C-base1)
 198                (constructor :STATIC C-base2)
 199                )))
 200     (C nil)
 201     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 202     (eieio-test-match ans)))
 203
 204 ;;; Diamond Test
 205 ;;
 206 ;; For a diamond shaped inheritance structure, (call-next-method) can break.
 207 ;; As such, there are two possible orders.
 208
 209 (defclass D-base0 () () :method-invocation-order :depth-first)
 210 (defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
 211 (defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
 212 (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
 213
 214 (defmethod eitest-F ((p D))
 215   "D"
 216   (eieio-test-method-store)
 217   (call-next-method))
 218
 219 (defmethod eitest-F ((p D-base0))
 220   "D-base0"
 221   (eieio-test-method-store)
 222   ;; This should have no next
 223   ;; (when (next-method-p) (call-next-method))
 224   )
 225
 226 (defmethod eitest-F ((p D-base1))
 227   "D-base1"
 228   (eieio-test-method-store)
 229   (call-next-method))
 230
 231 (defmethod eitest-F ((p D-base2))
 232   "D-base2"
 233   (eieio-test-method-store)
 234   (when (next-method-p)
 235     (call-next-method))
 236   )
 237
 238 (ert-deftest eieio-test-method-order-list-7 ()
 239   (let ((eieio-test-method-order-list nil)
 240         (ans '(
 241                (eitest-F :PRIMARY D)
 242                (eitest-F :PRIMARY D-base1)
 243                ;; (eitest-F :PRIMARY D-base2)
 244                (eitest-F :PRIMARY D-base0)
 245                )))
 246     (eitest-F (D nil))
 247     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 248     (eieio-test-match ans)))
 249
 250 ;;; Other invocation order
 251
 252 (defclass E-base0 () () :method-invocation-order :breadth-first)
 253 (defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
 254 (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
 255 (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
 256
 257 (defmethod eitest-F ((p E))
 258   (eieio-test-method-store)
 259   (call-next-method))
 260
 261 (defmethod eitest-F ((p E-base0))
 262   (eieio-test-method-store)
 263   ;; This should have no next
 264   ;; (when (next-method-p) (call-next-method))
 265   )
 266
 267 (defmethod eitest-F ((p E-base1))
 268   (eieio-test-method-store)
 269   (call-next-method))
 270
 271 (defmethod eitest-F ((p E-base2))
 272   (eieio-test-method-store)
 273   (when (next-method-p)
 274     (call-next-method))
 275   )
 276
 277 (ert-deftest eieio-test-method-order-list-8 ()
 278   (let ((eieio-test-method-order-list nil)
 279         (ans '(
 280                (eitest-F :PRIMARY E)
 281                (eitest-F :PRIMARY E-base1)
 282                (eitest-F :PRIMARY E-base2)
 283                (eitest-F :PRIMARY E-base0)
 284                )))
 285     (eitest-F (E nil))
 286     (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 287     (eieio-test-match ans)))
 288
 289 ;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
 290 ;;
 291 (defclass eitest-Ja ()
 292   ())
 293
 294 (defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
 295   ;(message "+Ja")
 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   (when (next-method-p)
 307     (call-next-method))
 308   ;(message "-Jb")
 309   )
 310
 311 (defclass eitest-Jc (eitest-Jb)
 312   ())
 313
 314 (defclass eitest-Jd (eitest-Jc eitest-Ja)
 315   ())
 316
 317 (defmethod initialize-instance ((this eitest-Jd) &rest slots)
 318   ;(message "+Jd")
 319   (when (next-method-p)
 320     (call-next-method))
 321   ;(message "-Jd")
 322   )
 323
 324 (ert-deftest eieio-test-method-order-list-9 ()
 325   (should (eitest-Jd "test")))
 326
 327 ;;; call-next-method with replacement arguments across a simple class hierarchy.
 328 ;;
 329
 330 (defclass CNM-0 ()
 331   ())
 332
 333 (defclass CNM-1-1 (CNM-0)
 334   ())
 335
 336 (defclass CNM-1-2 (CNM-0)
 337   ())
 338
 339 (defclass CNM-2 (CNM-1-1 CNM-1-2)
 340   ())
 341
 342 (defmethod CNM-M ((this CNM-0) args)
 343   (push (cons 'CNM-0 (copy-sequence args))
 344         eieio-test-call-next-method-arguments)
 345   (when (next-method-p)
 346     (call-next-method
 347      this (cons 'CNM-0 args))))
 348
 349 (defmethod CNM-M ((this CNM-1-1) args)
 350   (push (cons 'CNM-1-1 (copy-sequence args))
 351         eieio-test-call-next-method-arguments)
 352   (when (next-method-p)
 353     (call-next-method
 354      this (cons 'CNM-1-1 args))))
 355
 356 (defmethod CNM-M ((this CNM-1-2) args)
 357   (push (cons 'CNM-1-2 (copy-sequence args))
 358         eieio-test-call-next-method-arguments)
 359   (when (next-method-p)
 360     (call-next-method)))
 361
 362 (defmethod CNM-M ((this CNM-2) args)
 363   (push (cons 'CNM-2 (copy-sequence args))
 364         eieio-test-call-next-method-arguments)
 365   (when (next-method-p)
 366     (call-next-method
 367      this (cons 'CNM-2 args))))
 368
 369 (ert-deftest eieio-test-method-order-list-10 ()
 370   (let ((eieio-test-call-next-method-arguments nil))
 371     (CNM-M (CNM-2 "") '(INIT))
 372     (should (equal (eieio-test-arguments-for 'CNM-0)
 373                    '(CNM-1-1 CNM-2 INIT)))
 374     (should (equal (eieio-test-arguments-for 'CNM-1-1)
 375                    '(CNM-2 INIT)))
 376     (should (equal (eieio-test-arguments-for 'CNM-1-2)
 377                    '(CNM-1-1 CNM-2 INIT)))
 378     (should (equal (eieio-test-arguments-for 'CNM-2)
 379                    '(INIT)))))