Add ability for a base class to find its subclasses

[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 1dc8e24..4f75e52 100644 (file)
--- 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