1 ;;; eieio-tests.el -- eieio tests routines
3 ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
7 ;; This file is part of GNU Emacs.
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.
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.
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/>.
24 ;; Test the various features of EIEIO.
31 (eval-when-compile (require 'cl
))
34 ;; Set up some test classes
36 ((water :initarg
:water
39 :documentation
"Detail about water.")
40 (classslot :initform penguin
42 :documentation
"A class allocated slot."
44 (test-tag :initform nil
45 :documentation
"Used to make sure methods are called.")
47 :type
(or null class-a
)
48 :documentation
"Test self referencing types.")
55 :documentation
"Detail about land."))
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.")
64 ((slot-1 :initarg
:moose
68 :documentation
"First slot testing slot arguments."
73 (slot-2 :initarg
:penguin
77 :documentation
"Second slot testing slot arguments."
87 :documentation
"Third slot test class allocated accessor"
94 (:custom-groups
(foo))
95 "A class for testing slot arguments."
98 (defclass class-subc
(class-c)
99 ((slot-1 ;; :initform moose - don't override this
101 (slot-2 :initform
"linux" ;; Do override this one
104 "A class for testing slot arguments.")
106 ;;; Defining a class with a slot tag error
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.
113 ;; (let ((eieio-error-unsupported-class-tags t))
114 ;; (condition-case nil
116 ;; (defclass class-error ()
117 ;; ((error-slot :initarg :error-slot
119 ;; "A class with a bad slot tag.")
120 ;; (error "No error was thrown for badslottag"))
121 ;; (invalid-slot-type nil)))
123 ;; (let ((eieio-error-unsupported-class-tags nil))
124 ;; (condition-case nil
126 ;; (defclass class-error ()
127 ;; ((error-slot :initarg :error-slot
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")
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)))
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
143 "Throw a warning mixing allocation class and an initarg.")
145 ;; Check that message is there
146 (should (current-message))
147 (should (string-match "Class allocated slots do not need :initarg"
148 (current-message)))))
150 (defclass abstract-class
()
151 ((some-slot :initarg
:some-slot
153 :documentation
"A slot."))
154 :documentation
"An abstract class."
157 (ert-deftest eieio-test-02-abstract-class
()
158 ;; Abstract classes cannot be instantiated, so this should throw an
160 (should-error (abstract-class)))
162 (defgeneric generic1
() "First generic function")
164 (ert-deftest eieio-test-03-generics
()
165 (defun anormalfunction () "A plain function for error testing." nil
)
168 (defgeneric anormalfunction
()
169 "Attempt to turn it into a generic.")))
171 ;; Check that generic-p works
172 (should (generic-p 'generic1
))
174 (defmethod generic1 ((c class-a
))
175 "Method on generic1."
178 (defmethod generic1 (not-an-object)
179 "Method generic1 that can take a non-object."
182 (let ((ans-obj (generic1 (class-a)))
183 (ans-num (generic1 666)))
184 (should (eq ans-obj
'monkey
))
185 (should (eq ans-num
666))))
187 (defclass static-method-class
()
188 ((some-slot :initform nil
190 :documentation
"A slot."))
191 :documentation
"A class used for testing static methods.")
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
))
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-default static-method-class some-slot
) 'class
))
203 (static-method-class-method (static-method-class) 'object
)
204 (should (eq (oref-default static-method-class some-slot
) 'object
)))
206 (ert-deftest eieio-test-05-static-method-2
()
207 (defclass static-method-class-2
(static-method-class)
209 "A second class after the previous for static methods.")
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
)))))
217 (static-method-class-method static-method-class-2
'class
)
218 (should (eq (oref-default static-method-class-2 some-slot
) 'moose-class
))
219 (static-method-class-method (static-method-class-2) 'object
)
220 (should (eq (oref-default static-method-class-2 some-slot
) 'moose-object
)))
223 ;;; Perform method testing
226 ;;; Multiple Inheritance, and method signal testing
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)))
234 (should (setq eitest-a
(class-a)))
235 (should (setq eitest-b
(class-b))))
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
)))
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'."
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'."
252 (ert-deftest eieio-test-08-call-next-method
()
253 ;; Play with call-next-method
254 (should (eq (class-cn eitest-ab
) 'moose
)))
256 (defmethod no-applicable-method ((b class-b
) method
&rest args
)
258 Argument B is for booger.
259 METHOD is the method that was attempting to be called."
262 (ert-deftest eieio-test-09-no-applicable-method
()
263 ;; Non-existing methods.
264 (should (eq (class-cn eitest-b
) 'moose
)))
266 (defmethod class-fun ((a class-a
))
270 (defmethod class-fun ((b class-b
))
272 (error "Class B fun should not be called")
275 (defmethod class-fun-foo ((b class-b
))
276 "Foo Fun with class B."
279 (defmethod class-fun2 ((a class-a
))
280 "More fun with class A."
283 (defmethod class-fun2 ((b class-b
))
284 "More fun with class B."
285 (error "Class B fun2 should not be called")
288 (defmethod class-fun2 ((ab class-ab
))
289 "More fun with class AB."
292 ;; How about if B is the only slot?
293 (defmethod class-fun3 ((b class-b
))
294 "Even More fun with class B."
297 (defmethod class-fun3 ((ab class-ab
))
298 "Even More fun with class AB."
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
)))
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
)))
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
)
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
)
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
)
331 (ert-deftest eieio-test-12-generic-function-call
()
332 ;; Test value of a generic function call
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
)))))
341 ;;; Test initialization methods
344 (ert-deftest eieio-test-13-init-methods
()
345 (defmethod initialize-instance ((a class-a
) &rest slots
)
346 "Initialize the slots of class-a."
348 (if (/= (oref a test-tag
) 1)
349 (error "shared-initialize test failed."))
352 (defmethod shared-initialize ((a class-a
) &rest slots
)
353 "Shared initialize method for class-a."
357 (let ((ca (class-a)))
358 (should-not (/= (oref ca test-tag
) 2))))
361 ;;; Perform slot testing
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
)))
369 (ert-deftest eieio-test-15-slot-missing
()
371 (defmethod slot-missing ((ab class-ab
) &rest foo
)
372 "If a slot in AB is unbound, return something cool. FOO."
375 (should (eq (oref eitest-ab ooga-booga
) 'moose
))
376 (should-error (oref eitest-a ooga-booga
) :type
'invalid-slot-name
))
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
))
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."
397 ((or (eq slot-name
:derived-value
)
398 (eq slot-name
'derived-value
))
399 (with-slots (base-value) vsc
400 (if (eq operation
'oref
)
402 (setq base-value
(- new-value
1)))))
403 (t (call-next-method))))
405 (ert-deftest eieio-test-17-virtual-slot
()
406 (setq eitest-vsca
(virtual-slot-class :base-value
1))
408 (should (= (oref eitest-vsca
:base-value
) 1))
409 (should (= (oref eitest-vsca
:derived-value
) 2))
411 (oset eitest-vsca
:derived-value
3)
412 (should (= (oref eitest-vsca
:base-value
) 2))
413 (should (= (oref eitest-vsca
:derived-value
) 3))
415 (oset eitest-vsca
:base-value
3)
416 (should (= (oref eitest-vsca
:base-value
) 3))
417 (should (= (oref eitest-vsca
:derived-value
) 4))
419 ;; should also be possible to initialize instance using virtual slot
421 (setq eitest-vscb
(virtual-slot-class :derived-value
5))
422 (should (= (oref eitest-vscb
:base-value
) 4))
423 (should (= (oref eitest-vscb
:derived-value
) 5)))
425 (ert-deftest eieio-test-18-slot-unbound
()
427 (defmethod slot-unbound ((a class-a
) &rest foo
)
428 "If a slot in A is unbound, ignore FOO."
431 (should (eq (oref eitest-a water
) 'moose
))
433 ;; Check if oset of unbound works
434 (oset eitest-a water
'moose
)
435 (should (eq (oref eitest-a water
) 'moose
))
437 ;; oref/oref-default comparison
438 (should-not (eq (oref eitest-a water
) (oref-default eitest-a water
)))
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
)))
444 ;; After setting 'water to 'moose, make sure a new object has
446 (oset-default (eieio-object-class eitest-a
) water
'penguin
)
447 (should (eq (oref (class-a) water
) 'penguin
))
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
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 :water
"a string not a symbol") :type
'invalid-slot-type
))
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))
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
)))
474 ;; Slot should be bound
475 (should (slot-boundp eitest-a
'classslot
))
476 (should (slot-boundp class-a
'classslot
))
478 (slot-makeunbound eitest-a
'classslot
)
480 (should-not (slot-boundp eitest-a
'classslot
))
481 (should-not (slot-boundp class-a
'classslot
)))
484 (defvar eieio-test-permuting-value nil
)
485 (defvar eitest-pvinit nil
)
487 (setq eieio-test-permuting-value
1))
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
)
496 "Test initforms that eval.")
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))
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)))
508 (defvar eitest-tests nil
)
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.")
516 (defclass eitest-superior nil
517 ((sub :initform
(eitest-subordinate)
518 :type eitest-subordinate
))
519 "A class with an initform that creates a class.")
521 (should (setq eitest-tests
(eitest-superior)))
525 '(defclass broken-init nil
528 "This class should break."))
529 :type
'invalid-slot-type
))
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 ;; FIXME: eieio-class-parents now returns class objects!
540 (should (equal (mapcar #'eieio-class-object
(eieio-class-parents class-ab
))
541 (mapcar #'eieio-class-object
'(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 (class-a-child-p eitest-a
))
546 (should (class-a-child-p eitest-ab
))
547 (should (not (class-a-p "foo")))
548 (should (not (class-a-child-p "foo"))))
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 (class-a-list-p listooa
))
554 (should (class-b-list-p listoob
))
555 (should-not (class-b-list-p listooa
))
556 (should-not (class-a-list-p listoob
))))
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 (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 (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 must fail
657 (should-error (oref eitest-p1 slot-2
) :type
'invalid-slot-name
)
658 ;; Access protected slot in method
659 (prot1-slot-2 eitest-p1
)
660 ;; Protected slot in subclass method
661 (prot1-slot-2 eitest-p2
)
662 ;; Protected slot from parent class method
663 (prot0-slot-2 eitest-p1
)
664 ;; Accessing private slot out of context must fail
665 (should-error (oref eitest-p1 slot-3
) :type
'invalid-slot-name
)
666 ;; Access private slot in method
667 (prot1-slot-3 eitest-p1
)
668 ;; Access private slot in subclass method must fail
669 (should-error (prot1-slot-3 eitest-p2
) :type
'invalid-slot-name
)
670 ;; Access private slot by same class
671 (prot1-slot-3-only eitest-p1
)
672 ;; Access private slot by subclass in sameclass method
673 (prot1-slot-3-only eitest-p2
))
675 ;;; eieio-instance-inheritor
676 ;; Test to make sure this works.
677 (defclass II
(eieio-instance-inheritor)
681 "Instance Inheritor test class.")
683 (defvar eitest-II1 nil
)
684 (defvar eitest-II2 nil
)
685 (defvar eitest-II3 nil
)
686 (ert-deftest eieio-test-29-instance-inheritor
()
687 (setq eitest-II1
(II "II Test."))
688 (oset eitest-II1 slot2
'cat
)
689 (setq eitest-II2
(clone eitest-II1
"eitest-II2 Test."))
690 (oset eitest-II2 slot1
'moose
)
691 (setq eitest-II3
(clone eitest-II2
"eitest-II3 Test."))
692 (oset eitest-II3 slot3
'penguin
)
694 ;; Test level 1 inheritance
695 (should (eq (oref eitest-II3 slot1
) 'moose
))
696 ;; Test level 2 inheritance
697 (should (eq (oref eitest-II3 slot2
) 'cat
))
698 ;; Test level 0 inheritance
699 (should (eq (oref eitest-II3 slot3
) 'penguin
)))
701 (defclass slotattr-base
()
702 ((initform :initform init
)
704 (initarg :initarg
:initarg
)
705 (protection :protection
:private
)
706 (custom :custom
(repeat string
)
707 :label
"Custom Strings"
709 (docstring :documentation
710 "Replace the doc-string for this property.")
711 (printer :printer printer1
)
713 "Baseclass we will attempt to subclass.
714 Subclasses to override slot attributes.")
716 (defclass slotattr-ok
(slotattr-base)
717 ((initform :initform no-init
)
718 (initarg :initarg
:initblarg
)
719 (custom :custom string
722 (docstring :documentation
723 "A better doc string for this class.")
724 (printer :printer printer2
)
726 "This class should allow overriding of various slot attributes.")
729 (ert-deftest eieio-test-30-slot-attribute-override
()
730 ;; Subclass should not override :protection slot attribute
733 '(defclass slotattr-fail
(slotattr-base)
734 ((protection :protection
:public
)
736 "This class should throw an error.")))
738 ;; Subclass should not override :type slot attribute
741 '(defclass slotattr-fail
(slotattr-base)
744 "This class should throw an error.")))
746 ;; Initform should override instance allocation
747 (let ((obj (slotattr-ok)))
748 (should (eq (oref obj initform
) 'no-init
))))
750 (defclass slotattr-class-base
()
751 ((initform :allocation
:class
753 (type :allocation
:class
755 (initarg :allocation
:class
757 (protection :allocation
:class
758 :protection
:private
)
759 (custom :allocation
:class
760 :custom
(repeat string
)
761 :label
"Custom Strings"
763 (docstring :allocation
:class
765 "Replace the doc-string for this property.")
767 "Baseclass we will attempt to subclass.
768 Subclasses to override slot attributes.")
770 (defclass slotattr-class-ok
(slotattr-class-base)
771 ((initform :initform no-init
)
772 (initarg :initarg
:initblarg
)
773 (custom :custom string
776 (docstring :documentation
777 "A better doc string for this class.")
779 "This class should allow overriding of various slot attributes.")
782 (ert-deftest eieio-test-31-slot-attribute-override-class-allocation
()
783 ;; Same as test-30, but with class allocation
786 '(defclass slotattr-fail
(slotattr-class-base)
787 ((protection :protection
:public
)
789 "This class should throw an error.")))
792 '(defclass slotattr-fail
(slotattr-class-base)
795 "This class should throw an error.")))
796 (should (eq (oref-default slotattr-class-ok initform
) 'no-init
)))
798 (ert-deftest eieio-test-32-slot-attribute-override-2
()
799 (let* ((cv (eieio--class-v 'slotattr-ok
))
800 (docs (eieio--class-public-doc cv
))
801 (names (eieio--class-public-a cv
))
802 (cust (eieio--class-public-custom cv
))
803 (label (eieio--class-public-custom-label cv
))
804 (group (eieio--class-public-custom-group cv
))
805 (types (eieio--class-public-type cv
))
806 (args (eieio--class-initarg-tuples cv
))
808 ;; :initarg should override for subclass
809 (should (assoc :initblarg args
))
811 (while (< i
(length names
))
813 ((eq (nth i names
) 'custom
)
814 ;; Custom slot attributes must override
815 (should (eq (nth i cust
) 'string
))
816 ;; Custom label slot attribute must override
817 (should (string= (nth i label
) "One String"))
818 (let ((grp (nth i group
)))
819 ;; Custom group slot attribute must combine
820 (should (and (memq 'moose grp
) (memq 'cow grp
)))))
825 (defvar eitest-CLONETEST1 nil
)
826 (defvar eitest-CLONETEST2 nil
)
828 (ert-deftest eieio-test-32-test-clone-boring-objects
()
829 ;; A simple make instance with EIEIO extension
830 (should (setq eitest-CLONETEST1
(make-instance 'class-a
)))
831 (should (setq eitest-CLONETEST2
(clone eitest-CLONETEST1
)))
833 ;; CLOS form of make-instance
834 (should (setq eitest-CLONETEST1
(make-instance 'class-a
)))
835 (should (setq eitest-CLONETEST2
(clone eitest-CLONETEST1
))))
837 (defclass IT
(eieio-instance-tracker)
838 ((tracking-symbol :initform IT-list
)
839 (slot1 :initform
'die
))
840 "Instance Tracker test object.")
842 (ert-deftest eieio-test-33-instance-tracker
()
844 (should (setq IT1
(IT)))
845 ;; The instance tracker must find this
846 (should (eieio-instance-tracker-find 'die
'slot1
'IT-list
))
848 (delete-instance IT1
)
849 (should-not (eieio-instance-tracker-find 'die
'slot1
'IT-list
))))
851 (defclass SINGLE
(eieio-singleton)
852 ((a-slot :initarg
:a-slot
:initform t
))
853 "A Singleton test object.")
855 (ert-deftest eieio-test-34-singletons
()
856 (let ((obj1 (SINGLE))
858 (should (eieio-object-p obj1
))
859 (should (eieio-object-p obj2
))
860 (should (eq obj1 obj2
))
861 (should (oref obj1 a-slot
))))
863 (defclass NAMED
(eieio-named)
864 ((some-slot :initform nil
)
866 "A class inheriting from eieio-named.")
868 (ert-deftest eieio-test-35-named-object
()
870 (should (setq N
(NAMED :object-name
"Foo")))
871 (should (string= "Foo" (oref N object-name
)))
872 (should-error (oref N missing-slot
) :type
'invalid-slot-name
)
873 (oset N object-name
"NewName")
874 (should (string= "NewName" (oref N object-name
)))))
876 (defclass opt-test1
()
878 "Abstract base class"
881 (defclass opt-test2
(opt-test1)
883 "Instantiable child")
885 (ert-deftest eieio-test-36-build-class-alist
()
886 (should (= (length (eieio-build-class-alist opt-test1 nil
)) 2))
887 (should (= (length (eieio-build-class-alist opt-test1 t
)) 1)))
889 (provide 'eieio-tests
)
891 ;;; eieio-tests.el ends here
894 ;; no-byte-compile: t