From: Robert Boone <robo4288@gmail.com>
Date: Wed, 28 Nov 2007 16:45:12 +0000 (+0000)
Subject: Add ability for a base class to find its subclasses
X-Git-Tag: 0_49~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7160cad4c9961fec354a0333a3d7588341f36789;p=gitmo%2FClass-MOP.git

Add ability for a base class to find its subclasses
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 1dc8e24..4f75e52 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -386,6 +386,51 @@ sub superclasses {
     @{$self->get_package_symbol('@ISA')};
 }
 
+sub subclasses {
+    my $self = shift;
+
+    my $super_class = $self->name;
+    my @derived_classes;
+    
+    my $find_derived_classes;
+    $find_derived_classes = sub {
+        my ($outer_class) = @_;
+
+        my $symbol_table_hashref = do { no strict 'refs'; \%{"${outer_class}::"} };
+
+      SYMBOL:
+        for my $symbol ( keys %$symbol_table_hashref ) {
+            next SYMBOL if $symbol !~ /\A (\w+):: \z/x;
+            my $inner_class = $1;
+
+            next SYMBOL if $inner_class eq 'SUPER';    # skip '*::SUPER'
+
+            my $class =
+              $outer_class
+              ? "${outer_class}::$inner_class"
+              : $inner_class;
+
+            if ( $class->isa($super_class) and $class ne $super_class ) {
+                push @derived_classes, $class;
+            }
+
+            next SYMBOL if $class eq 'main';           # skip 'main::*'
+
+            $find_derived_classes->($class);
+        }
+    };
+
+    my $root_class = q{};
+    $find_derived_classes->($root_class);
+
+    undef $find_derived_classes;
+
+    @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes;
+
+    return @derived_classes;
+}
+
+
 sub linearized_isa {
     my %seen;
     grep { !($seen{$_}++) } (shift)->class_precedence_list
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 1ca0081..69f3c48 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 197;
+use Test::More tests => 199;
 use Test::Exception;
 
 BEGIN {
@@ -61,7 +61,7 @@ my @class_mop_class_methods = qw(
 
     attribute_metaclass method_metaclass
 
-    superclasses class_precedence_list linearized_isa
+    superclasses subclasses class_precedence_list linearized_isa
 
     has_method get_method add_method remove_method alias_method
     get_method_list get_method_map compute_all_applicable_methods