From: Shawn M Moore <sartak@gmail.com>
Date: Tue, 19 May 2009 23:29:05 +0000 (-0400)
Subject: Add direct_subclasses method, also tests for that and subclasses
X-Git-Tag: 0.85~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=462ed2c071b45b3bf6554e95734dd71823c08bd1;p=gitmo%2FClass-MOP.git

Add direct_subclasses method, also tests for that and subclasses
---

diff --git a/Changes b/Changes
index 215bbc2..d1076d5 100644
--- a/Changes
+++ b/Changes
@@ -11,6 +11,10 @@ Revision history for Perl extension Class-MOP.
     * Class::MOP
       - Localize $SIG{__DIE__} inside _try_load_one_class (Sartak)
 
+    * Class::MOP::Class
+      - Add direct_subclasses method (Sartak)
+        - Tests for subclasses and direct_subclasses (Sartak)
+
 0.84 Tue, May 12, 2009
     * Makefile.PL
       - Depend on Text::Exception 0.27 to avoid failing tests ond old
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 49431ab..a331ea4 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -529,6 +529,16 @@ sub subclasses {
     return @{ $super_class->mro::get_isarev() };
 }
 
+sub direct_subclasses {
+    my $self = shift;
+    my $super_class = $self->name;
+
+    return grep {
+        grep {
+            $_ eq $super_class
+        } Class::MOP::Class->initialize($_)->superclasses
+    } $self->subclasses;
+}
 
 sub linearized_isa {
     return @{ mro::get_linear_isa( (shift)->name ) };
@@ -1454,7 +1464,13 @@ duplicates removed.
 
 =item B<< $metaclass->subclasses >>
 
-This returns a list of subclasses for this class.
+This returns a list of all subclasses for this class, even indirect
+subclasses.
+
+=item B<< $metaclass->direct_subclasses >>
+
+This returns a list of immediate subclasses for this class, which does not
+include indirect subclasses.
 
 =back
 
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 17d489b..d4486f9 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 294;
+use Test::More tests => 296;
 use Test::Exception;
 
 use Class::MOP;
@@ -72,7 +72,8 @@ my @class_mop_class_methods = qw(
 
     attribute_metaclass method_metaclass wrapped_method_metaclass
 
-    superclasses subclasses class_precedence_list linearized_isa
+    superclasses subclasses direct_subclasses class_precedence_list
+    linearized_isa
 
     has_method get_method add_method remove_method alias_method wrap_method_body
     get_method_list get_method_map get_all_method_names get_all_methods compute_all_applicable_methods
diff --git a/t/087_subclasses.t b/t/087_subclasses.t
new file mode 100644
index 0000000..8885cc3
--- /dev/null
+++ b/t/087_subclasses.t
@@ -0,0 +1,44 @@
+use strict;
+use warnings;
+use Test::More tests => 12;
+use Class::MOP;
+
+do {
+    package Grandparent;
+    use metaclass;
+
+    package Parent;
+    use metaclass;
+    use base 'Grandparent';
+
+    package Uncle;
+    use metaclass;
+    use base 'Grandparent';
+
+    package Son;
+    use metaclass;
+    use base 'Parent';
+
+    package Daughter;
+    use metaclass;
+    use base 'Parent';
+
+    package Cousin;
+    use metaclass;
+    use base 'Uncle';
+};
+
+is_deeply([sort Grandparent->meta->subclasses], ['Cousin', 'Daughter', 'Parent', 'Son', 'Uncle']);
+is_deeply([sort Parent->meta->subclasses],      ['Daughter', 'Son']);
+is_deeply([sort Uncle->meta->subclasses],       ['Cousin']);
+is_deeply([sort Son->meta->subclasses],         []);
+is_deeply([sort Daughter->meta->subclasses],    []);
+is_deeply([sort Cousin->meta->subclasses],      []);
+
+is_deeply([sort Grandparent->meta->direct_subclasses], ['Parent', 'Uncle']);
+is_deeply([sort Parent->meta->direct_subclasses],      ['Daughter', 'Son']);
+is_deeply([sort Uncle->meta->direct_subclasses],       ['Cousin']);
+is_deeply([sort Son->meta->direct_subclasses],         []);
+is_deeply([sort Daughter->meta->direct_subclasses],    []);
+is_deeply([sort Cousin->meta->direct_subclasses],      []);
+