test/automated/eieio-tests.el

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