Commit | Line | Data |
---|---|---|
6ee60310 DE |
1 | ;;; eieio-tests.el -- eieio tests routines |
2 | ||
5bca8dfb | 3 | ;; Copyright (C) 1999-2003, 2005-2010, 2012-2014 Free Software Foundation, Inc. |
6ee60310 DE |
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: | |
b73517d9 | 23 | ;; |
6ee60310 DE |
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 | |
b73517d9 | 68 | :documentation "First slot testing slot arguments." |
6ee60310 DE |
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 | |
b73517d9 | 168 | (defgeneric anormalfunction () |
6ee60310 DE |
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 | |
b73517d9 | 591 | ;; the original value. |
6ee60310 DE |
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. | |
b73517d9 | 606 | Needed by the eieio persistent base class." |
6ee60310 DE |
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) | |
b73517d9 | 664 | ;; Access private slot in method |
6ee60310 DE |
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) | |
b73517d9 | 715 | ((initform :initform no-init) |
6ee60310 DE |
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) | |
b73517d9 | 769 | ((initform :initform no-init) |
6ee60310 DE |
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 | ||
6ee60310 DE |
887 | (provide 'eieio-tests) |
888 | ||
889 | ;;; eieio-tests.el ends here | |
5bca8dfb GM |
890 | |
891 | ;; Local Variables: | |
892 | ;; no-byte-compile: t | |
893 | ;; End: |