lib/MRO/Compat.pm

   1 package MRO::Compat;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '0.01';
   6
   7 # Is Class::C3 installed locally?
   8 our $C3_INSTALLED;
   9
  10 BEGIN {
  11     # Don't do anything if 5.9.5+
  12     if($] < 5.009_005) {
  13         # Find out if we have Class::C3 at all
  14         eval { require Class::C3 };
  15         $C3_INSTALLED = 1 if !$@;
  16
  17         # Alias our private functions over to
  18         # the mro:: namespace
  19         *mro::import            = \&__import;
  20         *mro::get_linear_isa    = \&__get_linear_isa;
  21         *mro::set_mro           = \&__set_mro;
  22         *mro::get_mro           = \&__get_mro;
  23         *mro::get_isarev        = \&__get_isarev;
  24         *mro::is_universal      = \&__is_universal;
  25         *mro::method_changed_in = \&__method_changed_in;
  26         *mro::invalidate_all_method_caches
  27                                 = \&__invalidate_all_method_caches;
  28     }
  29 }
  30
  31 =head1 NAME
  32
  33 MRO::Compat - Partial mro::* interface compatibility for Perls < 5.9.5
  34
  35 =head1 SYNOPSIS
  36
  37    package FooClass; use base qw/X Y Z/;
  38    package X;        use base qw/ZZZ/;
  39    package Y;        use base qw/ZZZ/;
  40    package Z;        use base qw/ZZZ/;
  41
  42    package main;
  43    use MRO::Compat;
  44    my $linear = mro::get_linear_isa('FooClass');
  45    print join(q{, }, @$linear);
  46
  47    # Prints: "FooClass, X, ZZZ, Y, Z"
  48
  49 =head1 DESCRIPTION
  50
  51 The "mro" namespace provides several utilities for dealing
  52 with method resolution order and method caching in general
  53 in Perl 5.9.5 and higher.
  54
  55 This module provides a subset of those interfaces for
  56 earlier versions of Perl.  It is a harmless no-op to use
  57 it on 5.9.5+.  If you're writing a piece of software
  58 that would like to use the parts of 5.9.5+'s mro::
  59 interfaces that are supported here, and you want
  60 compatibility with older Perls, this is the module
  61 for you.
  62
  63 This module never exports any functions.  All calls must
  64 be fully qualified with the C<mro::> prefix.
  65
  66 =head1 Functions
  67
  68 =head2 mro::get_linear_isa($classname[, $type])
  69
  70 Returns an arrayref which is the linearized MRO of the given class.
  71 Uses whichever MRO is currently in effect for that class by default,
  72 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
  73
  74 The linearized MRO of a class is a single ordered list of all of the
  75 classes that would be visited in the process of resolving a method
  76 on the given class, starting with itself.  It does not include any
  77 duplicate entries.
  78
  79 On pre-5.9.5 Perls with MRO::Compat, explicitly asking for the C<c3>
  80 MRO of a class will die if L<Class::C3> is not installed.  If
  81 L<Class::C3> is installed, it will detect C3 classes and return the
  82 correct C3 MRO unless explicitly asked to return the C<dfs> MRO.
  83
  84 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
  85 part of the MRO of a class, even though all classes implicitly inherit
  86 methods from C<UNIVERSAL> and its parents.
  87
  88 =cut
  89
  90 sub __get_linear_isa_dfs {
  91     no strict 'refs';
  92
  93     my $classname = shift;
  94
  95     my @lin = ($classname);
  96     my %stored;
  97     foreach my $parent (@{"$classname\::ISA"}) {
  98         my $plin = __get_linear_isa_dfs($parent);
  99         foreach (@$plin) {
 100             next if exists $stored{$_};
 101             push(@lin, $_);
 102             $stored{$_} = 1;
 103         }
 104     }
 105     return \@lin;
 106 }
 107
 108 sub __get_linear_isa {
 109     my ($classname, $type) = @_;
 110     die "mro::get_mro requires a classname" if !$classname;
 111
 112     $type ||= __get_mro($classname);
 113     if($type eq 'dfs') {
 114         return __get_linear_isa_dfs($classname);
 115     }
 116     elsif($type eq 'c3') {
 117         return [Class::C3::calculateMRO($classname)];
 118     }
 119     die "type argument must be 'dfs' or 'c3'";
 120 }
 121
 122 =head2 mro::import
 123
 124 Not supported, and hence 5.9.5's "use mro 'foo'" is also not supported.
 125 These will die if used on pre-5.9.5 Perls.
 126
 127 =cut
 128
 129 sub __import {
 130     die q{The "use mro 'foo'" is only supported on Perl 5.9.5+};
 131 }
 132
 133 =head2 mro::set_mro($classname, $type)
 134
 135 Not supported, will die if used on pre-5.9.5 Perls.
 136
 137 =cut
 138
 139 sub __set_mro {
 140     die q{mro::set_mro() is only supported on Perl 5.9.5+};
 141 }
 142
 143 =head2 mro::get_mro($classname)
 144
 145 Returns the MRO of the given class (either C<c3> or C<dfs>).
 146
 147 =cut
 148
 149 sub __get_mro {
 150     my $classname = shift;
 151     die "mro::get_mro requires a classname" if !$classname;
 152     if($C3_INSTALLED && exists $Class::C3::MRO{$classname}) {
 153         return 'c3';
 154     }
 155     return 'dfs';
 156 }
 157
 158 =head2 mro::get_isarev($classname)
 159
 160 Not supported, will die if used on pre-5.9.5 Perls.
 161
 162 =cut
 163
 164 sub __get_isarev {
 165     die "mro::get_isarev() is only supported on Perl 5.9.5+";
 166 }
 167
 168 =head2 mro::is_universal($classname)
 169
 170 Returns a boolean status indicating whether or not
 171 the given classname is either C<UNIVERSAL> itself,
 172 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
 173
 174 Any class for which this function returns true is
 175 "universal" in the sense that all classes potentially
 176 inherit methods from it.
 177
 178 =cut
 179
 180 sub __is_universal {
 181     my $classname = shift;
 182     die "mro::is_universal requires a classname" if !$classname;
 183
 184     my $lin = __get_linear_isa($classname);
 185     foreach (@$lin) {
 186         return 1 if $classname eq $_;
 187     }
 188
 189     return 0;
 190 }
 191
 192 =head2 mro::invalidate_all_method_caches
 193
 194 Increments C<PL_sub_generation>, which invalidates method
 195 caching in all packages.
 196
 197 =cut
 198
 199 sub __invalidate_all_method_caches {
 200     # Super secret mystery code :)
 201     @fedcba98::ISA = @fedcba98::ISA;
 202     return;
 203 }
 204
 205 =head2 mro::method_changed_in($classname)
 206
 207 Invalidates the method cache of any classes dependent on the
 208 given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
 209 an alias for C<mro::invalidate_all_method_caches> above, as
 210 pre-5.9.5 Perls have no other way to do this.  It will still
 211 enforce the requirement that you pass it a classname, for
 212 compatibility.
 213
 214 =cut
 215
 216 sub __method_changed_in {
 217     my $classname = shift;
 218     die "mro::method_changed_in requires a classname" if !$classname;
 219
 220     __invalidate_all_method_caches();
 221 }
 222
 223 =head1 SEE ALSO
 224
 225 L<Class::C3>
 226
 227 L<mro>
 228
 229 =head1 AUTHOR
 230
 231 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 232
 233 =head1 COPYRIGHT AND LICENSE
 234
 235 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
 236
 237 This library is free software; you can redistribute it and/or modify
 238 it under the same terms as Perl itself.
 239
 240 =cut
 241
 242 1;