From 6ee6031083c97309e7c10e17a25f466933e46656 Mon Sep 17 00:00:00 2001
From: David Engster <dengste@eml.cc>
Date: Wed, 21 Aug 2013 21:42:52 +0200
Subject: [PATCH] Imported EIEIO test suite from CEDET upstream

* automated/eieio-tests.el, automated/eieio-test-persist.el:
* automated/eieio-test-methodinvoke.el: EIEIO tests from CEDET
  upstream.  Changed to use ERT.
---
 test/ChangeLog                            |   6 +
 test/automated/eieio-test-methodinvoke.el | 379 +++++++++
 test/automated/eieio-test-persist.el      | 213 ++++++
 test/automated/eieio-tests.el             | 893 ++++++++++++++++++++++
 4 files changed, 1491 insertions(+)
 create mode 100644 test/automated/eieio-test-methodinvoke.el
 create mode 100644 test/automated/eieio-test-persist.el
 create mode 100644 test/automated/eieio-tests.el

diff --git a/test/ChangeLog b/test/ChangeLog
index 5f3006ec7bf..969bc3c4939 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -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
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el
new file mode 100644
index 00000000000..76a28919f21
--- /dev/null
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -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)))))
diff --git a/test/automated/eieio-test-persist.el b/test/automated/eieio-test-persist.el
new file mode 100644
index 00000000000..cdf308a39ab
--- /dev/null
+++ b/test/automated/eieio-test-persist.el
@@ -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
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el
new file mode 100644
index 00000000000..2d8ae4c7d43
--- /dev/null
+++ b/test/automated/eieio-tests.el
@@ -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
-- 
2.39.2