test/automated/eieio-tests.el

   1 ;;; eieio-tests.el -- eieio tests routines
   2
   3 ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software
   4 ;; Foundation, 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 the various features of EIEIO.
  26
  27 (require 'ert)
  28 (require 'eieio)
  29 (require 'eieio-base)
  30 (require 'eieio-opt)
  31
  32 (eval-when-compile (require 'cl-lib))
  33
  34 ;;; Code:
  35 ;; Set up some test classes
  36 (defclass class-a ()
  37   ((water :initarg :water
  38           :initform h20
  39           :type symbol
  40           :documentation "Detail about water.")
  41    (classslot :initform penguin
  42               :type symbol
  43               :documentation "A class allocated slot."
  44               :allocation :class)
  45    (test-tag :initform nil
  46              :documentation "Used to make sure methods are called.")
  47    (self :initform nil
  48          :type (or null class-a)
  49          :documentation "Test self referencing types.")
  50    )
  51   "Class A")
  52
  53 (defclass class-b ()
  54   ((land :initform "Sc"
  55          :type string
  56          :documentation "Detail about land."))
  57   "Class B")
  58
  59 (defclass class-ab (class-a class-b)
  60   ((amphibian :initform "frog"
  61               :documentation "Detail about amphibian on land and water."))
  62   "Class A and B combined.")
  63
  64 (defclass class-c ()
  65   ((slot-1 :initarg :moose
  66            :initform moose
  67            :type symbol
  68            :allocation :instance
  69            :documentation "First slot testing slot arguments."
  70            :custom symbol
  71            :label "Wild Animal"
  72            :group borg
  73            :protection :public)
  74    (slot-2 :initarg :penguin
  75            :initform "penguin"
  76            :type string
  77            :allocation :instance
  78            :documentation "Second slot testing slot arguments."
  79            :custom string
  80            :label "Wild bird"
  81            :group vorlon
  82            :accessor get-slot-2
  83            :protection :private)
  84    (slot-3 :initarg :emu
  85            :initform emu
  86            :type symbol
  87            :allocation :class
  88            :documentation "Third slot test class allocated accessor"
  89            :custom symbol
  90            :label "Fuzz"
  91            :group tokra
  92            :accessor get-slot-3
  93            :protection :private)
  94    )
  95   (:custom-groups (foo))
  96   "A class for testing slot arguments."
  97   )
  98
  99 (defclass class-subc (class-c)
 100   ((slot-1 ;; :initform moose  - don't override this
 101     )
 102    (slot-2 :initform "linux" ;; Do override this one
 103            :protection :private
 104            ))
 105   "A class for testing slot arguments.")
 106
 107 ;;; Defining a class with a slot tag error
 108 ;;
 109 ;; Temporarily disable this test because of macro expansion changes in
 110 ;; current Emacs trunk. It can be re-enabled when we have moved
 111 ;; `eieio-defclass' into the `defclass' macro and the
 112 ;; `eval-and-compile' there is removed.
 113
 114 ;; (let ((eieio-error-unsupported-class-tags t))
 115 ;;   (condition-case nil
 116 ;;       (progn
 117 ;;      (defclass class-error ()
 118 ;;        ((error-slot :initarg :error-slot
 119 ;;                     :badslottag 1))
 120 ;;        "A class with a bad slot tag.")
 121 ;;      (error "No error was thrown for badslottag"))
 122 ;;     (invalid-slot-type nil)))
 123
 124 ;; (let ((eieio-error-unsupported-class-tags nil))
 125 ;;   (condition-case nil
 126 ;;       (progn
 127 ;;      (defclass class-error ()
 128 ;;        ((error-slot :initarg :error-slot
 129 ;;                     :badslottag 1))
 130 ;;        "A class with a bad slot tag."))
 131 ;;     (invalid-slot-type
 132 ;;      (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil")
 133 ;;      )))
 134
 135 (ert-deftest eieio-test-01-mix-alloc-initarg ()
 136   ;; Only run this test if the message framework thingy works.
 137   (when (and (message "foo") (string= "foo" (current-message)))
 138
 139     ;; Defining this class should generate a warning(!) message that
 140     ;; you should not mix :initarg with class allocated slots.
 141     (defclass class-alloc-initarg ()
 142       ((throwwarning :initarg :throwwarning
 143                      :allocation :class))
 144       "Throw a warning mixing allocation class and an initarg.")
 145
 146     ;; Check that message is there
 147     (should (current-message))
 148     (should (string-match "Class allocated slots do not need :initarg"
 149                           (current-message)))))
 150
 151 (defclass abstract-class ()
 152   ((some-slot :initarg :some-slot
 153               :initform nil
 154               :documentation "A slot."))
 155   :documentation "An abstract class."
 156   :abstract t)
 157
 158 (ert-deftest eieio-test-02-abstract-class ()
 159   ;; Abstract classes cannot be instantiated, so this should throw an
 160   ;; error
 161   (should-error (abstract-class)))
 162
 163 (defgeneric generic1 () "First generic function")
 164
 165 (ert-deftest eieio-test-03-generics ()
 166   (defun anormalfunction () "A plain function for error testing." nil)
 167   (should-error
 168    (progn
 169      (defgeneric anormalfunction ()
 170        "Attempt to turn it into a generic.")))
 171
 172   ;; Check that generic-p works
 173   (should (generic-p 'generic1))
 174
 175   (defmethod generic1 ((c class-a))
 176     "Method on generic1."
 177     'monkey)
 178
 179   (defmethod generic1 (not-an-object)
 180     "Method generic1 that can take a non-object."
 181     not-an-object)
 182
 183   (let ((ans-obj (generic1 (class-a)))
 184         (ans-num (generic1 666)))
 185     (should (eq ans-obj 'monkey))
 186     (should (eq ans-num 666))))
 187
 188 (defclass static-method-class ()
 189   ((some-slot :initform nil
 190               :allocation :class
 191               :documentation "A slot."))
 192   :documentation "A class used for testing static methods.")
 193
 194 (defmethod static-method-class-method :STATIC ((c static-method-class) value)
 195   "Test static methods.
 196 Argument C is the class bound to this static method."
 197   (if (eieio-object-p c) (setq c (eieio-object-class c)))
 198   (oset-default c some-slot value))
 199
 200 (ert-deftest eieio-test-04-static-method ()
 201   ;; Call static method on a class and see if it worked
 202   (static-method-class-method 'static-method-class 'class)
 203   (should (eq (oref-default 'static-method-class some-slot) 'class))
 204   (static-method-class-method (static-method-class) 'object)
 205   (should (eq (oref-default 'static-method-class some-slot) 'object)))
 206
 207 (ert-deftest eieio-test-05-static-method-2 ()
 208   (defclass static-method-class-2 (static-method-class)
 209     ()
 210     "A second class after the previous for static methods.")
 211
 212   (defmethod static-method-class-method :STATIC ((c static-method-class-2) value)
 213     "Test static methods.
 214 Argument C is the class bound to this static method."
 215     (if (eieio-object-p c) (setq c (eieio-object-class c)))
 216     (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
 217
 218   (static-method-class-method 'static-method-class-2 'class)
 219   (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
 220   (static-method-class-method (static-method-class-2) 'object)
 221   (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
 222
 223 \f
 224 ;;; Perform method testing
 225 ;;
 226
 227 ;;; Multiple Inheritance, and method signal testing
 228 ;;
 229 (defvar eitest-ab nil)
 230 (defvar eitest-a nil)
 231 (defvar eitest-b nil)
 232 (ert-deftest eieio-test-06-allocate-objects ()
 233    ;; allocate an object to use
 234    (should (setq eitest-ab (class-ab)))
 235    (should (setq eitest-a (class-a)))
 236    (should (setq eitest-b (class-b))))
 237
 238 (ert-deftest eieio-test-07-make-instance ()
 239   (should (make-instance 'class-ab))
 240   (should (make-instance 'class-a :water 'cho))
 241   (should (make-instance 'class-b)))
 242
 243 (defmethod class-cn ((a class-a))
 244   "Try calling `call-next-method' when there isn't one.
 245 Argument A is object of type symbol `class-a'."
 246   (call-next-method))
 247
 248 (defmethod no-next-method ((a class-a) &rest args)
 249   "Override signal throwing for variable `class-a'.
 250 Argument A is the object of class variable `class-a'."
 251   'moose)
 252
 253 (ert-deftest eieio-test-08-call-next-method ()
 254   ;; Play with call-next-method
 255   (should (eq (class-cn eitest-ab) 'moose)))
 256
 257 (defmethod no-applicable-method ((b class-b) method &rest args)
 258   "No need.
 259 Argument B is for booger.
 260 METHOD is the method that was attempting to be called."
 261   'moose)
 262
 263 (ert-deftest eieio-test-09-no-applicable-method ()
 264   ;; Non-existing methods.
 265   (should (eq (class-cn eitest-b) 'moose)))
 266
 267 (defmethod class-fun ((a class-a))
 268   "Fun with class A."
 269   'moose)
 270
 271 (defmethod class-fun ((b class-b))
 272   "Fun with class B."
 273   (error "Class B fun should not be called")
 274   )
 275
 276 (defmethod class-fun-foo ((b class-b))
 277   "Foo Fun with class B."
 278   'moose)
 279
 280 (defmethod class-fun2 ((a class-a))
 281   "More fun with class A."
 282   'moose)
 283
 284 (defmethod class-fun2 ((b class-b))
 285   "More fun with class B."
 286   (error "Class B fun2 should not be called")
 287   )
 288
 289 (defmethod class-fun2 ((ab class-ab))
 290   "More fun with class AB."
 291   (call-next-method))
 292
 293 ;; How about if B is the only slot?
 294 (defmethod class-fun3 ((b class-b))
 295   "Even More fun with class B."
 296   'moose)
 297
 298 (defmethod class-fun3 ((ab class-ab))
 299   "Even More fun with class AB."
 300   (call-next-method))
 301
 302 (ert-deftest eieio-test-10-multiple-inheritance ()
 303   ;; play with methods and mi
 304   (should (eq (class-fun eitest-ab) 'moose))
 305   (should (eq (class-fun-foo eitest-ab) 'moose))
 306   ;; Play with next-method and mi
 307   (should (eq (class-fun2 eitest-ab) 'moose))
 308   (should (eq (class-fun3 eitest-ab) 'moose)))
 309
 310 (ert-deftest eieio-test-11-self ()
 311   ;; Try the self referencing test
 312   (should (oset eitest-a self eitest-a))
 313   (should (oset eitest-ab self eitest-ab)))
 314
 315
 316 (defvar class-fun-value-seq '())
 317 (defmethod class-fun-value :BEFORE ((a class-a))
 318   "Return `before', and push `before' in `class-fun-value-seq'."
 319   (push 'before class-fun-value-seq)
 320   'before)
 321
 322 (defmethod class-fun-value :PRIMARY ((a class-a))
 323   "Return `primary', and push `primary' in `class-fun-value-seq'."
 324   (push 'primary class-fun-value-seq)
 325   'primary)
 326
 327 (defmethod class-fun-value :AFTER ((a class-a))
 328   "Return `after', and push `after' in `class-fun-value-seq'."
 329   (push 'after class-fun-value-seq)
 330   'after)
 331
 332 (ert-deftest eieio-test-12-generic-function-call ()
 333   ;; Test value of a generic function call
 334   ;;
 335   (let* ((class-fun-value-seq nil)
 336          (value (class-fun-value eitest-a)))
 337     ;; Test if generic function call returns the primary method's value
 338     (should (eq value 'primary))
 339     ;; Make sure :before and :after methods were run
 340     (should (equal class-fun-value-seq '(after primary before)))))
 341
 342 ;;; Test initialization methods
 343 ;;
 344
 345 (ert-deftest eieio-test-13-init-methods ()
 346   (defmethod initialize-instance ((a class-a) &rest slots)
 347     "Initialize the slots of class-a."
 348     (call-next-method)
 349     (if (/= (oref a test-tag) 1)
 350         (error "shared-initialize test failed."))
 351     (oset a test-tag 2))
 352
 353   (defmethod shared-initialize ((a class-a) &rest slots)
 354     "Shared initialize method for class-a."
 355     (call-next-method)
 356     (oset a test-tag 1))
 357
 358   (let ((ca (class-a)))
 359     (should-not (/=  (oref ca test-tag) 2))))
 360
 361 \f
 362 ;;; Perform slot testing
 363 ;;
 364 (ert-deftest eieio-test-14-slots ()
 365   ;; Check slot existence
 366   (should (oref eitest-ab water))
 367   (should (oref eitest-ab land))
 368   (should (oref eitest-ab amphibian)))
 369
 370 (ert-deftest eieio-test-15-slot-missing ()
 371
 372   (defmethod slot-missing ((ab class-ab) &rest foo)
 373     "If a slot in AB is unbound, return something cool.  FOO."
 374     'moose)
 375
 376   (should (eq (oref eitest-ab ooga-booga) 'moose))
 377   (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name))
 378
 379 (ert-deftest eieio-test-16-slot-makeunbound ()
 380   (slot-makeunbound eitest-a 'water)
 381   ;; Should now be unbound
 382   (should-not (slot-boundp eitest-a 'water))
 383   ;; But should still exist
 384   (should (slot-exists-p eitest-a 'water))
 385   (should-not (slot-exists-p eitest-a 'moose))
 386   ;; oref of unbound slot must fail
 387   (should-error (oref eitest-a water) :type 'unbound-slot))
 388
 389 (defvar eitest-vsca nil)
 390 (defvar eitest-vscb nil)
 391 (defclass virtual-slot-class ()
 392   ((base-value :initarg :base-value))
 393   "Class has real slot :base-value and simulated slot :derived-value.")
 394 (defmethod slot-missing ((vsc virtual-slot-class)
 395                          slot-name operation &optional new-value)
 396   "Simulate virtual slot derived-value."
 397   (cond
 398    ((or (eq slot-name :derived-value)
 399         (eq slot-name 'derived-value))
 400     (with-slots (base-value) vsc
 401       (if (eq operation 'oref)
 402           (+ base-value 1)
 403         (setq base-value (- new-value 1)))))
 404    (t (call-next-method))))
 405
 406 (ert-deftest eieio-test-17-virtual-slot ()
 407   (setq eitest-vsca (virtual-slot-class :base-value 1))
 408   ;; Check slot values
 409   (should (= (oref eitest-vsca :base-value) 1))
 410   (should (= (oref eitest-vsca :derived-value) 2))
 411
 412   (oset eitest-vsca :derived-value 3)
 413   (should (= (oref eitest-vsca :base-value) 2))
 414   (should (= (oref eitest-vsca :derived-value) 3))
 415
 416   (oset eitest-vsca :base-value 3)
 417   (should (= (oref eitest-vsca :base-value) 3))
 418   (should (= (oref eitest-vsca :derived-value) 4))
 419
 420   ;; should also be possible to initialize instance using virtual slot
 421
 422   (setq eitest-vscb (virtual-slot-class :derived-value 5))
 423   (should (= (oref eitest-vscb :base-value) 4))
 424   (should (= (oref eitest-vscb :derived-value) 5)))
 425
 426 (ert-deftest eieio-test-18-slot-unbound ()
 427
 428   (defmethod slot-unbound ((a class-a) &rest foo)
 429     "If a slot in A is unbound, ignore FOO."
 430     'moose)
 431
 432   (should (eq (oref eitest-a water) 'moose))
 433
 434   ;; Check if oset of unbound works
 435   (oset eitest-a water 'moose)
 436   (should (eq (oref eitest-a water) 'moose))
 437
 438   ;; oref/oref-default comparison
 439   (should-not (eq (oref eitest-a water) (oref-default eitest-a water)))
 440
 441   ;; oset-default -> oref/oref-default comparison
 442   (oset-default (eieio-object-class eitest-a) water 'moose)
 443   (should (eq (oref eitest-a water) (oref-default eitest-a water)))
 444
 445   ;; After setting 'water to 'moose, make sure a new object has
 446   ;; the right stuff.
 447   (oset-default (eieio-object-class eitest-a) water 'penguin)
 448   (should (eq (oref (class-a) water) 'penguin))
 449
 450   ;; Revert the above
 451   (defmethod slot-unbound ((a class-a) &rest foo)
 452     "If a slot in A is unbound, ignore FOO."
 453     ;; Disable the old slot-unbound so we can run this test
 454     ;; more than once
 455     (call-next-method)))
 456
 457 (ert-deftest eieio-test-19-slot-type-checking ()
 458   ;; Slot type checking
 459   ;; We should not be able to set a string here
 460   (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
 461   (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
 462   (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type))
 463
 464 (ert-deftest eieio-test-20-class-allocated-slots ()
 465   ;; Test out class allocated slots
 466   (defvar eitest-aa nil)
 467   (setq eitest-aa (class-a))
 468
 469   ;; Make sure class slots do not track between objects
 470   (let ((newval 'moose))
 471     (oset eitest-aa classslot newval)
 472     (should (eq (oref eitest-a classslot) newval))
 473     (should (eq (oref eitest-aa classslot) newval)))
 474
 475   ;; Slot should be bound
 476   (should (slot-boundp eitest-a 'classslot))
 477   (should (slot-boundp 'class-a 'classslot))
 478
 479   (slot-makeunbound eitest-a 'classslot)
 480
 481   (should-not (slot-boundp eitest-a 'classslot))
 482   (should-not (slot-boundp 'class-a 'classslot)))
 483
 484
 485 (defvar eieio-test-permuting-value nil)
 486 (defvar eitest-pvinit nil)
 487 (eval-and-compile
 488   (setq eieio-test-permuting-value 1))
 489
 490 (defclass inittest nil
 491   ((staticval :initform 1)
 492    (symval :initform eieio-test-permuting-value)
 493    (evalval :initform (symbol-value 'eieio-test-permuting-value))
 494    (evalnow :initform (symbol-value 'eieio-test-permuting-value)
 495             :allocation :class)
 496    )
 497   "Test initforms that eval.")
 498
 499 (ert-deftest eieio-test-21-eval-at-construction-time ()
 500   ;; initforms that need to be evalled at construction time.
 501   (setq eieio-test-permuting-value 2)
 502   (setq eitest-pvinit (inittest))
 503
 504   (should (eq (oref eitest-pvinit staticval) 1))
 505   (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
 506   (should (eq (oref eitest-pvinit evalval) 2))
 507   (should (eq (oref eitest-pvinit evalnow) 1)))
 508
 509 (defvar eitest-tests nil)
 510
 511 (ert-deftest eieio-test-22-init-forms-dont-match-runnable ()
 512   ;; Init forms with types that don't match the runnable.
 513   (defclass eitest-subordinate nil
 514     ((text :initform "" :type string))
 515     "Test class that will be a calculated value.")
 516
 517   (defclass eitest-superior nil
 518     ((sub :initform (eitest-subordinate)
 519           :type eitest-subordinate))
 520     "A class with an initform that creates a class.")
 521
 522   (should (setq eitest-tests (eitest-superior)))
 523
 524   (should-error
 525    (eval
 526     '(defclass broken-init nil
 527        ((broken :initform 1
 528                 :type string))
 529        "This class should break."))
 530    :type 'invalid-slot-type))
 531
 532 (ert-deftest eieio-test-23-inheritance-check ()
 533   (should (child-of-class-p 'class-ab 'class-a))
 534   (should (child-of-class-p 'class-ab 'class-b))
 535   (should (object-of-class-p eitest-a 'class-a))
 536   (should (object-of-class-p eitest-ab 'class-a))
 537   (should (object-of-class-p eitest-ab 'class-b))
 538   (should (object-of-class-p eitest-ab 'class-ab))
 539   (should (eq (eieio-class-parents 'class-a) nil))
 540   ;; FIXME: eieio-class-parents now returns class objects!
 541   (should (equal (mapcar #'eieio-class-object (eieio-class-parents 'class-ab))
 542                  (mapcar #'eieio-class-object '(class-a class-b))))
 543   (should (same-class-p eitest-a 'class-a))
 544   (should (class-a-p eitest-a))
 545   (should (not (class-a-p eitest-ab)))
 546   (should (cl-typep eitest-a 'class-a))
 547   (should (cl-typep eitest-ab 'class-a))
 548   (should (not (class-a-p "foo")))
 549   (should (not (cl-typep "foo" 'class-a))))
 550
 551 (ert-deftest eieio-test-24-object-predicates ()
 552   (let ((listooa (list (class-ab) (class-a)))
 553         (listoob (list (class-ab) (class-b))))
 554     (should (cl-typep listooa '(list-of class-a)))
 555     (should (cl-typep listoob '(list-of class-b)))
 556     (should-not (cl-typep listooa '(list-of class-b)))
 557     (should-not (cl-typep listoob '(list-of class-a)))))
 558
 559 (defvar eitest-t1 nil)
 560 (ert-deftest eieio-test-25-slot-tests ()
 561   (setq eitest-t1 (class-c))
 562   ;; Slot initialization
 563   (should (eq (oref eitest-t1 slot-1) 'moose))
 564   (should (eq (oref eitest-t1 :moose) 'moose))
 565   ;; Don't pass reference of private slot
 566   ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
 567   ;; Check private slot accessor
 568   (should (string= (get-slot-2 eitest-t1) "penguin"))
 569   ;; Pass string instead of symbol
 570   (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
 571   (should (eq (get-slot-3 eitest-t1) 'emu))
 572   (should (eq (get-slot-3 'class-c) 'emu))
 573   ;; Check setf
 574   (setf (get-slot-3 eitest-t1) 'setf-emu)
 575   (should (eq (get-slot-3 eitest-t1) 'setf-emu))
 576   ;; Roll back
 577   (setf (get-slot-3 eitest-t1) 'emu))
 578
 579 (defvar eitest-t2 nil)
 580 (ert-deftest eieio-test-26-default-inheritance ()
 581   ;; See previous test, nor for subclass
 582   (setq eitest-t2 (class-subc))
 583   (should (eq (oref eitest-t2 slot-1) 'moose))
 584   (should (eq (oref eitest-t2 :moose) 'moose))
 585   (should (string= (get-slot-2 eitest-t2) "linux"))
 586   ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
 587   (should (string= (get-slot-2 eitest-t2) "linux"))
 588   (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
 589
 590 ;;(ert-deftest eieio-test-27-inherited-new-value ()
 591   ;;; HACK ALERT: The new value of a class slot is inherited by the
 592   ;; subclass!  This is probably a bug.  We should either share the slot
 593   ;; so sets on the baseclass change the subclass, or we should inherit
 594   ;; the original value.
 595 ;;  (should (eq (get-slot-3 eitest-t2) 'emu))
 596 ;;  (should (eq (get-slot-3 class-subc) 'emu))
 597 ;;  (setf (get-slot-3 eitest-t2) 'setf-emu)
 598 ;;  (should (eq (get-slot-3 eitest-t2) 'setf-emu)))
 599
 600 ;; Slot protection
 601 (defclass prot-0 ()
 602   ()
 603   "Protection testing baseclass.")
 604
 605 (defmethod prot0-slot-2 ((s2 prot-0))
 606   "Try to access slot-2 from this class which doesn't have it.
 607 The object S2 passed in will be of class prot-1, which does have
 608 the slot.  This could be allowed, and currently is in EIEIO.
 609 Needed by the eieio persistent base class."
 610   (oref s2 slot-2))
 611
 612 (defclass prot-1 (prot-0)
 613   ((slot-1 :initarg :slot-1
 614            :initform nil
 615            :protection :public)
 616    (slot-2 :initarg :slot-2
 617            :initform nil
 618            :protection :protected)
 619    (slot-3 :initarg :slot-3
 620            :initform nil
 621            :protection :private))
 622   "A class for testing the :protection option.")
 623
 624 (defclass prot-2 (prot-1)
 625   nil
 626   "A class for testing the :protection option.")
 627
 628 (defmethod prot1-slot-2 ((s2 prot-1))
 629   "Try to access slot-2 in S2."
 630   (oref s2 slot-2))
 631
 632 (defmethod prot1-slot-2 ((s2 prot-2))
 633   "Try to access slot-2 in S2."
 634   (oref s2 slot-2))
 635
 636 (defmethod prot1-slot-3-only ((s2 prot-1))
 637   "Try to access slot-3 in S2.
 638 Do not override for `prot-2'."
 639   (oref s2 slot-3))
 640
 641 (defmethod prot1-slot-3 ((s2 prot-1))
 642   "Try to access slot-3 in S2."
 643   (oref s2 slot-3))
 644
 645 (defmethod prot1-slot-3 ((s2 prot-2))
 646   "Try to access slot-3 in S2."
 647   (oref s2 slot-3))
 648
 649 (defvar eitest-p1 nil)
 650 (defvar eitest-p2 nil)
 651 (ert-deftest eieio-test-28-slot-protection ()
 652   (setq eitest-p1 (prot-1))
 653   (setq eitest-p2 (prot-2))
 654   ;; Access public slots
 655   (oref eitest-p1 slot-1)
 656   (oref eitest-p2 slot-1)
 657   ;; Accessing protected slot out of context used to fail, but we dropped this
 658   ;; feature, since it was underused and no one noticed that the check was
 659   ;; incorrect (much too loose).
 660   ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
 661   ;; Access protected slot in method
 662   (prot1-slot-2 eitest-p1)
 663   ;; Protected slot in subclass method
 664   (prot1-slot-2 eitest-p2)
 665   ;; Protected slot from parent class method
 666   (prot0-slot-2 eitest-p1)
 667   ;; Accessing private slot out of context used to fail, but we dropped this
 668   ;; feature, since it was not used.
 669   ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
 670   ;; Access private slot in method
 671   (prot1-slot-3 eitest-p1)
 672   ;; Access private slot in subclass method must fail
 673   ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
 674   ;; Access private slot by same class
 675   (prot1-slot-3-only eitest-p1)
 676   ;; Access private slot by subclass in sameclass method
 677   (prot1-slot-3-only eitest-p2))
 678
 679 ;;; eieio-instance-inheritor
 680 ;; Test to make sure this works.
 681 (defclass II (eieio-instance-inheritor)
 682   ((slot1 :initform 1)
 683    (slot2)
 684    (slot3))
 685   "Instance Inheritor test class.")
 686
 687 (defvar eitest-II1 nil)
 688 (defvar eitest-II2 nil)
 689 (defvar eitest-II3 nil)
 690 (ert-deftest eieio-test-29-instance-inheritor ()
 691   (setq eitest-II1 (II "II Test."))
 692   (oset eitest-II1 slot2 'cat)
 693   (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test."))
 694   (oset eitest-II2 slot1 'moose)
 695   (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test."))
 696   (oset eitest-II3 slot3 'penguin)
 697
 698   ;; Test level 1 inheritance
 699   (should (eq (oref eitest-II3 slot1) 'moose))
 700   ;; Test level 2 inheritance
 701   (should (eq (oref eitest-II3 slot2) 'cat))
 702   ;; Test level 0 inheritance
 703   (should (eq (oref eitest-II3 slot3) 'penguin)))
 704
 705 (defclass slotattr-base ()
 706   ((initform :initform init)
 707    (type :type list)
 708    (initarg :initarg :initarg)
 709    (protection :protection :private)
 710    (custom :custom (repeat string)
 711            :label "Custom Strings"
 712            :group moose)
 713    (docstring :documentation
 714               "Replace the doc-string for this property.")
 715    (printer :printer printer1)
 716    )
 717   "Baseclass we will attempt to subclass.
 718 Subclasses to override slot attributes.")
 719
 720 (defclass slotattr-ok (slotattr-base)
 721   ((initform :initform no-init)
 722    (initarg :initarg :initblarg)
 723    (custom :custom string
 724            :label "One String"
 725            :group cow)
 726    (docstring :documentation
 727               "A better doc string for this class.")
 728    (printer :printer printer2)
 729    )
 730   "This class should allow overriding of various slot attributes.")
 731
 732
 733 (ert-deftest eieio-test-30-slot-attribute-override ()
 734   ;; Subclass should not override :protection slot attribute
 735   ;;PROTECTION is gone.
 736   ;;(should-error
 737   ;;       (eval
 738   ;;        '(defclass slotattr-fail (slotattr-base)
 739   ;;           ((protection :protection :public)
 740   ;;            )
 741   ;;           "This class should throw an error.")))
 742
 743   ;; Subclass should not override :type slot attribute
 744   (should-error
 745         (eval
 746          '(defclass slotattr-fail (slotattr-base)
 747           ((type :type string)
 748            )
 749           "This class should throw an error.")))
 750
 751   ;; Initform should override instance allocation
 752   (let ((obj (slotattr-ok)))
 753     (should (eq (oref obj initform) 'no-init))))
 754
 755 (defclass slotattr-class-base ()
 756   ((initform :allocation :class
 757              :initform init)
 758    (type :allocation :class
 759          :type list)
 760    (initarg :allocation :class
 761             :initarg :initarg)
 762    (protection :allocation :class
 763                :protection :private)
 764    (custom :allocation :class
 765            :custom (repeat string)
 766            :label "Custom Strings"
 767            :group moose)
 768    (docstring :allocation :class
 769               :documentation
 770               "Replace the doc-string for this property.")
 771    )
 772   "Baseclass we will attempt to subclass.
 773 Subclasses to override slot attributes.")
 774
 775 (defclass slotattr-class-ok (slotattr-class-base)
 776   ((initform :initform no-init)
 777    (initarg :initarg :initblarg)
 778    (custom :custom string
 779            :label "One String"
 780            :group cow)
 781    (docstring :documentation
 782               "A better doc string for this class.")
 783    )
 784   "This class should allow overriding of various slot attributes.")
 785
 786
 787 (ert-deftest eieio-test-31-slot-attribute-override-class-allocation ()
 788   ;; Same as test-30, but with class allocation
 789   ;;PROTECTION is gone.
 790   ;;(should-error
 791   ;;     (eval
 792   ;;      '(defclass slotattr-fail (slotattr-class-base)
 793   ;;         ((protection :protection :public)
 794   ;;          )
 795   ;;         "This class should throw an error.")))
 796   (should-error
 797       (eval
 798        '(defclass slotattr-fail (slotattr-class-base)
 799           ((type :type string)
 800            )
 801           "This class should throw an error.")))
 802   (should (eq (oref-default 'slotattr-class-ok initform) 'no-init)))
 803
 804 (ert-deftest eieio-test-32-slot-attribute-override-2 ()
 805   (let* ((cv (eieio--class-v 'slotattr-ok))
 806          (docs   (eieio--class-public-doc cv))
 807          (names  (eieio--class-public-a cv))
 808          (cust   (eieio--class-public-custom cv))
 809          (label  (eieio--class-public-custom-label cv))
 810          (group  (eieio--class-public-custom-group cv))
 811          (types  (eieio--class-public-type cv))
 812          (args   (eieio--class-initarg-tuples cv))
 813          (i 0))
 814     ;; :initarg should override for subclass
 815     (should (assoc :initblarg args))
 816
 817   (while (< i (length names))
 818     (cond
 819      ((eq (nth i names) 'custom)
 820       ;; Custom slot attributes must override
 821       (should (eq (nth i cust) 'string))
 822       ;; Custom label slot attribute must override
 823       (should (string= (nth i label) "One String"))
 824       (let ((grp (nth i group)))
 825         ;; Custom group slot attribute must combine
 826         (should (and (memq 'moose grp) (memq 'cow grp)))))
 827      (t nil))
 828
 829     (setq i (1+ i)))))
 830
 831 (defvar eitest-CLONETEST1 nil)
 832 (defvar eitest-CLONETEST2 nil)
 833
 834 (ert-deftest eieio-test-32-test-clone-boring-objects ()
 835   ;; A simple make instance with EIEIO extension
 836   (should (setq eitest-CLONETEST1 (make-instance 'class-a)))
 837   (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
 838
 839   ;; CLOS form of make-instance
 840   (should (setq eitest-CLONETEST1 (make-instance 'class-a)))
 841   (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))))
 842
 843 (defclass IT (eieio-instance-tracker)
 844   ((tracking-symbol :initform IT-list)
 845    (slot1 :initform 'die))
 846   "Instance Tracker test object.")
 847
 848 (ert-deftest eieio-test-33-instance-tracker ()
 849   (let (IT-list IT1)
 850     (should (setq IT1 (IT)))
 851     ;; The instance tracker must find this
 852     (should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
 853     ;; Test deletion
 854     (delete-instance IT1)
 855     (should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list))))
 856
 857 (defclass SINGLE (eieio-singleton)
 858   ((a-slot :initarg :a-slot :initform t))
 859   "A Singleton test object.")
 860
 861 (ert-deftest eieio-test-34-singletons ()
 862   (let ((obj1 (SINGLE))
 863         (obj2 (SINGLE)))
 864     (should (eieio-object-p obj1))
 865     (should (eieio-object-p obj2))
 866     (should (eq obj1 obj2))
 867     (should (oref obj1 a-slot))))
 868
 869 (defclass NAMED (eieio-named)
 870   ((some-slot :initform nil)
 871    )
 872   "A class inheriting from eieio-named.")
 873
 874 (ert-deftest eieio-test-35-named-object ()
 875   (let (N)
 876     (should (setq N (NAMED :object-name "Foo")))
 877     (should (string= "Foo" (oref N object-name)))
 878     (should-error (oref N missing-slot) :type 'invalid-slot-name)
 879     (oset N object-name "NewName")
 880     (should (string= "NewName" (oref N object-name)))))
 881
 882 (defclass opt-test1 ()
 883   ()
 884   "Abstract base class"
 885   :abstract t)
 886
 887 (defclass opt-test2 (opt-test1)
 888   ()
 889   "Instantiable child")
 890
 891 (ert-deftest eieio-test-36-build-class-alist ()
 892   (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
 893   (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
 894
 895 (defclass eieio--testing ()
 896   ())
 897
 898 (defmethod constructor :static ((_x eieio--testing) newname &rest _args)
 899   (list newname 2))
 900
 901 (ert-deftest eieio-test-37-obsolete-name-in-constructor ()
 902   (should (equal (eieio--testing "toto") '("toto" 2))))
 903
 904 (provide 'eieio-tests)
 905
 906 ;;; eieio-tests.el ends here
 907
 908 ;; Local Variables:
 909 ;; no-byte-compile: t
 910 ;; End: