mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-03 08:30:09 +00:00
Code Issues Releases Activity

merge from trunk

Browse Source
This commit is contained in:
Joakim Verona 2013-08-21 21:56:47 +02:00
commit 3b6a2946d0
4 changed files with 1491 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
test/ChangeLog
View File

@ -1,3 +1,9 @@
2013-08-21 David Engster <deng@randomsample.de>
* automated/eieio-tests.el, automated/eieio-test-persist.el:
* automated/eieio-test-methodinvoke.el: EIEIO tests from CEDET
upstream. Changed to use ERT.
2013-08-14 Daniel Hackney <dan@haxney.org>
* package-test.el: Remove tar-package-building functions. Tar file

379
test/automated/eieio-test-methodinvoke.el Normal file
View File

@ -0,0 +1,379 @@
;;; eieio-testsinvoke.el -- eieio tests for method invokation
;; Copyright (C) 2005, 2008, 2010, 2013 Free Software Foundation, Inc.
;; Author: Eric. M. Ludlam <zappo@gnu.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Test method invocation order. From the common lisp reference
;; manual:
;;
;; QUOTE:
;; - All the :before methods are called, in most-specific-first
;; order. Their values are ignored. An error is signaled if
;; call-next-method is used in a :before method.
;;
;; - The most specific primary method is called. Inside the body of a
;; primary method, call-next-method may be used to call the next
;; most specific primary method. When that method returns, the
;; previous primary method can execute more code, perhaps based on
;; the returned value or values. The generic function no-next-method
;; is invoked if call-next-method is used and there are no more
;; applicable primary methods. The function next-method-p may be
;; used to determine whether a next method exists. If
;; call-next-method is not used, only the most specific primary
;; method is called.
;;
;; - All the :after methods are called, in most-specific-last order.
;; Their values are ignored. An error is signaled if
;; call-next-method is used in a :after method.
;;
;;
;; Also test behavior of `call-next-method'. From clos.org:
;;
;; QUOTE:
;; When call-next-method is called with no arguments, it passes the
;; current method's original arguments to the next method.
(require 'eieio)
(require 'ert)
(defvar eieio-test-method-order-list nil
"List of symbols stored during method invocation.")
(defun eieio-test-method-store ()
"Store current invocation class symbol in the invocation order list."
(let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
(or eieio-generic-call-key 0)))
(c (list eieio-generic-call-methodname keysym (eieio--scoped-class))))
(setq eieio-test-method-order-list
(cons c eieio-test-method-order-list))))
(defun eieio-test-match (rightanswer)
"Do a test match."
(if (equal rightanswer eieio-test-method-order-list)
t
(error "eieio-test-methodinvoke.el: Test Failed!")))
(defvar eieio-test-call-next-method-arguments nil
"List of passed to methods during execution of `call-next-method'.")
(defun eieio-test-arguments-for (class)
"Returns arguments passed to method of CLASS during `call-next-method'."
(cdr (assoc class eieio-test-call-next-method-arguments)))
(defclass eitest-A () ())
(defclass eitest-AA (eitest-A) ())
(defclass eitest-AAA (eitest-AA) ())
(defclass eitest-B-base1 () ())
(defclass eitest-B-base2 () ())
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
(defmethod eitest-F :BEFORE ((p eitest-B-base1))
(eieio-test-method-store))
(defmethod eitest-F :BEFORE ((p eitest-B-base2))
(eieio-test-method-store))
(defmethod eitest-F :BEFORE ((p eitest-B))
(eieio-test-method-store))
(defmethod eitest-F ((p eitest-B))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base1))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base2))
(eieio-test-method-store)
(when (next-method-p)
(call-next-method))
)
(defmethod eitest-F :AFTER ((p eitest-B-base1))
(eieio-test-method-store))
(defmethod eitest-F :AFTER ((p eitest-B-base2))
(eieio-test-method-store))
(defmethod eitest-F :AFTER ((p eitest-B))
(eieio-test-method-store))
(ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(eitest-F :BEFORE eitest-B)
(eitest-F :BEFORE eitest-B-base1)
(eitest-F :BEFORE eitest-B-base2)
(eitest-F :PRIMARY eitest-B)
(eitest-F :PRIMARY eitest-B-base1)
(eitest-F :PRIMARY eitest-B-base2)
(eitest-F :AFTER eitest-B-base2)
(eitest-F :AFTER eitest-B-base1)
(eitest-F :AFTER eitest-B)
)))
(eitest-F (eitest-B nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Test static invokation
;;
(defmethod eitest-H :STATIC ((class eitest-A))
"No need to do work in here."
'moose)
(ert-deftest eieio-test-method-order-list-4 ()
;; Both of these situations should succeed.
(should (eitest-H eitest-A))
(should (eitest-H (eitest-A nil))))
;;; Return value from :PRIMARY
;;
(defmethod eitest-I :BEFORE ((a eitest-A))
(eieio-test-method-store)
":before")
(defmethod eitest-I :PRIMARY ((a eitest-A))
(eieio-test-method-store)
":primary")
(defmethod eitest-I :AFTER ((a eitest-A))
(eieio-test-method-store)
":after")
(ert-deftest eieio-test-method-order-list-5 ()
(let ((eieio-test-method-order-list nil)
(ans (eitest-I (eitest-A nil))))
(should (string= ans ":primary"))))
;;; Multiple inheritance and the 'constructor' method.
;;
;; Constructor is a static method, so this is really testing
;; static method invocation and multiple inheritance.
;;
(defclass C-base1 () ())
(defclass C-base2 () ())
(defclass C (C-base1 C-base2) ())
(defmethod constructor :STATIC ((p C-base1) &rest args)
(eieio-test-method-store)
(if (next-method-p) (call-next-method))
)
(defmethod constructor :STATIC ((p C-base2) &rest args)
(eieio-test-method-store)
(if (next-method-p) (call-next-method))
)
(defmethod constructor :STATIC ((p C) &rest args)
(eieio-test-method-store)
(call-next-method)
)
(ert-deftest eieio-test-method-order-list-6 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(constructor :STATIC C)
(constructor :STATIC C-base1)
(constructor :STATIC C-base2)
)))
(C nil)
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Diamond Test
;;
;; For a diamond shaped inheritance structure, (call-next-method) can break.
;; As such, there are two possible orders.
(defclass D-base0 () () :method-invocation-order :depth-first)
(defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
(defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
(defmethod eitest-F ((p D))
"D"
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p D-base0))
"D-base0"
(eieio-test-method-store)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p D-base1))
"D-base1"
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p D-base2))
"D-base2"
(eieio-test-method-store)
(when (next-method-p)
(call-next-method))
)
(ert-deftest eieio-test-method-order-list-7 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(eitest-F :PRIMARY D)
(eitest-F :PRIMARY D-base1)
;; (eitest-F :PRIMARY D-base2)
(eitest-F :PRIMARY D-base0)
)))
(eitest-F (D nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Other invocation order
(defclass E-base0 () () :method-invocation-order :breadth-first)
(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
(defmethod eitest-F ((p E))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p E-base0))
(eieio-test-method-store)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p E-base1))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p E-base2))
(eieio-test-method-store)
(when (next-method-p)
(call-next-method))
)
(ert-deftest eieio-test-method-order-list-8 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(eitest-F :PRIMARY E)
(eitest-F :PRIMARY E-base1)
(eitest-F :PRIMARY E-base2)
(eitest-F :PRIMARY E-base0)
)))
(eitest-F (E nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
;;
(defclass eitest-Ja ()
())
(defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
;(message "+Ja")
(when (next-method-p)
(call-next-method))
;(message "-Ja")
)
(defclass eitest-Jb ()
())
(defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
;(message "+Jb")
(when (next-method-p)
(call-next-method))
;(message "-Jb")
)
(defclass eitest-Jc (eitest-Jb)
())
(defclass eitest-Jd (eitest-Jc eitest-Ja)
())
(defmethod initialize-instance ((this eitest-Jd) &rest slots)
;(message "+Jd")
(when (next-method-p)
(call-next-method))
;(message "-Jd")
)
(ert-deftest eieio-test-method-order-list-9 ()
(should (eitest-Jd "test")))
;;; call-next-method with replacement arguments across a simple class hierarchy.
;;
(defclass CNM-0 ()
())
(defclass CNM-1-1 (CNM-0)
())
(defclass CNM-1-2 (CNM-0)
())
(defclass CNM-2 (CNM-1-1 CNM-1-2)
())
(defmethod CNM-M ((this CNM-0) args)
(push (cons 'CNM-0 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method
this (cons 'CNM-0 args))))
(defmethod CNM-M ((this CNM-1-1) args)
(push (cons 'CNM-1-1 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method
this (cons 'CNM-1-1 args))))
(defmethod CNM-M ((this CNM-1-2) args)
(push (cons 'CNM-1-2 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method)))
(defmethod CNM-M ((this CNM-2) args)
(push (cons 'CNM-2 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method
this (cons 'CNM-2 args))))
(ert-deftest eieio-test-method-order-list-10 ()
(let ((eieio-test-call-next-method-arguments nil))
(CNM-M (CNM-2 "") '(INIT))
(should (equal (eieio-test-arguments-for 'CNM-0)
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-1-1)
'(CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-1-2)
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-2)
'(INIT)))))

213
test/automated/eieio-test-persist.el Normal file
View File

@ -0,0 +1,213 @@
;;; eieio-persist.el --- Tests for eieio-persistent class
;; Copyright (C) 2011-2013 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; The eieio-persistent base-class provides a vital service, that
;; could be used to accidentally load in malicious code. As such,
;; something as simple as calling eval on the generated code can't be
;; used. These tests exercises various flavors of data that might be
;; in a persistent object, and tries to save/load them.
;;; Code:
(require 'eieio)
(require 'eieio-base)
(require 'ert)
(defun persist-test-save-and-compare (original)
"Compare the object ORIGINAL against the one read fromdisk."
(eieio-persistent-save original)
(let* ((file (oref original :file))
(class (eieio-object-class original))
(fromdisk (eieio-persistent-read file class))
(cv (class-v class))
(slot-names (eieio--class-public-a cv))
(slot-deflt (eieio--class-public-d cv))
)
(unless (object-of-class-p fromdisk class)
(error "Persistent class %S != original class %S"
(eieio-object-class fromdisk)
class))
(while slot-names
(let* ((oneslot (car slot-names))
(origvalue (eieio-oref original oneslot))
(fromdiskvalue (eieio-oref fromdisk oneslot))
(initarg-p (eieio-attribute-to-initarg class oneslot))
)
(if initarg-p
(unless (equal origvalue fromdiskvalue)
(error "Slot %S Original Val %S != Persistent Val %S"
oneslot origvalue fromdiskvalue))
;; Else !initarg-p
(unless (equal (car slot-deflt) fromdiskvalue)
(error "Slot %S Persistent Val %S != Default Value %S"
oneslot fromdiskvalue (car slot-deflt))))
(setq slot-names (cdr slot-names)
slot-deflt (cdr slot-deflt))
))))
;;; Simple Case
;;
;; Simplest case is a mix of slots with and without initargs.
(defclass persist-simple (eieio-persistent)
((slot1 :initarg :slot1
:type symbol
:initform moose)
(slot2 :initarg :slot2
:initform "foo")
(slot3 :initform 2))
"A Persistent object with two initializable slots, and one not.")
(ert-deftest eieio-test-persist-simple-1 ()
(let ((persist-simple-1
(persist-simple "simple 1" :slot1 'goose :slot2 "testing"
:file (concat default-directory "test-ps1.pt"))))
(should persist-simple-1)
;; When the slot w/out an initarg has not been changed
(persist-test-save-and-compare persist-simple-1)
;; When the slot w/out an initarg HAS been changed
(oset persist-simple-1 slot3 3)
(persist-test-save-and-compare persist-simple-1)
(delete-file (oref persist-simple-1 file))))
;;; Slot Writers
;;
;; Replica of the test in eieio-tests.el -
(defclass persist-:printer (eieio-persistent)
((slot1 :initarg :slot1
:initform 'moose
:printer PO-slot1-printer)
(slot2 :initarg :slot2
:initform "foo"))
"A Persistent object with two initializable slots.")
(defun PO-slot1-printer (slotvalue)
"Print the slot value SLOTVALUE to stdout.
Assume SLOTVALUE is a symbol of some sort."
(princ "'")
(princ (symbol-name slotvalue))
(princ " ;; RAN PRINTER")
nil)
(ert-deftest eieio-test-persist-printer ()
(let ((persist-:printer-1
(persist-:printer "persist" :slot1 'goose :slot2 "testing"
:file (concat default-directory "test-ps2.pt"))))
(should persist-:printer-1)
(persist-test-save-and-compare persist-:printer-1)
(let* ((find-file-hook nil)
(tbuff (find-file-noselect "test-ps2.pt"))
)
(condition-case nil
(unwind-protect
(with-current-buffer tbuff
(goto-char (point-min))
(re-search-forward "RAN PRINTER"))
(kill-buffer tbuff))
(error "persist-:printer-1's Slot1 printer function didn't work.")))
(delete-file (oref persist-:printer-1 file))))
;;; Slot with Object
;;
;; A slot that contains another object that isn't persistent
(defclass persist-not-persistent ()
((slot1 :initarg :slot1
:initform 1)
(slot2 :initform 2))
"Class for testing persistent saving of an object that isn't
persistent. This class is instead used as a slot value in a
persistent class.")
(defclass persistent-with-objs-slot (eieio-persistent)
((pnp :initarg :pnp
:type (or null persist-not-persistent)
:initform nil))
"Class for testing the saving of slots with objects in them.")
(ert-deftest eieio-test-non-persistent-as-slot ()
(let ((persist-wos
(persistent-with-objs-slot
"persist wos 1"
:pnp (persist-not-persistent "pnp 1" :slot1 3)
:file (concat default-directory "test-ps3.pt"))))
(persist-test-save-and-compare persist-wos)
(delete-file (oref persist-wos file))))
;;; Slot with Object child of :type
;;
;; A slot that contains another object that isn't persistent
(defclass persist-not-persistent-subclass (persist-not-persistent)
((slot3 :initarg :slot1
:initform 1)
(slot4 :initform 2))
"Class for testing persistent saving of an object subclass that isn't
persistent. This class is instead used as a slot value in a
persistent class.")
(defclass persistent-with-objs-slot-subs (eieio-persistent)
((pnp :initarg :pnp
:type (or null persist-not-persistent-child)
:initform nil))
"Class for testing the saving of slots with objects in them.")
(ert-deftest eieio-test-non-persistent-as-slot-child ()
(let ((persist-woss
(persistent-with-objs-slot-subs
"persist woss 1"
:pnp (persist-not-persistent-subclass "pnps 1" :slot1 3)
:file (concat default-directory "test-ps4.pt"))))
(persist-test-save-and-compare persist-woss)
(delete-file (oref persist-woss file))))
;;; Slot with a list of Objects
;;
;; A slot that contains another object that isn't persistent
(defclass persistent-with-objs-list-slot (eieio-persistent)
((pnp :initarg :pnp
:type persist-not-persistent-list
:initform nil))
"Class for testing the saving of slots with objects in them.")
(ert-deftest eieio-test-slot-with-list-of-objects ()
(let ((persist-wols
(persistent-with-objs-list-slot
"persist wols 1"
:pnp (list (persist-not-persistent "pnp 1" :slot1 3)
(persist-not-persistent "pnp 2" :slot1 4)
(persist-not-persistent "pnp 3" :slot1 5))
:file (concat default-directory "test-ps5.pt"))))
(persist-test-save-and-compare persist-wols)
(delete-file (oref persist-wols file))))
;;; eieio-test-persist.el ends here

893
test/automated/eieio-tests.el Normal file
View File

@ -0,0 +1,893 @@
;;; eieio-tests.el -- eieio tests routines
;; Copyright (C) 1999-2003, 2005-2010, 2012-2013 Free Software
;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Test the various features of EIEIO.
(require 'ert)
(require 'eieio)
(require 'eieio-base)
(require 'eieio-opt)
(eval-when-compile (require 'cl))
;;; Code:
;; Set up some test classes
(defclass class-a ()
((water :initarg :water
:initform h20
:type symbol
:documentation "Detail about water.")
(classslot :initform penguin
:type symbol
:documentation "A class allocated slot."
:allocation :class)
(test-tag :initform nil
:documentation "Used to make sure methods are called.")
(self :initform nil
:type (or null class-a)
:documentation "Test self referencing types.")
)
"Class A")
(defclass class-b ()
((land :initform "Sc"
:type string
:documentation "Detail about land."))
"Class B")
(defclass class-ab (class-a class-b)
((amphibian :initform "frog"
:documentation "Detail about amphibian on land and water."))
"Class A and B combined.")
(defclass class-c ()
((slot-1 :initarg :moose
:initform moose
:type symbol
:allocation :instance
:documentation "Fisrt slot testing slot arguments."
:custom symbol
:label "Wild Animal"
:group borg
:protection :public)
(slot-2 :initarg :penguin
:initform "penguin"
:type string
:allocation :instance
:documentation "Second slot testing slot arguments."
:custom string
:label "Wild bird"
:group vorlon
:accessor get-slot-2
:protection :private)
(slot-3 :initarg :emu
:initform emu
:type symbol
:allocation :class
:documentation "Third slot test class allocated accessor"
:custom symbol
:label "Fuzz"
:group tokra
:accessor get-slot-3
:protection :private)
)
(:custom-groups (foo))
"A class for testing slot arguments."
)
(defclass class-subc (class-c)
((slot-1 ;; :initform moose - don't override this
)
(slot-2 :initform "linux" ;; Do override this one
:protection :private
))
"A class for testing slot arguments.")
;;; Defining a class with a slot tag error
;;
;; Temporarily disable this test because of macro expansion changes in
;; current Emacs trunk. It can be re-enabled when we have moved
;; `eieio-defclass' into the `defclass' macro and the
;; `eval-and-compile' there is removed.
;; (let ((eieio-error-unsupported-class-tags t))
;; (condition-case nil
;; (progn
;; (defclass class-error ()
;; ((error-slot :initarg :error-slot
;; :badslottag 1))
;; "A class with a bad slot tag.")
;; (error "No error was thrown for badslottag"))
;; (invalid-slot-type nil)))
;; (let ((eieio-error-unsupported-class-tags nil))
;; (condition-case nil
;; (progn
;; (defclass class-error ()
;; ((error-slot :initarg :error-slot
;; :badslottag 1))
;; "A class with a bad slot tag."))
;; (invalid-slot-type
;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil")
;; )))
(ert-deftest eieio-test-01-mix-alloc-initarg ()
;; Only run this test if the message framework thingy works.
(when (and (message "foo") (string= "foo" (current-message)))
;; Defining this class should generate a warning(!) message that
;; you should not mix :initarg with class allocated slots.
(defclass class-alloc-initarg ()
((throwwarning :initarg :throwwarning
:allocation :class))
"Throw a warning mixing allocation class and an initarg.")
;; Check that message is there
(should (current-message))
(should (string-match "Class allocated slots do not need :initarg"
(current-message)))))
(defclass abstract-class ()
((some-slot :initarg :some-slot
:initform nil
:documentation "A slot."))
:documentation "An abstract class."
:abstract t)
(ert-deftest eieio-test-02-abstract-class ()
;; Abstract classes cannot be instantiated, so this should throw an
;; error
(should-error (abstract-class "Test")))
(defgeneric generic1 () "First generic function")
(ert-deftest eieio-test-03-generics ()
(defun anormalfunction () "A plain function for error testing." nil)
(should-error
(progn
(defgeneric anormalfunction ()
"Attempt to turn it into a generic.")))
;; Check that generic-p works
(should (generic-p 'generic1))
(defmethod generic1 ((c class-a))
"Method on generic1."
'monkey)
(defmethod generic1 (not-an-object)
"Method generic1 that can take a non-object."
not-an-object)
(let ((ans-obj (generic1 (class-a "test")))
(ans-num (generic1 666)))
(should (eq ans-obj 'monkey))
(should (eq ans-num 666))))
(defclass static-method-class ()
((some-slot :initform nil
:allocation :class
:documentation "A slot."))
:documentation "A class used for testing static methods.")
(defmethod static-method-class-method :STATIC ((c static-method-class) value)
"Test static methods.
Argument C is the class bound to this static method."
(if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot value))
(ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked
(static-method-class-method static-method-class 'class)
(should (eq (oref static-method-class some-slot) 'class))
(static-method-class-method (static-method-class "test") 'object)
(should (eq (oref static-method-class some-slot) 'object)))
(ert-deftest eieio-test-05-static-method-2 ()
(defclass static-method-class-2 (static-method-class)
()
"A second class after the previous for static methods.")
(defmethod static-method-class-method :STATIC ((c static-method-class-2) value)
"Test static methods.
Argument C is the class bound to this static method."
(if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
(static-method-class-method static-method-class-2 'class)
(should (eq (oref static-method-class-2 some-slot) 'moose-class))
(static-method-class-method (static-method-class-2 "test") 'object)
(should (eq (oref static-method-class-2 some-slot) 'moose-object)))
;;; Perform method testing
;;
;;; Multiple Inheritance, and method signal testing
;;
(defvar eitest-ab nil)
(defvar eitest-a nil)
(defvar eitest-b nil)
(ert-deftest eieio-test-06-allocate-objects ()
;; allocate an object to use
(should (setq eitest-ab (class-ab "abby")))
(should (setq eitest-a (class-a "aye")))
(should (setq eitest-b (class-b "fooby"))))
(ert-deftest eieio-test-07-make-instance ()
(should (make-instance 'class-ab))
(should (make-instance 'class-a :water 'cho))
(should (make-instance 'class-b "a name")))
(defmethod class-cn ((a class-a))
"Try calling `call-next-method' when there isn't one.
Argument A is object of type symbol `class-a'."
(call-next-method))
(defmethod no-next-method ((a class-a) &rest args)
"Override signal throwing for variable `class-a'.
Argument A is the object of class variable `class-a'."
'moose)
(ert-deftest eieio-test-08-call-next-method ()
;; Play with call-next-method
(should (eq (class-cn eitest-ab) 'moose)))
(defmethod no-applicable-method ((b class-b) method &rest args)
"No need.
Argument B is for booger.
METHOD is the method that was attempting to be called."
'moose)
(ert-deftest eieio-test-09-no-applicable-method ()
;; Non-existing methods.
(should (eq (class-cn eitest-b) 'moose)))
(defmethod class-fun ((a class-a))
"Fun with class A."
'moose)
(defmethod class-fun ((b class-b))
"Fun with class B."
(error "Class B fun should not be called")
)
(defmethod class-fun-foo ((b class-b))
"Foo Fun with class B."
'moose)
(defmethod class-fun2 ((a class-a))
"More fun with class A."
'moose)
(defmethod class-fun2 ((b class-b))
"More fun with class B."
(error "Class B fun2 should not be called")
)
(defmethod class-fun2 ((ab class-ab))
"More fun with class AB."
(call-next-method))
;; How about if B is the only slot?
(defmethod class-fun3 ((b class-b))
"Even More fun with class B."
'moose)
(defmethod class-fun3 ((ab class-ab))
"Even More fun with class AB."
(call-next-method))
(ert-deftest eieio-test-10-multiple-inheritance ()
;; play with methods and mi
(should (eq (class-fun eitest-ab) 'moose))
(should (eq (class-fun-foo eitest-ab) 'moose))
;; Play with next-method and mi
(should (eq (class-fun2 eitest-ab) 'moose))
(should (eq (class-fun3 eitest-ab) 'moose)))
(ert-deftest eieio-test-11-self ()
;; Try the self referencing test
(should (oset eitest-a self eitest-a))
(should (oset eitest-ab self eitest-ab)))
(defvar class-fun-value-seq '())
(defmethod class-fun-value :BEFORE ((a class-a))
"Return `before', and push `before' in `class-fun-value-seq'."
(push 'before class-fun-value-seq)
'before)
(defmethod class-fun-value :PRIMARY ((a class-a))
"Return `primary', and push `primary' in `class-fun-value-seq'."
(push 'primary class-fun-value-seq)
'primary)
(defmethod class-fun-value :AFTER ((a class-a))
"Return `after', and push `after' in `class-fun-value-seq'."
(push 'after class-fun-value-seq)
'after)
(ert-deftest eieio-test-12-generic-function-call ()
;; Test value of a generic function call
;;
(let* ((class-fun-value-seq nil)
(value (class-fun-value eitest-a)))
;; Test if generic function call returns the primary method's value
(should (eq value 'primary))
;; Make sure :before and :after methods were run
(should (equal class-fun-value-seq '(after primary before)))))
;;; Test initialization methods
;;
(ert-deftest eieio-test-13-init-methods ()
(defmethod initialize-instance ((a class-a) &rest slots)
"Initialize the slots of class-a."
(call-next-method)
(if (/= (oref a test-tag) 1)
(error "shared-initialize test failed."))
(oset a test-tag 2))
(defmethod shared-initialize ((a class-a) &rest slots)
"Shared initialize method for class-a."
(call-next-method)
(oset a test-tag 1))
(let ((ca (class-a "class act")))
(should-not (/= (oref ca test-tag) 2))))
;;; Perform slot testing
;;
(ert-deftest eieio-test-14-slots ()
;; Check slot existence
(should (oref eitest-ab water))
(should (oref eitest-ab land))
(should (oref eitest-ab amphibian)))
(ert-deftest eieio-test-15-slot-missing ()
(defmethod slot-missing ((ab class-ab) &rest foo)
"If a slot in AB is unbound, return something cool. FOO."
'moose)
(should (eq (oref eitest-ab ooga-booga) 'moose))
(should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name))
(ert-deftest eieio-test-16-slot-makeunbound ()
(slot-makeunbound eitest-a 'water)
;; Should now be unbound
(should-not (slot-boundp eitest-a 'water))
;; But should still exist
(should (slot-exists-p eitest-a 'water))
(should-not (slot-exists-p eitest-a 'moose))
;; oref of unbound slot must fail
(should-error (oref eitest-a water) :type 'unbound-slot))
(defvar eitest-vsca nil)
(defvar eitest-vscb nil)
(defclass virtual-slot-class ()
((base-value :initarg :base-value))
"Class has real slot :base-value and simulated slot :derived-value.")
(defmethod slot-missing ((vsc virtual-slot-class)
slot-name operation &optional new-value)
"Simulate virtual slot derived-value."
(cond
((or (eq slot-name :derived-value)
(eq slot-name 'derived-value))
(with-slots (base-value) vsc
(if (eq operation 'oref)
(+ base-value 1)
(setq base-value (- new-value 1)))))
(t (call-next-method))))
(ert-deftest eieio-test-17-virtual-slot ()
(setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1))
;; Check slot values
(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))
(should (= (oref eitest-vsca :derived-value) 3))
(oset eitest-vsca :base-value 3)
(should (= (oref eitest-vsca :base-value) 3))
(should (= (oref eitest-vsca :derived-value) 4))
;; should also be possible to initialize instance using virtual slot
(setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5))
(should (= (oref eitest-vscb :base-value) 4))
(should (= (oref eitest-vscb :derived-value) 5)))
(ert-deftest eieio-test-18-slot-unbound ()
(defmethod slot-unbound ((a class-a) &rest foo)
"If a slot in A is unbound, ignore FOO."
'moose)
(should (eq (oref eitest-a water) 'moose))
;; Check if oset of unbound works
(oset eitest-a water 'moose)
(should (eq (oref eitest-a water) 'moose))
;; oref/oref-default comparison
(should-not (eq (oref eitest-a water) (oref-default eitest-a water)))
;; oset-default -> oref/oref-default comparison
(oset-default (eieio-object-class eitest-a) water 'moose)
(should (eq (oref eitest-a water) (oref-default eitest-a water)))
;; After setting 'water to 'moose, make sure a new object has
;; the right stuff.
(oset-default (eieio-object-class eitest-a) water 'penguin)
(should (eq (oref (class-a "foo") water) 'penguin))
;; Revert the above
(defmethod slot-unbound ((a class-a) &rest foo)
"If a slot in A is unbound, ignore FOO."
;; Disable the old slot-unbound so we can run this test
;; more than once
(call-next-method)))
(ert-deftest eieio-test-19-slot-type-checking ()
;; Slot type checking
;; We should not be able to set a string here
(should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
(should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
(should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type))
(ert-deftest eieio-test-20-class-allocated-slots ()
;; Test out class allocated slots
(defvar eitest-aa nil)
(setq eitest-aa (class-a "another"))
;; Make sure class slots do not track between objects
(let ((newval 'moose))
(oset eitest-aa classslot newval)
(should (eq (oref eitest-a classslot) newval))
(should (eq (oref eitest-aa classslot) newval)))
;; Slot should be bound
(should (slot-boundp eitest-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)))
(defvar eieio-test-permuting-value nil)
(defvar eitest-pvinit nil)
(eval-and-compile
(setq eieio-test-permuting-value 1))
(defclass inittest nil
((staticval :initform 1)
(symval :initform eieio-test-permuting-value)
(evalval :initform (symbol-value 'eieio-test-permuting-value))
(evalnow :initform (symbol-value 'eieio-test-permuting-value)
:allocation :class)
)
"Test initforms that eval.")
(ert-deftest eieio-test-21-eval-at-construction-time ()
;; initforms that need to be evalled at construction time.
(setq eieio-test-permuting-value 2)
(setq eitest-pvinit (inittest "permuteme"))
(should (eq (oref eitest-pvinit staticval) 1))
(should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
(should (eq (oref eitest-pvinit evalval) 2))
(should (eq (oref eitest-pvinit evalnow) 1)))
(defvar eitest-tests nil)
(ert-deftest eieio-test-22-init-forms-dont-match-runnable ()
;; Init forms with types that don't match the runnable.
(defclass eitest-subordinate nil
((text :initform "" :type string))
"Test class that will be a calculated value.")
(defclass eitest-superior nil
((sub :initform (eitest-subordinate "test")
:type eitest-subordinate))
"A class with an initform that creates a class.")
(should (setq eitest-tests (eitest-superior "test")))
(should-error
(eval
'(defclass broken-init nil
((broken :initform 1
:type string))
"This class should break."))
:type 'invalid-slot-type))
(ert-deftest eieio-test-23-inheritance-check ()
(should (child-of-class-p class-ab class-a))
(should (child-of-class-p class-ab class-b))
(should (object-of-class-p eitest-a class-a))
(should (object-of-class-p eitest-ab class-a))
(should (object-of-class-p eitest-ab class-b))
(should (object-of-class-p eitest-ab class-ab))
(should (eq (eieio-class-parents class-a) nil))
(should (equal (eieio-class-parents class-ab) '(class-a class-b)))
(should (same-class-p eitest-a class-a))
(should (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 (not (class-a-p "foo")))
(should (not (class-a-child-p "foo"))))
(ert-deftest eieio-test-24-object-predicates ()
(let ((listooa (list (class-ab "ab") (class-a "a")))
(listoob (list (class-ab "ab") (class-b "b"))))
(should (class-a-list-p listooa))
(should (class-b-list-p listoob))
(should-not (class-b-list-p listooa))
(should-not (class-a-list-p listoob))))
(defvar eitest-t1 nil)
(ert-deftest eieio-test-25-slot-tests ()
(setq eitest-t1 (class-c "C1"))
;; Slot initialization
(should (eq (oref eitest-t1 slot-1) 'moose))
(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)
;; Check private slot accessor
(should (string= (get-slot-2 eitest-t1) "penguin"))
;; Pass string instead of symbol
(should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type)
(should (eq (get-slot-3 eitest-t1) '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))
;; Roll back
(setf (get-slot-3 eitest-t1) 'emu))
(defvar eitest-t2 nil)
(ert-deftest eieio-test-26-default-inheritance ()
;; See previous test, nor for subclass
(setq eitest-t2 (class-subc "subc"))
(should (eq (oref eitest-t2 slot-1) 'moose))
(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)
(should (string= (get-slot-2 eitest-t2) "linux"))
(should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type))
;;(ert-deftest eieio-test-27-inherited-new-value ()
;;; HACK ALERT: The new value of a class slot is inherited by the
;; subclass! This is probably a bug. We should either share the slot
;; so sets on the baseclass change the subclass, or we should inherit
;; the original value.
;; (should (eq (get-slot-3 eitest-t2) 'emu))
;; (should (eq (get-slot-3 class-subc) 'emu))
;; (setf (get-slot-3 eitest-t2) 'setf-emu)
;; (should (eq (get-slot-3 eitest-t2) 'setf-emu)))
;; Slot protection
(defclass prot-0 ()
()
"Protection testing baseclass.")
(defmethod prot0-slot-2 ((s2 prot-0))
"Try to access slot-2 from this class which doesn't have it.
The object S2 passed in will be of class prot-1, which does have
the slot. This could be allowed, and currently is in EIEIO.
Needed by the eieio persistant base class."
(oref s2 slot-2))
(defclass prot-1 (prot-0)
((slot-1 :initarg :slot-1
:initform nil
:protection :public)
(slot-2 :initarg :slot-2
:initform nil
:protection :protected)
(slot-3 :initarg :slot-3
:initform nil
:protection :private))
"A class for testing the :protection option.")
(defclass prot-2 (prot-1)
nil
"A class for testing the :protection option.")
(defmethod prot1-slot-2 ((s2 prot-1))
"Try to access slot-2 in S2."
(oref s2 slot-2))
(defmethod prot1-slot-2 ((s2 prot-2))
"Try to access slot-2 in S2."
(oref s2 slot-2))
(defmethod prot1-slot-3-only ((s2 prot-1))
"Try to access slot-3 in S2.
Do not override for `prot-2'."
(oref s2 slot-3))
(defmethod prot1-slot-3 ((s2 prot-1))
"Try to access slot-3 in S2."
(oref s2 slot-3))
(defmethod prot1-slot-3 ((s2 prot-2))
"Try to access slot-3 in S2."
(oref s2 slot-3))
(defvar eitest-p1 nil)
(defvar eitest-p2 nil)
(ert-deftest eieio-test-28-slot-protection ()
(setq eitest-p1 (prot-1 ""))
(setq eitest-p2 (prot-2 ""))
;; 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)
;; 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)
;; Access private slot in ethod
(prot1-slot-3 eitest-p1)
;; Access private slot in subclass method must fail
(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
(prot1-slot-3-only eitest-p2))
;;; eieio-instance-inheritor
;; Test to make sure this works.
(defclass II (eieio-instance-inheritor)
((slot1 :initform 1)
(slot2)
(slot3))
"Instance Inheritor test class.")
(defvar eitest-II1 nil)
(defvar eitest-II2 nil)
(defvar eitest-II3 nil)
(ert-deftest eieio-test-29-instance-inheritor ()
(setq eitest-II1 (II "II Test."))
(oset eitest-II1 slot2 'cat)
(setq eitest-II2 (clone eitest-II1 "eitest-II2 Test."))
(oset eitest-II2 slot1 'moose)
(setq eitest-II3 (clone eitest-II2 "eitest-II3 Test."))
(oset eitest-II3 slot3 'penguin)
;; Test level 1 inheritance
(should (eq (oref eitest-II3 slot1) 'moose))
;; Test level 2 inheritance
(should (eq (oref eitest-II3 slot2) 'cat))
;; Test level 0 inheritance
(should (eq (oref eitest-II3 slot3) 'penguin)))
(defclass slotattr-base ()
((initform :initform init)
(type :type list)
(initarg :initarg :initarg)
(protection :protection :private)
(custom :custom (repeat string)
:label "Custom Strings"
:group moose)
(docstring :documentation
"Replace the doc-string for this property.")
(printer :printer printer1)
)
"Baseclass we will attempt to subclass.
Subclasses to override slot attributes.")
(defclass slotattr-ok (slotattr-base)
((initform :initform no-init)
(initarg :initarg :initblarg)
(custom :custom string
:label "One String"
:group cow)
(docstring :documentation
"A better doc string for this class.")
(printer :printer printer2)
)
"This class should allow overriding of various slot attributes.")
(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.")))
;; Subclass should not override :type slot attribute
(should-error
(eval
'(defclass slotattr-fail (slotattr-base)
((type :type string)
)
"This class should throw an error.")))
;; Initform should override instance allocation
(let ((obj (slotattr-ok "moose")))
(should (eq (oref obj initform) 'no-init))))
(defclass slotattr-class-base ()
((initform :allocation :class
:initform init)
(type :allocation :class
:type list)
(initarg :allocation :class
:initarg :initarg)
(protection :allocation :class
:protection :private)
(custom :allocation :class
:custom (repeat string)
:label "Custom Strings"
:group moose)
(docstring :allocation :class
:documentation
"Replace the doc-string for this property.")
)
"Baseclass we will attempt to subclass.
Subclasses to override slot attributes.")
(defclass slotattr-class-ok (slotattr-class-base)
((initform :initform no-init)
(initarg :initarg :initblarg)
(custom :custom string
:label "One String"
:group cow)
(docstring :documentation
"A better doc string for this class.")
)
"This class should allow overriding of various slot attributes.")
(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.")))
(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)))
(ert-deftest eieio-test-32-slot-attribute-override-2 ()
(let* ((cv (class-v 'slotattr-ok))
(docs (eieio--class-public-doc cv))
(names (eieio--class-public-a cv))
(cust (eieio--class-public-custom cv))
(label (eieio--class-public-custom-label cv))
(group (eieio--class-public-custom-group cv))
(types (eieio--class-public-type cv))
(args (eieio--class-initarg-tuples cv))
(i 0))
;; :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)))))
(defvar eitest-CLONETEST1 nil)
(defvar eitest-CLONETEST2 nil)
(ert-deftest eieio-test-32-test-clone-boring-objects ()
;; A simple make instance with EIEIO extension
(should (setq eitest-CLONETEST1 (make-instance 'class-a "a")))
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
;; CLOS form of make-instance
(should (setq eitest-CLONETEST1 (make-instance 'class-a)))
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))))
(defclass IT (eieio-instance-tracker)
((tracking-symbol :initform IT-list)
(slot1 :initform 'die))
"Instance Tracker test object.")
(ert-deftest eieio-test-33-instance-tracker ()
(let (IT-list IT1)
(should (setq IT1 (IT "trackme")))
;; The instance tracker must find this
(should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
;; Test deletion
(delete-instance IT1)
(should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list))))
(defclass SINGLE (eieio-singleton)
((a-slot :initarg :a-slot :initform t))
"A Singleton test object.")
(ert-deftest eieio-test-34-singletons ()
(let ((obj1 (SINGLE "Moose"))
(obj2 (SINGLE "Cow")))
(should (eieio-object-p obj1))
(should (eieio-object-p obj2))
(should (eq obj1 obj2))
(should (oref obj1 a-slot))))
(defclass NAMED (eieio-named)
((some-slot :initform nil)
)
"A class inheriting from eieio-named.")
(ert-deftest eieio-test-35-named-object ()
(let (N)
(should (setq N (NAMED "Foo")))
(should (string= "Foo" (oref N object-name)))
(should-error (oref N missing-slot) :type 'invalid-slot-name)
(oset N object-name "NewName")
(should (string= "NewName" (oref N object-name)))))
(defclass opt-test1 ()
()
"Abstract base class"
:abstract t)
(defclass opt-test2 (opt-test1)
()
"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)))
(ert-deftest eieio-test-37-persistent-classes ()
(load-file "eieio-test-persist.el"))
(provide 'eieio-tests)
;;; eieio-tests.el ends here