package Test::Run::Class::Hierarchy; use strict; use warnings; =head1 NAME Test::Run::Class::Hierarchy - returns a list of super-classes in topological order. =head1 SYNPOSIS use Test::Run::Class::Hierarchy; my $base_classes = hierarchy_of("MyClass::Sub::Sub::Sub"); my $base_classes_rev = rev_hierarchy_of("MyClass::Sub::Sub::Sub"); =head1 DESCRIPTION Returns a list of classes in the current namespace. Note that it caches the results. =head1 EXPORTS =cut use Moose; extends('Exporter'); use List::MoreUtils (qw(uniq)); our @EXPORT_OK = (qw(hierarchy_of rev_hierarchy_of)); our %_hierarchy_of = (); =head2 my [@list] = hierarchy_of($class) Returns a list of the classes in the hierarchy of the class, from bottom to top. =cut sub hierarchy_of { my $class = shift; if (exists($_hierarchy_of{$class})) { return $_hierarchy_of{$class}; } no strict 'refs'; my @hierarchy = $class; my @parents = @{$class. '::ISA'}; while (my $p = shift(@parents)) { push @hierarchy, $p; push @parents, @{$p. '::ISA'}; } my @unique = uniq(@hierarchy); return $_hierarchy_of{$class} = [ sort { $a->isa($b) ? -1 : $b->isa($a) ? +1 : 0 } @unique ]; } our %_rev_hierarchy_of = (); =head2 my [@list] = rev_hierarchy_of($class) Returns the classes from top to bottom. =cut sub rev_hierarchy_of { my $class = shift; if (exists($_rev_hierarchy_of{$class})) { return $_rev_hierarchy_of{$class}; } return $_rev_hierarchy_of{$class} = [reverse @{hierarchy_of($class)}]; } 1; =head1 LICENSE This file is licensed under the MIT X11 License: http://www.opensource.org/licenses/mit-license.php =head1 CREDITS The code was inspired by the code from Damian Conway's L, but is not inclusive of it. Written by Shlomi Fish: L. =head1 SEE ALSO L, L =cut