fix a test on 5.9.5, and release 0.01_01

[gitmo/MRO-Compat.git] / lib / MRO / Compat.pm

diff --git a/lib/MRO/Compat.pm b/lib/MRO/Compat.pm
index acdac69..ea0df45 100644 (file)
--- a/lib/MRO/Compat.pm
+++ b/lib/MRO/Compat.pm
@@ -3,7 +3,9 @@ use strict;
 use warnings;
 require 5.006_000;
 
-our $VERSION = '0.01';
+# Keep this < 1.00, so people can tell the fake
+#  mro.pm from the real one
+our $VERSION = '0.01_01';
 
 BEGIN {
     # Alias our private functions over to
@@ -20,6 +22,8 @@ BEGIN {
         *mro::method_changed_in = \&__method_changed_in;
         *mro::invalidate_all_method_caches
                                 = \&__invalidate_all_method_caches;
+        $mro::VERSION = $VERSION;
+        $INC{'mro.pm'} = 'Faked by MRO::Compat';
     }
 
     # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+
@@ -33,7 +37,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,18 +59,25 @@ 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.
 
 This module never exports any functions.  All calls must
 be fully qualified with the C<mro::> prefix.
 
+=head1 VERSION 0.01_01
+
+This is the first dev release of this new module, and on top of that,
+the Perl 5.9.5 it seeks to provide compatibility with isn't even
+out yet.  Consider it not fully stabilized for the time being.
+These interfaces are not necessarily nailed down yet.
+
 =head1 Functions
 
 =head2 mro::get_linear_isa($classname[, $type])
@@ -155,8 +166,7 @@ sub __set_mro {
         die q{Invalid mro type "$type"};
     }
 
-    # In the dfs case, check whether we need to
-    #  undo C3
+    # In the dfs case, check whether we need to undo C3
     if(defined $Class::C3::MRO{$classname}) {
         Class::C3::_remove_method_dispatch_table($classname);
     }
@@ -183,15 +193,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;
+
+    @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
 }
 
 =head2 mro::is_universal($classname)
@@ -210,7 +284,7 @@ sub __is_universal {
     my $classname = shift;
     die "mro::is_universal requires a classname" if !$classname;
 
-    my $lin = __get_linear_isa($classname);
+    my $lin = __get_linear_isa('UNIVERSAL');
     foreach (@$lin) {
         return 1 if $classname eq $_;
     }