1 ;;; eieio-tests.el -- eieio tests routines
3 ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software
6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
8 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;; Test the various features of EIEIO.
32 (eval-when-compile (require 'cl-lib
))
35 ;; Set up some test classes
37 ((water :initarg
:water
40 :documentation
"Detail about water.")
41 (classslot :initform penguin
43 :documentation
"A class allocated slot."
45 (test-tag :initform nil
46 :documentation
"Used to make sure methods are called.")
48 :type
(or null class-a
)
49 :documentation
"Test self referencing types.")
56 :documentation
"Detail about land."))
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.")
65 ((slot-1 :initarg
:moose
69 :documentation
"First slot testing slot arguments."
74 (slot-2 :initarg
:penguin
78 :documentation
"Second slot testing slot arguments."
88 :documentation
"Third slot test class allocated accessor"
95 (:custom-groups
(foo))
96 "A class for testing slot arguments."
99 (defclass class-subc
(class-c)
100 ((slot-1 ;; :initform moose - don't override this
102 (slot-2 :initform
"linux" ;; Do override this one
105 "A class for testing slot arguments.")
107 ;;; Defining a class with a slot tag error
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.
114 ;; (let ((eieio-error-unsupported-class-tags t))
115 ;; (condition-case nil
117 ;; (defclass class-error ()
118 ;; ((error-slot :initarg :error-slot
120 ;; "A class with a bad slot tag.")
121 ;; (error "No error was thrown for badslottag"))
122 ;; (invalid-slot-type nil)))
124 ;; (let ((eieio-error-unsupported-class-tags nil))
125 ;; (condition-case nil
127 ;; (defclass class-error ()
128 ;; ((error-slot :initarg :error-slot
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")
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)))
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
144 "Throw a warning mixing allocation class and an initarg.")
146 ;; Check that message is there
147 (should (current-message))
148 (should (string-match "Class allocated slots do not need :initarg"
149 (current-message)))))
151 (defclass abstract-class
()
152 ((some-slot :initarg
:some-slot
154 :documentation
"A slot."))
155 :documentation
"An abstract class."
158 (ert-deftest eieio-test-02-abstract-class
()
159 ;; Abstract classes cannot be instantiated, so this should throw an
161 (should-error (abstract-class)))
163 (defgeneric generic1
() "First generic function")
165 (ert-deftest eieio-test-03-generics
()
166 (defun anormalfunction () "A plain function for error testing." nil
)
169 (defgeneric anormalfunction
()
170 "Attempt to turn it into a generic.")))
172 ;; Check that generic-p works
173 (should (generic-p 'generic1
))
175 (defmethod generic1 ((c class-a
))
176 "Method on generic1."
179 (defmethod generic1 (not-an-object)
180 "Method generic1 that can take a non-object."
183 (let ((ans-obj (generic1 (class-a)))
184 (ans-num (generic1 666)))
185 (should (eq ans-obj
'monkey
))
186 (should (eq ans-num
666))))
188 (defclass static-method-class
()
189 ((some-slot :initform nil
191 :documentation
"A slot."))
192 :documentation
"A class used for testing static methods.")
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
))
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
)))
207 (ert-deftest eieio-test-05-static-method-2
()
208 (defclass static-method-class-2
(static-method-class)
210 "A second class after the previous for static methods.")
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
)))))
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
)))
224 ;;; Perform method testing
227 ;;; Multiple Inheritance, and method signal testing
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))))
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
)))
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'."
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'."
253 (ert-deftest eieio-test-08-call-next-method
()
254 ;; Play with call-next-method
255 (should (eq (class-cn eitest-ab
) 'moose
)))
257 (defmethod no-applicable-method ((b class-b
) method
&rest args
)
259 Argument B is for booger.
260 METHOD is the method that was attempting to be called."
263 (ert-deftest eieio-test-09-no-applicable-method
()
264 ;; Non-existing methods.
265 (should (eq (class-cn eitest-b
) 'moose
)))
267 (defmethod class-fun ((a class-a
))
271 (defmethod class-fun ((b class-b
))
273 (error "Class B fun should not be called")
276 (defmethod class-fun-foo ((b class-b
))
277 "Foo Fun with class B."
280 (defmethod class-fun2 ((a class-a
))
281 "More fun with class A."
284 (defmethod class-fun2 ((b class-b
))
285 "More fun with class B."
286 (error "Class B fun2 should not be called")
289 (defmethod class-fun2 ((ab class-ab
))
290 "More fun with class AB."
293 ;; How about if B is the only slot?
294 (defmethod class-fun3 ((b class-b
))
295 "Even More fun with class B."
298 (defmethod class-fun3 ((ab class-ab
))
299 "Even More fun with class AB."
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
)))
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
)))
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
)
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
)
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
)
332 (ert-deftest eieio-test-12-generic-function-call
()
333 ;; Test value of a generic function call
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
)))))
342 ;;; Test initialization methods
345 (ert-deftest eieio-test-13-init-methods
()
346 (defmethod initialize-instance ((a class-a
) &rest slots
)
347 "Initialize the slots of class-a."
349 (if (/= (oref a test-tag
) 1)
350 (error "shared-initialize test failed."))
353 (defmethod shared-initialize ((a class-a
) &rest slots
)
354 "Shared initialize method for class-a."
358 (let ((ca (class-a)))
359 (should-not (/= (oref ca test-tag
) 2))))
362 ;;; Perform slot testing
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
)))
370 (ert-deftest eieio-test-15-slot-missing
()
372 (defmethod slot-missing ((ab class-ab
) &rest foo
)
373 "If a slot in AB is unbound, return something cool. FOO."
376 (should (eq (oref eitest-ab ooga-booga
) 'moose
))
377 (should-error (oref eitest-a ooga-booga
) :type
'invalid-slot-name
))
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
))
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."
398 ((or (eq slot-name
:derived-value
)
399 (eq slot-name
'derived-value
))
400 (with-slots (base-value) vsc
401 (if (eq operation
'oref
)
403 (setq base-value
(- new-value
1)))))
404 (t (call-next-method))))
406 (ert-deftest eieio-test-17-virtual-slot
()
407 (setq eitest-vsca
(virtual-slot-class :base-value
1))
409 (should (= (oref eitest-vsca
:base-value
) 1))
410 (should (= (oref eitest-vsca
:derived-value
) 2))
412 (oset eitest-vsca
:derived-value
3)
413 (should (= (oref eitest-vsca
:base-value
) 2))
414 (should (= (oref eitest-vsca
:derived-value
) 3))
416 (oset eitest-vsca
:base-value
3)
417 (should (= (oref eitest-vsca
:base-value
) 3))
418 (should (= (oref eitest-vsca
:derived-value
) 4))
420 ;; should also be possible to initialize instance using virtual slot
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)))
426 (ert-deftest eieio-test-18-slot-unbound
()
428 (defmethod slot-unbound ((a class-a
) &rest foo
)
429 "If a slot in A is unbound, ignore FOO."
432 (should (eq (oref eitest-a water
) 'moose
))
434 ;; Check if oset of unbound works
435 (oset eitest-a water
'moose
)
436 (should (eq (oref eitest-a water
) 'moose
))
438 ;; oref/oref-default comparison
439 (should-not (eq (oref eitest-a water
) (oref-default eitest-a water
)))
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
)))
445 ;; After setting 'water to 'moose, make sure a new object has
447 (oset-default (eieio-object-class eitest-a
) water
'penguin
)
448 (should (eq (oref (class-a) water
) 'penguin
))
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
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
))
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))
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
)))
475 ;; Slot should be bound
476 (should (slot-boundp eitest-a
'classslot
))
477 (should (slot-boundp 'class-a
'classslot
))
479 (slot-makeunbound eitest-a
'classslot
)
481 (should-not (slot-boundp eitest-a
'classslot
))
482 (should-not (slot-boundp 'class-a
'classslot
)))
485 (defvar eieio-test-permuting-value nil
)
486 (defvar eitest-pvinit nil
)
488 (setq eieio-test-permuting-value
1))
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
)
497 "Test initforms that eval.")
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))
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)))
509 (defvar eitest-tests nil
)
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.")
517 (defclass eitest-superior nil
518 ((sub :initform
(eitest-subordinate)
519 :type eitest-subordinate
))
520 "A class with an initform that creates a class.")
522 (should (setq eitest-tests
(eitest-superior)))
526 '(defclass broken-init nil
529 "This class should break."))
530 :type
'invalid-slot-type
))
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 (should (equal (eieio-class-parents 'class-ab
)
541 (mapcar #'find-class
'(class-a class-b
))))
542 (should (same-class-p eitest-a
'class-a
))
543 (should (class-a-p eitest-a
))
544 (should (not (class-a-p eitest-ab
)))
545 (should (cl-typep eitest-a
'class-a
))
546 (should (cl-typep eitest-ab
'class-a
))
547 (should (not (class-a-p "foo")))
548 (should (not (cl-typep "foo" 'class-a
))))
550 (ert-deftest eieio-test-24-object-predicates
()
551 (let ((listooa (list (class-ab) (class-a)))
552 (listoob (list (class-ab) (class-b))))
553 (should (cl-typep listooa
'(list-of class-a
)))
554 (should (cl-typep listoob
'(list-of class-b
)))
555 (should-not (cl-typep listooa
'(list-of class-b
)))
556 (should-not (cl-typep listoob
'(list-of class-a
)))))
558 (defvar eitest-t1 nil
)
559 (ert-deftest eieio-test-25-slot-tests
()
560 (setq eitest-t1
(class-c))
561 ;; Slot initialization
562 (should (eq (oref eitest-t1 slot-1
) 'moose
))
563 (should (eq (oref eitest-t1
:moose
) 'moose
))
564 ;; Don't pass reference of private slot
565 ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
566 ;; Check private slot accessor
567 (should (string= (get-slot-2 eitest-t1
) "penguin"))
568 ;; Pass string instead of symbol
569 (should-error (class-c :moose
"not a symbol") :type
'invalid-slot-type
)
570 (should (eq (get-slot-3 eitest-t1
) 'emu
))
571 (should (eq (get-slot-3 'class-c
) 'emu
))
573 (setf (get-slot-3 eitest-t1
) 'setf-emu
)
574 (should (eq (get-slot-3 eitest-t1
) 'setf-emu
))
576 (setf (get-slot-3 eitest-t1
) 'emu
))
578 (defvar eitest-t2 nil
)
579 (ert-deftest eieio-test-26-default-inheritance
()
580 ;; See previous test, nor for subclass
581 (setq eitest-t2
(class-subc))
582 (should (eq (oref eitest-t2 slot-1
) 'moose
))
583 (should (eq (oref eitest-t2
:moose
) 'moose
))
584 (should (string= (get-slot-2 eitest-t2
) "linux"))
585 ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
586 (should (string= (get-slot-2 eitest-t2
) "linux"))
587 (should-error (class-subc :moose
"not a symbol") :type
'invalid-slot-type
))
589 ;;(ert-deftest eieio-test-27-inherited-new-value ()
590 ;;; HACK ALERT: The new value of a class slot is inherited by the
591 ;; subclass! This is probably a bug. We should either share the slot
592 ;; so sets on the baseclass change the subclass, or we should inherit
593 ;; the original value.
594 ;; (should (eq (get-slot-3 eitest-t2) 'emu))
595 ;; (should (eq (get-slot-3 class-subc) 'emu))
596 ;; (setf (get-slot-3 eitest-t2) 'setf-emu)
597 ;; (should (eq (get-slot-3 eitest-t2) 'setf-emu)))
602 "Protection testing baseclass.")
604 (defmethod prot0-slot-2 ((s2 prot-0
))
605 "Try to access slot-2 from this class which doesn't have it.
606 The object S2 passed in will be of class prot-1, which does have
607 the slot. This could be allowed, and currently is in EIEIO.
608 Needed by the eieio persistent base class."
611 (defclass prot-1
(prot-0)
612 ((slot-1 :initarg
:slot-1
615 (slot-2 :initarg
:slot-2
617 :protection
:protected
)
618 (slot-3 :initarg
:slot-3
620 :protection
:private
))
621 "A class for testing the :protection option.")
623 (defclass prot-2
(prot-1)
625 "A class for testing the :protection option.")
627 (defmethod prot1-slot-2 ((s2 prot-1
))
628 "Try to access slot-2 in S2."
631 (defmethod prot1-slot-2 ((s2 prot-2
))
632 "Try to access slot-2 in S2."
635 (defmethod prot1-slot-3-only ((s2 prot-1
))
636 "Try to access slot-3 in S2.
637 Do not override for `prot-2'."
640 (defmethod prot1-slot-3 ((s2 prot-1
))
641 "Try to access slot-3 in S2."
644 (defmethod prot1-slot-3 ((s2 prot-2
))
645 "Try to access slot-3 in S2."
648 (defvar eitest-p1 nil
)
649 (defvar eitest-p2 nil
)
650 (ert-deftest eieio-test-28-slot-protection
()
651 (setq eitest-p1
(prot-1))
652 (setq eitest-p2
(prot-2))
653 ;; Access public slots
654 (oref eitest-p1 slot-1
)
655 (oref eitest-p2 slot-1
)
656 ;; Accessing protected slot out of context used to fail, but we dropped this
657 ;; feature, since it was underused and no one noticed that the check was
658 ;; incorrect (much too loose).
659 ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
660 ;; Access protected slot in method
661 (prot1-slot-2 eitest-p1
)
662 ;; Protected slot in subclass method
663 (prot1-slot-2 eitest-p2
)
664 ;; Protected slot from parent class method
665 (prot0-slot-2 eitest-p1
)
666 ;; Accessing private slot out of context used to fail, but we dropped this
667 ;; feature, since it was not used.
668 ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
669 ;; Access private slot in method
670 (prot1-slot-3 eitest-p1
)
671 ;; Access private slot in subclass method must fail
672 ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
673 ;; Access private slot by same class
674 (prot1-slot-3-only eitest-p1
)
675 ;; Access private slot by subclass in sameclass method
676 (prot1-slot-3-only eitest-p2
))
678 ;;; eieio-instance-inheritor
679 ;; Test to make sure this works.
680 (defclass II
(eieio-instance-inheritor)
684 "Instance Inheritor test class.")
686 (defvar eitest-II1 nil
)
687 (defvar eitest-II2 nil
)
688 (defvar eitest-II3 nil
)
689 (ert-deftest eieio-test-29-instance-inheritor
()
690 (setq eitest-II1
(II "II Test."))
691 (oset eitest-II1 slot2
'cat
)
692 (setq eitest-II2
(clone eitest-II1
"eitest-II2 Test."))
693 (oset eitest-II2 slot1
'moose
)
694 (setq eitest-II3
(clone eitest-II2
"eitest-II3 Test."))
695 (oset eitest-II3 slot3
'penguin
)
697 ;; Test level 1 inheritance
698 (should (eq (oref eitest-II3 slot1
) 'moose
))
699 ;; Test level 2 inheritance
700 (should (eq (oref eitest-II3 slot2
) 'cat
))
701 ;; Test level 0 inheritance
702 (should (eq (oref eitest-II3 slot3
) 'penguin
)))
704 (defclass slotattr-base
()
705 ((initform :initform init
)
707 (initarg :initarg
:initarg
)
708 (protection :protection
:private
)
709 (custom :custom
(repeat string
)
710 :label
"Custom Strings"
712 (docstring :documentation
713 "Replace the doc-string for this property.")
714 (printer :printer printer1
)
716 "Baseclass we will attempt to subclass.
717 Subclasses to override slot attributes.")
719 (defclass slotattr-ok
(slotattr-base)
720 ((initform :initform no-init
)
721 (initarg :initarg
:initblarg
)
722 (custom :custom string
725 (docstring :documentation
726 "A better doc string for this class.")
727 (printer :printer printer2
)
729 "This class should allow overriding of various slot attributes.")
732 (ert-deftest eieio-test-30-slot-attribute-override
()
733 ;; Subclass should not override :protection slot attribute
734 ;;PROTECTION is gone.
737 ;; '(defclass slotattr-fail (slotattr-base)
738 ;; ((protection :protection :public)
740 ;; "This class should throw an error.")))
742 ;; Subclass should not override :type slot attribute
745 '(defclass slotattr-fail
(slotattr-base)
748 "This class should throw an error.")))
750 ;; Initform should override instance allocation
751 (let ((obj (slotattr-ok)))
752 (should (eq (oref obj initform
) 'no-init
))))
754 (defclass slotattr-class-base
()
755 ((initform :allocation
:class
757 (type :allocation
:class
759 (initarg :allocation
:class
761 (protection :allocation
:class
762 :protection
:private
)
763 (custom :allocation
:class
764 :custom
(repeat string
)
765 :label
"Custom Strings"
767 (docstring :allocation
:class
769 "Replace the doc-string for this property.")
771 "Baseclass we will attempt to subclass.
772 Subclasses to override slot attributes.")
774 (defclass slotattr-class-ok
(slotattr-class-base)
775 ((initform :initform no-init
)
776 (initarg :initarg
:initblarg
)
777 (custom :custom string
780 (docstring :documentation
781 "A better doc string for this class.")
783 "This class should allow overriding of various slot attributes.")
786 (ert-deftest eieio-test-31-slot-attribute-override-class-allocation
()
787 ;; Same as test-30, but with class allocation
788 ;;PROTECTION is gone.
791 ;; '(defclass slotattr-fail (slotattr-class-base)
792 ;; ((protection :protection :public)
794 ;; "This class should throw an error.")))
797 '(defclass slotattr-fail
(slotattr-class-base)
800 "This class should throw an error.")))
801 (should (eq (oref-default 'slotattr-class-ok initform
) 'no-init
)))
803 (ert-deftest eieio-test-32-slot-attribute-override-2
()
804 (let* ((cv (eieio--class-v 'slotattr-ok
))
805 (docs (eieio--class-public-doc cv
))
806 (names (eieio--class-public-a cv
))
807 (cust (eieio--class-public-custom cv
))
808 (label (eieio--class-public-custom-label cv
))
809 (group (eieio--class-public-custom-group cv
))
810 (types (eieio--class-public-type cv
))
811 (args (eieio--class-initarg-tuples cv
))
813 ;; :initarg should override for subclass
814 (should (assoc :initblarg args
))
816 (while (< i
(length names
))
818 ((eq (nth i names
) 'custom
)
819 ;; Custom slot attributes must override
820 (should (eq (nth i cust
) 'string
))
821 ;; Custom label slot attribute must override
822 (should (string= (nth i label
) "One String"))
823 (let ((grp (nth i group
)))
824 ;; Custom group slot attribute must combine
825 (should (and (memq 'moose grp
) (memq 'cow grp
)))))
830 (defvar eitest-CLONETEST1 nil
)
831 (defvar eitest-CLONETEST2 nil
)
833 (ert-deftest eieio-test-32-test-clone-boring-objects
()
834 ;; A simple make instance with EIEIO extension
835 (should (setq eitest-CLONETEST1
(make-instance 'class-a
)))
836 (should (setq eitest-CLONETEST2
(clone eitest-CLONETEST1
)))
838 ;; CLOS form of make-instance
839 (should (setq eitest-CLONETEST1
(make-instance 'class-a
)))
840 (should (setq eitest-CLONETEST2
(clone eitest-CLONETEST1
))))
842 (defclass IT
(eieio-instance-tracker)
843 ((tracking-symbol :initform IT-list
)
844 (slot1 :initform
'die
))
845 "Instance Tracker test object.")
847 (ert-deftest eieio-test-33-instance-tracker
()
849 (should (setq IT1
(IT)))
850 ;; The instance tracker must find this
851 (should (eieio-instance-tracker-find 'die
'slot1
'IT-list
))
853 (delete-instance IT1
)
854 (should-not (eieio-instance-tracker-find 'die
'slot1
'IT-list
))))
856 (defclass SINGLE
(eieio-singleton)
857 ((a-slot :initarg
:a-slot
:initform t
))
858 "A Singleton test object.")
860 (ert-deftest eieio-test-34-singletons
()
861 (let ((obj1 (SINGLE))
863 (should (eieio-object-p obj1
))
864 (should (eieio-object-p obj2
))
865 (should (eq obj1 obj2
))
866 (should (oref obj1 a-slot
))))
868 (defclass NAMED
(eieio-named)
869 ((some-slot :initform nil
)
871 "A class inheriting from eieio-named.")
873 (ert-deftest eieio-test-35-named-object
()
875 (should (setq N
(NAMED :object-name
"Foo")))
876 (should (string= "Foo" (oref N object-name
)))
877 (should-error (oref N missing-slot
) :type
'invalid-slot-name
)
878 (oset N object-name
"NewName")
879 (should (string= "NewName" (oref N object-name
)))))
881 (defclass opt-test1
()
883 "Abstract base class"
886 (defclass opt-test2
(opt-test1)
888 "Instantiable child")
890 (ert-deftest eieio-test-36-build-class-alist
()
891 (should (= (length (eieio-build-class-alist 'opt-test1 nil
)) 2))
892 (should (= (length (eieio-build-class-alist 'opt-test1 t
)) 1)))
894 (defclass eieio--testing
()
897 (defmethod constructor :static
((_x eieio--testing
) newname
&rest _args
)
900 (ert-deftest eieio-test-37-obsolete-name-in-constructor
()
901 (should (equal (eieio--testing "toto") '("toto" 2))))
903 (provide 'eieio-tests
)
905 ;;; eieio-tests.el ends here
908 ;; no-byte-compile: t