;;; eieio-tests.el -- eieio tests routines
-;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 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-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-default static-method-class some-slot) 'class))
+ (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)))
+ (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-default static-method-class-2 some-slot) 'moose-class))
+ (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)))
+ (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
\f
;;; Perform method testing
(ert-deftest eieio-test-17-virtual-slot ()
(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 :derived-value 5))
- (should (= (oref eitest-vscb :base-value) 4))
+ (should (= (oref eitest-vscb base-value) 4))
(should (= (oref eitest-vscb :derived-value) 5)))
(ert-deftest eieio-test-18-slot-unbound ()
;; 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)
: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))
- ;; FIXME: eieio-class-parents now returns class objects!
- (should (equal (mapcar #'eieio-class-object (eieio-class-parents class-ab))
- (mapcar #'eieio-class-object '(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) (class-a)))
(listoob (list (class-ab) (class-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))))
+ (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))
;; 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 :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))
;; See previous test, nor for subclass
(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 :moose "not a symbol") :type 'invalid-slot-type))
;; 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
(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 (eieio--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))
+ (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)
"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)