;;; eieio-tests.el -- eieio tests routines
-;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software
+;; Copyright (C) 1999-2003, 2005-2010, 2012-2016 Free Software
;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
(require 'eieio-base)
(require 'eieio-opt)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;; Code:
;; Set up some test classes
(ert-deftest eieio-test-02-abstract-class ()
;; Abstract classes cannot be instantiated, so this should throw an
;; error
- (should-error (abstract-class "Test")))
+ (should-error (abstract-class)))
(defgeneric generic1 () "First generic function")
"Method generic1 that can take a non-object."
not-an-object)
- (let ((ans-obj (generic1 (class-a "test")))
+ (let ((ans-obj (generic1 (class-a)))
(ans-num (generic1 666)))
(should (eq ans-obj 'monkey))
(should (eq ans-num 666))))
(ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked
- (static-method-class-method static-method-class 'class)
- (should (eq (oref static-method-class some-slot) 'class))
- (static-method-class-method (static-method-class "test") 'object)
- (should (eq (oref static-method-class some-slot) 'object)))
+ (static-method-class-method 'static-method-class 'class)
+ (should (eq (oref-default 'static-method-class some-slot) 'class))
+ (static-method-class-method (static-method-class) 'object)
+ (should (eq (oref-default 'static-method-class some-slot) 'object)))
(ert-deftest eieio-test-05-static-method-2 ()
(defclass static-method-class-2 (static-method-class)
(if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
- (static-method-class-method static-method-class-2 'class)
- (should (eq (oref static-method-class-2 some-slot) 'moose-class))
- (static-method-class-method (static-method-class-2 "test") 'object)
- (should (eq (oref static-method-class-2 some-slot) 'moose-object)))
+ (static-method-class-method 'static-method-class-2 'class)
+ (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
+ (static-method-class-method (static-method-class-2) 'object)
+ (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
\f
;;; Perform method testing
(defvar eitest-b nil)
(ert-deftest eieio-test-06-allocate-objects ()
;; allocate an object to use
- (should (setq eitest-ab (class-ab "abby")))
- (should (setq eitest-a (class-a "aye")))
- (should (setq eitest-b (class-b "fooby"))))
+ (should (setq eitest-ab (class-ab)))
+ (should (setq eitest-a (class-a)))
+ (should (setq eitest-b (class-b))))
(ert-deftest eieio-test-07-make-instance ()
(should (make-instance 'class-ab))
(should (make-instance 'class-a :water 'cho))
- (should (make-instance 'class-b "a name")))
+ (should (make-instance 'class-b)))
(defmethod class-cn ((a class-a))
"Try calling `call-next-method' when there isn't one.
(call-next-method)
(oset a test-tag 1))
- (let ((ca (class-a "class act")))
+ (let ((ca (class-a)))
(should-not (/= (oref ca test-tag) 2))))
\f
(t (call-next-method))))
(ert-deftest eieio-test-17-virtual-slot ()
- (setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1))
+ (setq eitest-vsca (virtual-slot-class :base-value 1))
;; Check slot values
- (should (= (oref eitest-vsca :base-value) 1))
+ (should (= (oref eitest-vsca base-value) 1))
(should (= (oref eitest-vsca :derived-value) 2))
- (oset eitest-vsca :derived-value 3)
- (should (= (oref eitest-vsca :base-value) 2))
+ (oset eitest-vsca derived-value 3)
+ (should (= (oref eitest-vsca base-value) 2))
(should (= (oref eitest-vsca :derived-value) 3))
- (oset eitest-vsca :base-value 3)
- (should (= (oref eitest-vsca :base-value) 3))
+ (oset eitest-vsca base-value 3)
+ (should (= (oref eitest-vsca base-value) 3))
(should (= (oref eitest-vsca :derived-value) 4))
;; should also be possible to initialize instance using virtual slot
- (setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5))
- (should (= (oref eitest-vscb :base-value) 4))
+ (setq eitest-vscb (virtual-slot-class :derived-value 5))
+ (should (= (oref eitest-vscb base-value) 4))
(should (= (oref eitest-vscb :derived-value) 5)))
(ert-deftest eieio-test-18-slot-unbound ()
;; After setting 'water to 'moose, make sure a new object has
;; the right stuff.
(oset-default (eieio-object-class eitest-a) water 'penguin)
- (should (eq (oref (class-a "foo") water) 'penguin))
+ (should (eq (oref (class-a) water) 'penguin))
;; Revert the above
(defmethod slot-unbound ((a class-a) &rest foo)
;; We should not be able to set a string here
(should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
(should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
- (should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type))
+ (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type))
(ert-deftest eieio-test-20-class-allocated-slots ()
;; Test out class allocated slots
(defvar eitest-aa nil)
- (setq eitest-aa (class-a "another"))
+ (setq eitest-aa (class-a))
;; Make sure class slots do not track between objects
(let ((newval 'moose))
;; Slot should be bound
(should (slot-boundp eitest-a 'classslot))
- (should (slot-boundp class-a 'classslot))
+ (should (slot-boundp 'class-a 'classslot))
(slot-makeunbound eitest-a 'classslot)
(should-not (slot-boundp eitest-a 'classslot))
- (should-not (slot-boundp class-a 'classslot)))
+ (should-not (slot-boundp 'class-a 'classslot)))
(defvar eieio-test-permuting-value nil)
(ert-deftest eieio-test-21-eval-at-construction-time ()
;; initforms that need to be evalled at construction time.
(setq eieio-test-permuting-value 2)
- (setq eitest-pvinit (inittest "permuteme"))
+ (setq eitest-pvinit (inittest))
(should (eq (oref eitest-pvinit staticval) 1))
(should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
"Test class that will be a calculated value.")
(defclass eitest-superior nil
- ((sub :initform (eitest-subordinate "test")
+ ((sub :initform (eitest-subordinate)
:type eitest-subordinate))
"A class with an initform that creates a class.")
- (should (setq eitest-tests (eitest-superior "test")))
+ (should (setq eitest-tests (eitest-superior)))
(should-error
(eval
:type 'invalid-slot-type))
(ert-deftest eieio-test-23-inheritance-check ()
- (should (child-of-class-p class-ab class-a))
- (should (child-of-class-p class-ab class-b))
- (should (object-of-class-p eitest-a class-a))
- (should (object-of-class-p eitest-ab class-a))
- (should (object-of-class-p eitest-ab class-b))
- (should (object-of-class-p eitest-ab class-ab))
- (should (eq (eieio-class-parents class-a) nil))
- (should (equal (eieio-class-parents class-ab) '(class-a class-b)))
- (should (same-class-p eitest-a class-a))
+ (should (child-of-class-p 'class-ab 'class-a))
+ (should (child-of-class-p 'class-ab 'class-b))
+ (should (object-of-class-p eitest-a 'class-a))
+ (should (object-of-class-p eitest-ab 'class-a))
+ (should (object-of-class-p eitest-ab 'class-b))
+ (should (object-of-class-p eitest-ab 'class-ab))
+ (should (eq (eieio-class-parents 'class-a) nil))
+ (should (equal (eieio-class-parents 'class-ab)
+ (mapcar #'find-class '(class-a class-b))))
+ (should (same-class-p eitest-a 'class-a))
(should (class-a-p eitest-a))
(should (not (class-a-p eitest-ab)))
- (should (class-a-child-p eitest-a))
- (should (class-a-child-p eitest-ab))
+ (should (cl-typep eitest-a 'class-a))
+ (should (cl-typep eitest-ab 'class-a))
(should (not (class-a-p "foo")))
- (should (not (class-a-child-p "foo"))))
+ (should (not (cl-typep "foo" 'class-a))))
(ert-deftest eieio-test-24-object-predicates ()
- (let ((listooa (list (class-ab "ab") (class-a "a")))
- (listoob (list (class-ab "ab") (class-b "b"))))
- (should (class-a-list-p listooa))
- (should (class-b-list-p listoob))
- (should-not (class-b-list-p listooa))
- (should-not (class-a-list-p listoob))))
+ (let ((listooa (list (class-ab) (class-a)))
+ (listoob (list (class-ab) (class-b))))
+ (should (cl-typep listooa '(list-of class-a)))
+ (should (cl-typep listoob '(list-of class-b)))
+ (should-not (cl-typep listooa '(list-of class-b)))
+ (should-not (cl-typep listoob '(list-of class-a)))))
(defvar eitest-t1 nil)
(ert-deftest eieio-test-25-slot-tests ()
- (setq eitest-t1 (class-c "C1"))
+ (setq eitest-t1 (class-c))
;; Slot initialization
(should (eq (oref eitest-t1 slot-1) 'moose))
- (should (eq (oref eitest-t1 :moose) 'moose))
+ ;; Accessing via the initarg name is deprecated!
+ ;; (should (eq (oref eitest-t1 :moose) 'moose))
;; Don't pass reference of private slot
- (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
+ ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
;; Check private slot accessor
(should (string= (get-slot-2 eitest-t1) "penguin"))
;; Pass string instead of symbol
- (should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type)
+ (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
(should (eq (get-slot-3 eitest-t1) 'emu))
- (should (eq (get-slot-3 class-c) 'emu))
+ (should (eq (get-slot-3 'class-c) 'emu))
;; Check setf
(setf (get-slot-3 eitest-t1) 'setf-emu)
(should (eq (get-slot-3 eitest-t1) 'setf-emu))
(defvar eitest-t2 nil)
(ert-deftest eieio-test-26-default-inheritance ()
;; See previous test, nor for subclass
- (setq eitest-t2 (class-subc "subc"))
+ (setq eitest-t2 (class-subc))
(should (eq (oref eitest-t2 slot-1) 'moose))
- (should (eq (oref eitest-t2 :moose) 'moose))
+ ;; Accessing via the initarg name is deprecated!
+ ;;(should (eq (oref eitest-t2 :moose) 'moose))
(should (string= (get-slot-2 eitest-t2) "linux"))
- (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
+ ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
(should (string= (get-slot-2 eitest-t2) "linux"))
- (should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type))
+ (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
;;(ert-deftest eieio-test-27-inherited-new-value ()
;;; HACK ALERT: The new value of a class slot is inherited by the
(defvar eitest-p1 nil)
(defvar eitest-p2 nil)
(ert-deftest eieio-test-28-slot-protection ()
- (setq eitest-p1 (prot-1 ""))
- (setq eitest-p2 (prot-2 ""))
+ (setq eitest-p1 (prot-1))
+ (setq eitest-p2 (prot-2))
;; Access public slots
(oref eitest-p1 slot-1)
(oref eitest-p2 slot-1)
- ;; Accessing protected slot out of context must fail
- (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
+ ;; Accessing protected slot out of context used to fail, but we dropped this
+ ;; feature, since it was underused and no one noticed that the check was
+ ;; incorrect (much too loose).
+ ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
;; Access protected slot in method
(prot1-slot-2 eitest-p1)
;; Protected slot in subclass method
(prot1-slot-2 eitest-p2)
;; Protected slot from parent class method
(prot0-slot-2 eitest-p1)
- ;; Accessing private slot out of context must fail
- (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
+ ;; Accessing private slot out of context used to fail, but we dropped this
+ ;; feature, since it was not used.
+ ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
;; Access private slot in method
(prot1-slot-3 eitest-p1)
;; Access private slot in subclass method must fail
- (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
+ ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
;; Access private slot by same class
(prot1-slot-3-only eitest-p1)
;; Access private slot by subclass in sameclass method
(ert-deftest eieio-test-30-slot-attribute-override ()
;; Subclass should not override :protection slot attribute
- (should-error
- (eval
- '(defclass slotattr-fail (slotattr-base)
- ((protection :protection :public)
- )
- "This class should throw an error.")))
+ ;;PROTECTION is gone.
+ ;;(should-error
+ ;; (eval
+ ;; '(defclass slotattr-fail (slotattr-base)
+ ;; ((protection :protection :public)
+ ;; )
+ ;; "This class should throw an error.")))
;; Subclass should not override :type slot attribute
(should-error
"This class should throw an error.")))
;; Initform should override instance allocation
- (let ((obj (slotattr-ok "moose")))
+ (let ((obj (slotattr-ok)))
(should (eq (oref obj initform) 'no-init))))
(defclass slotattr-class-base ()
(ert-deftest eieio-test-31-slot-attribute-override-class-allocation ()
;; Same as test-30, but with class allocation
- (should-error
- (eval
- '(defclass slotattr-fail (slotattr-class-base)
- ((protection :protection :public)
- )
- "This class should throw an error.")))
+ ;;PROTECTION is gone.
+ ;;(should-error
+ ;; (eval
+ ;; '(defclass slotattr-fail (slotattr-class-base)
+ ;; ((protection :protection :public)
+ ;; )
+ ;; "This class should throw an error.")))
(should-error
(eval
'(defclass slotattr-fail (slotattr-class-base)
((type :type string)
)
"This class should throw an error.")))
- (should (eq (oref-default slotattr-class-ok initform) 'no-init)))
+ (should (eq (oref-default 'slotattr-class-ok initform) 'no-init)))
(ert-deftest eieio-test-32-slot-attribute-override-2 ()
- (let* ((cv (class-v 'slotattr-ok))
- (docs (eieio--class-public-doc cv))
- (names (eieio--class-public-a cv))
- (cust (eieio--class-public-custom cv))
- (label (eieio--class-public-custom-label cv))
- (group (eieio--class-public-custom-group cv))
- (types (eieio--class-public-type cv))
- (args (eieio--class-initarg-tuples cv))
- (i 0))
+ (let* ((cv (cl--find-class 'slotattr-ok))
+ (slots (eieio--class-slots cv))
+ (args (eieio--class-initarg-tuples cv)))
;; :initarg should override for subclass
(should (assoc :initblarg args))
- (while (< i (length names))
- (cond
- ((eq (nth i names) 'custom)
- ;; Custom slot attributes must override
- (should (eq (nth i cust) 'string))
- ;; Custom label slot attribute must override
- (should (string= (nth i label) "One String"))
- (let ((grp (nth i group)))
- ;; Custom group slot attribute must combine
- (should (and (memq 'moose grp) (memq 'cow grp)))))
- (t nil))
-
- (setq i (1+ i)))))
+ (dotimes (i (length slots))
+ (let* ((slot (aref slots i))
+ (props (cl--slot-descriptor-props slot)))
+ (cond
+ ((eq (cl--slot-descriptor-name slot) 'custom)
+ ;; Custom slot attributes must override
+ (should (eq (alist-get :custom props) 'string))
+ ;; Custom label slot attribute must override
+ (should (string= (alist-get :label props) "One String"))
+ (let ((grp (alist-get :group props)))
+ ;; Custom group slot attribute must combine
+ (should (and (memq 'moose grp) (memq 'cow grp)))))
+ (t nil))))))
(defvar eitest-CLONETEST1 nil)
(defvar eitest-CLONETEST2 nil)
(ert-deftest eieio-test-32-test-clone-boring-objects ()
;; A simple make instance with EIEIO extension
- (should (setq eitest-CLONETEST1 (make-instance 'class-a "a")))
+ (should (setq eitest-CLONETEST1 (make-instance 'class-a)))
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
;; CLOS form of make-instance
(ert-deftest eieio-test-33-instance-tracker ()
(let (IT-list IT1)
- (should (setq IT1 (IT "trackme")))
+ (should (setq IT1 (IT)))
;; The instance tracker must find this
(should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
;; Test deletion
"A Singleton test object.")
(ert-deftest eieio-test-34-singletons ()
- (let ((obj1 (SINGLE "Moose"))
- (obj2 (SINGLE "Cow")))
+ (let ((obj1 (SINGLE))
+ (obj2 (SINGLE)))
(should (eieio-object-p obj1))
(should (eieio-object-p obj2))
(should (eq obj1 obj2))
(ert-deftest eieio-test-35-named-object ()
(let (N)
- (should (setq N (NAMED "Foo")))
+ (should (setq N (NAMED :object-name "Foo")))
(should (string= "Foo" (oref N object-name)))
(should-error (oref N missing-slot) :type 'invalid-slot-name)
(oset N object-name "NewName")
"Instantiable child")
(ert-deftest eieio-test-36-build-class-alist ()
- (should (= (length (eieio-build-class-alist opt-test1 nil)) 2))
- (should (= (length (eieio-build-class-alist opt-test1 t)) 1)))
+ (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
+ (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
+
+(defclass eieio--testing () ())
+
+(defmethod constructor :static ((_x eieio--testing) newname &rest _args)
+ (list newname 2))
+
+(ert-deftest eieio-test-37-obsolete-name-in-constructor ()
+ (should (equal (eieio--testing "toto") '("toto" 2))))
(provide 'eieio-tests)