Re: [perl #54230] [BUG] [PATCH] Loops in class hierarchies

[NotFound]

On Sun, Jun 15, 2008 at 12:47 AM, chromatic via RT
<[EMAIL PROTECTED]> wrote:

> Seems reasonable to me.  If you have tests, I'll apply it.

Patch updated to r28430 with a simple test added in t/oo/subclass.t

-- 
Salu2

Index: src/pmc/class.pmc
===================================================================
--- src/pmc/class.pmc	(revisión: 28430)
+++ src/pmc/class.pmc	(copia de trabajo)
@@ -734,7 +734,7 @@
         STRING * const parent_name  = VTABLE_get_string(interp, parent);
 
         /* get number of direct parents */
-        const int parent_count      = VTABLE_elements(interp, _class->parents);
+        int parent_count      = VTABLE_elements(interp, _class->parents);
 
         int index; /* loop iterator */
 
@@ -765,7 +765,23 @@
                     "It may have been supplied by a role.",
                     VTABLE_get_string(interp, SELF), parent_name);
         }
+        /* Check is not self */
+        if (parent == SELF)
+            real_exception(interp, NULL, E_TypeError, "Can't be own parent");
 
+        /* Check that none of the parents is self */
+        parent_count = VTABLE_elements(interp,
+            PARROT_CLASS(parent)->all_parents);
+        for (index = 0; index < parent_count; index++) {
+            /* get the next parent */
+            PMC * const current_parent = VTABLE_get_pmc_keyed_int(interp,
+                PARROT_CLASS(parent)->all_parents, index);
+            if (current_parent == SELF)
+                real_exception(interp, NULL, E_TypeError,
+                    "Loop in class hierarchy: '%S' is an ancestor of '%S'.",
+                    VTABLE_get_string(interp, SELF),
+                    VTABLE_get_string(interp, parent));
+        }
 
         /* Add to the lists of our immediate parents and all parents. */
         VTABLE_push_pmc(interp, _class->parents, parent);
Index: t/oo/subclass.t
===================================================================
--- t/oo/subclass.t	(revisión: 28430)
+++ t/oo/subclass.t	(copia de trabajo)
@@ -6,7 +6,7 @@
 use warnings;
 use lib qw( . lib ../lib ../../lib );
 use Test::More;
-use Parrot::Test tests => 20;
+use Parrot::Test tests => 21;
 
 =head1 NAME
 
@@ -591,6 +591,17 @@
 /The class 'Bar' already has a parent class 'Foo'./
 OUT
 
+pir_error_output_like( <<'CODE', <<'OUT', 'attempts to create loops in hierarchy should be rejected');
+.sub main :main
+    $P0 = newclass 'Foo'
+    $P1 = newclass 'Bar'
+    addparent $P1, $P0
+    addparent $P0, $P1
+.end
+CODE
+/Loop in class hierarchy: 'Foo' is an ancestor of 'Bar'./
+OUT
+
 pir_output_is( <<'CODE', <<'OUT', 'subclass should do what the parent does' );
 .sub 'main' :main
     does_pmc()