cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/eieio-test-methodinvoke.el

   1 ;;; eieio-testsinvoke.el -- eieio tests for method invokation
   2
   3 ;;;
   4 ;; Copyright (C) 2005 Eric M. Ludlam
   5 ;;
   6 ;; Author: <zappo@gnu.org>
   7 ;; RCS: $Id: eieio-test-methodinvoke.el,v 1.1 2007-11-26 15:01:05 michaels Exp $
   8 ;; Keywords: oop, lisp, tools
   9 ;;
  10 ;; This program 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 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;; Please send bug reports, etc. to zappo@gnu.org
  26 ;;
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; Test method invocation order.  From the common lisp reference
  31 ;; manual:
  32 ;;
  33 ;; QUOTE:
  34 ;; - All the :before methods are called, in most-specific-first
  35 ;;   order.  Their values are ignored.  An error is signaled if
  36 ;;   call-next-method is used in a :before method.
  37 ;;
  38 ;; - The most specific primary method is called. Inside the body of a
  39 ;;   primary method, call-next-method may be used to call the next
  40 ;;   most specific primary method. When that method returns, the
  41 ;;   previous primary method can execute more code, perhaps based on
  42 ;;   the returned value or values. The generic function no-next-method
  43 ;;   is invoked if call-next-method is used and there are no more
  44 ;;   applicable primary methods. The function next-method-p may be
  45 ;;   used to determine whether a next method exists. If
  46 ;;   call-next-method is not used, only the most specific primary
  47 ;;   method is called.
  48 ;;
  49 ;; - All the :after methods are called, in most-specific-last order.
  50 ;;   Their values are ignored.  An error is signaled if
  51 ;;   call-next-method is used in a :after method.
  52 ;;
  53
  54 (defvar eieio-test-method-order-list nil
  55   "List of symbols stored during method invocation.")
  56
  57 (defun eieio-test-method-store ()
  58   "Store current invocation class symbol in the invocation order list."
  59   (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
  60                        (or eieio-generic-call-key 0)))
  61          (c (list eieio-generic-call-methodname keysym scoped-class)))
  62     (setq eieio-test-method-order-list
  63           (cons c 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!")))
  70
  71 ;;; This Example was submitted by darkman:
  72 ;;
  73 ;; drkm <darkman_spam@yahoo.fr>
  74 (defclass A () ())
  75 (defclass AA (A) ())
  76 (defclass AAA (AA) ())
  77
  78 (defmethod F :BEFORE ((p A))
  79   (eieio-test-method-store))
  80 (defmethod F :BEFORE ((p AA))
  81   (eieio-test-method-store))
  82 (defmethod F :BEFORE ((p AAA))
  83   (eieio-test-method-store))
  84
  85 (defmethod F ((p A))
  86   (eieio-test-method-store))
  87 (defmethod F ((p AA))
  88   (eieio-test-method-store))
  89
  90 (defmethod F :AFTER ((p A))
  91   (eieio-test-method-store))
  92 (defmethod F :AFTER ((p AA))
  93   (eieio-test-method-store))
  94 (defmethod F :AFTER ((p AAA))
  95   (eieio-test-method-store))
  96
  97 (let ((eieio-test-method-order-list nil)
  98       (ans '(
  99              (F :BEFORE AAA)
 100              (F :BEFORE AA)
 101              (F :BEFORE A)
 102              ;; Not primary A method
 103              (F :PRIMARY AA)
 104              ;; No call-next-method in AA to get to A.
 105              (F :AFTER A)
 106              (F :AFTER AA)
 107              (F :AFTER AAA)
 108              )))
 109   (F (AAA nil))
 110   (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 111   (eieio-test-match ans))
 112
 113 (defmethod G :BEFORE ((p A))
 114   (eieio-test-method-store))
 115 (defmethod G :BEFORE ((p AAA))
 116   (eieio-test-method-store))
 117
 118 (defmethod G ((p A))
 119   (eieio-test-method-store))
 120
 121 (defmethod G :AFTER ((p A))
 122   (eieio-test-method-store))
 123 (defmethod G :AFTER ((p AAA))
 124   (eieio-test-method-store))
 125
 126
 127 (let ((eieio-test-method-order-list nil)
 128       (ans '(
 129              (G :BEFORE AAA)
 130              (G :BEFORE A)
 131              ;; Not primary A method
 132              (G :PRIMARY A)
 133              ;; No call-next-method in AA to get to A.
 134              (G :AFTER A)
 135              (G :AFTER AAA)
 136              )))
 137   (G (AAA nil))
 138   (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 139   (eieio-test-match ans))
 140
 141 ;;; Test Multiple Inheritance.
 142 ;;
 143 (defclass B-base1 () ())
 144 (defclass B-base2 () ())
 145 (defclass B (B-base1 B-base2) ())
 146
 147 (defmethod F :BEFORE ((p B-base1))
 148   (eieio-test-method-store))
 149
 150 (defmethod F :BEFORE ((p B-base2))
 151   (eieio-test-method-store))
 152
 153 (defmethod F :BEFORE ((p B))
 154   (eieio-test-method-store))
 155
 156 (defmethod F ((p B))
 157   (eieio-test-method-store)
 158   (call-next-method))
 159
 160 (defmethod F ((p B-base1))
 161   (eieio-test-method-store)
 162   (call-next-method))
 163
 164 (defmethod F ((p B-base2))
 165   (eieio-test-method-store)
 166   (when (next-method-p)
 167     (call-next-method))
 168   )
 169
 170 (defmethod F :AFTER ((p B-base1))
 171   (eieio-test-method-store))
 172
 173 (defmethod F :AFTER ((p B-base2))
 174   (eieio-test-method-store))
 175
 176 (defmethod F :AFTER ((p B))
 177   (eieio-test-method-store))
 178
 179 (let ((eieio-test-method-order-list nil)
 180       (ans '(
 181              (F :BEFORE B)
 182              (F :BEFORE B-base1)
 183              (F :BEFORE B-base2)
 184
 185              (F :PRIMARY B)
 186              (F :PRIMARY B-base1)
 187              (F :PRIMARY B-base2)
 188
 189              (F :AFTER B-base2)
 190              (F :AFTER B-base1)
 191              (F :AFTER B)
 192              )))
 193   (F (B nil))
 194   (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 195   ;;(message "%S" eieio-test-method-order-list)
 196   (eieio-test-match ans)
 197   )
 198
 199 ;;; Test static invokation
 200 ;;
 201 (defmethod H :STATIC ((class A))
 202   "No need to do work in here."
 203   'moose)
 204
 205 ;; Both of these situations should succeed.
 206 (H A)
 207 (H (A nil))
 208
 209 ;;; Return value from :PRIMARY
 210 ;;
 211 (defmethod I :BEFORE ((a A))
 212   (eieio-test-method-store)
 213   ":before")
 214
 215 (defmethod I :PRIMARY ((a A))
 216   (eieio-test-method-store)
 217   ":primary")
 218
 219 (defmethod I :AFTER ((a A))
 220   (eieio-test-method-store)
 221   ":after")
 222
 223 (let ((eieio-test-method-order-list nil)
 224       (ans  (I (A nil))))
 225   (unless (string= ans ":primary")
 226     (error "Value %S erroneously provided in method call."
 227            ans)))
 228
 229 ;;; Multiple inheritance and the 'constructor' method.
 230 ;;
 231 ;; Constructor is a static method, so this is really testing
 232 ;; static method invocation and multiple inheritance.
 233 ;;
 234 (defclass C-base1 () ())
 235 (defclass C-base2 () ())
 236 (defclass C (C-base1 C-base2) ())
 237
 238 (defmethod constructor :STATIC ((p C-base1) &rest args)
 239   (eieio-test-method-store)
 240   (if (next-method-p) (call-next-method))
 241   )
 242
 243 (defmethod constructor :STATIC ((p C-base2) &rest args)
 244   (eieio-test-method-store)
 245   (if (next-method-p) (call-next-method))
 246   )
 247
 248 (defmethod constructor :STATIC ((p C) &rest args)
 249   (eieio-test-method-store)
 250   (call-next-method)
 251   )
 252
 253 (let ((eieio-test-method-order-list nil)
 254       (ans '(
 255              (constructor :STATIC C)
 256              (constructor :STATIC C-base1)
 257              (constructor :STATIC C-base2)
 258              )))
 259   (C nil)
 260   (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
 261   (eieio-test-match ans)
 262   )