From: Brandon L Black <blblack@gmail.com>
Date: Fri, 11 May 2007 15:10:55 +0000 (+0000)
Subject: implemented get_isarev, interface now complete, needs more tests
X-Git-Tag: 0.02~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=42915ba4bc0331a65fbd10aa590b5e51f267aa7e;p=gitmo%2FMRO-Compat.git

implemented get_isarev, interface now complete, needs more tests
---

diff --git a/lib/MRO/Compat.pm b/lib/MRO/Compat.pm
index acdac69..b75a855 100644
--- a/lib/MRO/Compat.pm
+++ b/lib/MRO/Compat.pm
@@ -33,7 +33,7 @@ BEGIN {
 
 =head1 NAME
 
-MRO::Compat - Partial mro::* interface compatibility for Perls < 5.9.5
+MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
 
 =head1 SYNOPSIS
 
@@ -55,12 +55,12 @@ The "mro" namespace provides several utilities for dealing
 with method resolution order and method caching in general
 in Perl 5.9.5 and higher.
 
-This module provides a subset of those interfaces for
+This module provides those interfaces for
 earlier versions of Perl (back to 5.6.0 anyways).
 
-It is a harmless no-op to use it on 5.9.5+.  If you're
-writing a piece of software that would like to use the
-parts of 5.9.5+'s mro:: interfaces that are supported
+It is a harmless no-op to use this module on 5.9.5+.  If
+you're writing a piece of software that would like to use
+the parts of 5.9.5+'s mro:: interfaces that are supported
 here, and you want compatibility with older Perls, this
 is the module for you.
 
@@ -183,15 +183,79 @@ sub __get_mro {
 
 =head2 mro::get_isarev($classname)
 
-Not supported, will die if used on pre-5.9.5 Perls.
+Returns an array of classes who are subclasses of the
+given classname.  In other words, classes who we exists,
+however indirectly, in the @ISA inheritancy hierarchy of.
+
+This is much slower on pre-5.9.5 Perls with MRO::Compat
+than it is on 5.9.5+, as it has to search the entire
+package namespace.
 
 =cut
 
-# In theory this could be made to work, but it would
-#  be an insanely slow algorithm if any reasonably large
-#  number of modules were loaded.
+sub __get_all_pkgs_with_isas {
+    no strict 'refs';
+    no warnings 'recursion';
+
+    my @retval;
+
+    my $search = shift;
+    my $pfx;
+    my $isa;
+    if($search) {
+        $isa = \@{"$search\::ISA"};
+        $pfx = "$search\::";
+    }
+    else {
+        $search = 'main';
+        $isa = \@main::ISA;
+        $pfx = '';
+    }
+
+    push(@retval, $search) if scalar(@$isa);
+
+    foreach my $cand (keys %{"$search\::"}) {
+        if($cand =~ /::$/) {
+            $cand =~ s/::$//;
+            next if $cand eq $search; # skip self-reference (main?)
+            push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
+        }
+    }
+
+    return \@retval;
+}
+
+sub __get_isarev_recurse {
+    no strict 'refs';
+
+    my ($class, $all_isas, $level) = @_;
+
+    die "Recursive inheritance detected" if $level > 100;
+
+    my %retval;
+
+    foreach my $cand (@$all_isas) {
+        my $found_me;
+        foreach (@{"$cand\::ISA"}) {
+            if($_ eq $class) {
+                $found_me = 1;
+                last;
+            }
+        }
+        if($found_me) {
+            $retval{$cand} = 1;
+            map { $retval{$_} = 1 }
+                @{__get_isarev_recurse($cand, $all_isas, $level+1)};
+        }
+    }
+    return [keys %retval];
+}
+
 sub __get_isarev {
-    die "mro::get_isarev() is only supported on Perl 5.9.5+";
+    my $classname = shift;
+    die "mro::get_isarev requires a classname" if !$classname;
+
+    sort @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
 }
 
 =head2 mro::is_universal($classname)
diff --git a/t/10basic.t b/t/10basic.t
index 7eebe5d..8f9a118 100644
--- a/t/10basic.t
+++ b/t/10basic.t
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2;
+use Test::More tests => 5;
 
 BEGIN {
     use_ok('MRO::Compat');
@@ -22,3 +22,18 @@ is_deeply(
   mro::get_linear_isa('GGG'),
   [ 'GGG', 'FFF', 'EEE', 'BBB', 'AAA', 'CCC', 'DDD' ]
 );
+
+is_deeply(
+  [mro::get_isarev('GGG')],
+  [],
+);
+
+is_deeply(
+  [mro::get_isarev('DDD')],
+  [ 'EEE', 'FFF', 'GGG' ],
+);
+
+is_deeply(
+  [mro::get_isarev('AAA')],
+  [ 'BBB', 'CCC', 'DDD', 'EEE', 'FFF', 'GGG' ],
+);