File Coverage

blib/lib/UNIVERSAL/derived_classes.pm

Criterion	Covered	Total	%
statement	9	36	25.0
branch	0	18	0.0
condition	0	3	0.0
subroutine	3	6	50.0
pod	0	2	0.0
total	12	65	18.4

package UNIVERSAL::derived_classes;

use strict;
use vars qw( $VERSION );

$VERSION = '0.02';

sub UNIVERSAL::derived_classes {
    my ($super_class, $reversed) = @_;

    if (my $blessed_class = ref $super_class) {
        $super_class = $blessed_class;
    }

    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 reverse @derived_classes if $reversed;
    return         @derived_classes             ;
}

sub UNIVERSAL::derived_classes_reversed {
    my ($super_class) = @_;
    return $super_class->derived_classes('reversed');
}

1;
__END__