lib/MRO/Compat.pm

   1 package MRO::Compat;
   2 use strict;
   3 use warnings;
   4 require 5.006_000;
   5
   6 # Keep this < 1.00, so people can tell the fake
   7 #  mro.pm from the real one
   8 our $VERSION = '0.01';
   9
  10 BEGIN {
  11     # Alias our private functions over to
  12     # the mro:: namespace and load
  13     # Class::C3 if Perl < 5.9.5
  14     if($] < 5.009_005) {
  15         require Class::C3;
  16         *mro::import            = \&__import;
  17         *mro::get_linear_isa    = \&__get_linear_isa;
  18         *mro::set_mro           = \&__set_mro;
  19         *mro::get_mro           = \&__get_mro;
  20         *mro::get_isarev        = \&__get_isarev;
  21         *mro::is_universal      = \&__is_universal;
  22         *mro::method_changed_in = \&__method_changed_in;
  23         *mro::invalidate_all_method_caches
  24                                 = \&__invalidate_all_method_caches;
  25         $mro::VERSION = $VERSION;
  26         $INC{'mro.pm'} = 'Faked by MRO::Compat';
  27     }
  28
  29     # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+
  30     else {
  31         no warnings 'redefine';
  32         *Class::C3::initialize = sub { 1 };
  33         *Class::C3::reinitialize = sub { 1 };
  34         *Class::C3::uninitialize = sub { 1 };
  35     }
  36 }
  37
  38 =head1 NAME
  39
  40 MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
  41
  42 =head1 SYNOPSIS
  43
  44    package FooClass; use base qw/X Y Z/;
  45    package X;        use base qw/ZZZ/;
  46    package Y;        use base qw/ZZZ/;
  47    package Z;        use base qw/ZZZ/;
  48
  49    package main;
  50    use MRO::Compat;
  51    my $linear = mro::get_linear_isa('FooClass');
  52    print join(q{, }, @$linear);
  53
  54    # Prints: "FooClass, X, ZZZ, Y, Z"
  55
  56 =head1 DESCRIPTION
  57
  58 The "mro" namespace provides several utilities for dealing
  59 with method resolution order and method caching in general
  60 in Perl 5.9.5 and higher.
  61
  62 This module provides those interfaces for
  63 earlier versions of Perl (back to 5.6.0 anyways).
  64
  65 It is a harmless no-op to use this module on 5.9.5+.  If
  66 you're writing a piece of software that would like to use
  67 the parts of 5.9.5+'s mro:: interfaces that are supported
  68 here, and you want compatibility with older Perls, this
  69 is the module for you.
  70
  71 This module never exports any functions.  All calls must
  72 be fully qualified with the C<mro::> prefix.
  73
  74 =head1 Functions
  75
  76 =head2 mro::get_linear_isa($classname[, $type])
  77
  78 Returns an arrayref which is the linearized MRO of the given class.
  79 Uses whichever MRO is currently in effect for that class by default,
  80 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
  81
  82 The linearized MRO of a class is a single ordered list of all of the
  83 classes that would be visited in the process of resolving a method
  84 on the given class, starting with itself.  It does not include any
  85 duplicate entries.
  86
  87 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
  88 part of the MRO of a class, even though all classes implicitly inherit
  89 methods from C<UNIVERSAL> and its parents.
  90
  91 =cut
  92
  93 sub __get_linear_isa_dfs {
  94     no strict 'refs';
  95
  96     my $classname = shift;
  97
  98     my @lin = ($classname);
  99     my %stored;
 100     foreach my $parent (@{"$classname\::ISA"}) {
 101         my $plin = __get_linear_isa_dfs($parent);
 102         foreach (@$plin) {
 103             next if exists $stored{$_};
 104             push(@lin, $_);
 105             $stored{$_} = 1;
 106         }
 107     }
 108     return \@lin;
 109 }
 110
 111 sub __get_linear_isa {
 112     my ($classname, $type) = @_;
 113     die "mro::get_mro requires a classname" if !$classname;
 114
 115     $type ||= __get_mro($classname);
 116     if($type eq 'dfs') {
 117         return __get_linear_isa_dfs($classname);
 118     }
 119     elsif($type eq 'c3') {
 120         return [Class::C3::calculateMRO($classname)];
 121     }
 122     die "type argument must be 'dfs' or 'c3'";
 123 }
 124
 125 =head2 mro::import
 126
 127 This allows the C<use mro 'dfs'> and
 128 C<use mro 'c3'> syntaxes, providing you
 129 L<use MRO::Compat> first.  Please see the
 130 L</USING C3> section for additional details.
 131
 132 =cut
 133
 134 sub __import {
 135     if($_[1]) {
 136         goto &Class::C3::import if $_[1] eq 'c3';
 137         __set_mro(scalar(caller), $_[1]);
 138     }
 139 }
 140
 141 =head2 mro::set_mro($classname, $type)
 142
 143 Sets the mro of C<$classname> to one of the types
 144 C<dfs> or C<c3>.  Please see the L</USING C3>
 145 section for additional details.
 146
 147 =cut
 148
 149 sub __set_mro {
 150     my ($classname, $type) = @_;
 151     if(!$classname || !$type) {
 152         die q{Usage: mro::set_mro($classname, $type)};
 153     }
 154     if($type eq 'c3') {
 155         eval "package $classname; use Class::C3";
 156         die $@ if $@;
 157     }
 158     if($type ne 'dfs') {
 159         die q{Invalid mro type "$type"};
 160     }
 161
 162     # In the dfs case, check whether we need to undo C3
 163     if(defined $Class::C3::MRO{$classname}) {
 164         Class::C3::_remove_method_dispatch_table($classname);
 165     }
 166     delete $Class::C3::MRO{$classname};
 167
 168     return;
 169 }
 170
 171 =head2 mro::get_mro($classname)
 172
 173 Returns the MRO of the given class (either C<c3> or C<dfs>).
 174
 175 It considers any Class::C3-using class to have C3 MRO
 176 even before L<Class::C3::initialize()> is called.
 177
 178 =cut
 179
 180 sub __get_mro {
 181     my $classname = shift;
 182     die "mro::get_mro requires a classname" if !$classname;
 183     return 'c3' if exists $Class::C3::MRO{$classname};
 184     return 'dfs';
 185 }
 186
 187 =head2 mro::get_isarev($classname)
 188
 189 Returns an array of classes who are subclasses of the
 190 given classname.  In other words, classes who we exists,
 191 however indirectly, in the @ISA inheritancy hierarchy of.
 192
 193 This is much slower on pre-5.9.5 Perls with MRO::Compat
 194 than it is on 5.9.5+, as it has to search the entire
 195 package namespace.
 196
 197 =cut
 198
 199 sub __get_all_pkgs_with_isas {
 200     no strict 'refs';
 201     no warnings 'recursion';
 202
 203     my @retval;
 204
 205     my $search = shift;
 206     my $pfx;
 207     my $isa;
 208     if($search) {
 209         $isa = \@{"$search\::ISA"};
 210         $pfx = "$search\::";
 211     }
 212     else {
 213         $search = 'main';
 214         $isa = \@main::ISA;
 215         $pfx = '';
 216     }
 217
 218     push(@retval, $search) if scalar(@$isa);
 219
 220     foreach my $cand (keys %{"$search\::"}) {
 221         if($cand =~ /::$/) {
 222             $cand =~ s/::$//;
 223             next if $cand eq $search; # skip self-reference (main?)
 224             push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
 225         }
 226     }
 227
 228     return \@retval;
 229 }
 230
 231 sub __get_isarev_recurse {
 232     no strict 'refs';
 233
 234     my ($class, $all_isas, $level) = @_;
 235
 236     die "Recursive inheritance detected" if $level > 100;
 237
 238     my %retval;
 239
 240     foreach my $cand (@$all_isas) {
 241         my $found_me;
 242         foreach (@{"$cand\::ISA"}) {
 243             if($_ eq $class) {
 244                 $found_me = 1;
 245                 last;
 246             }
 247         }
 248         if($found_me) {
 249             $retval{$cand} = 1;
 250             map { $retval{$_} = 1 }
 251                 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
 252         }
 253     }
 254     return [keys %retval];
 255 }
 256
 257 sub __get_isarev {
 258     my $classname = shift;
 259     die "mro::get_isarev requires a classname" if !$classname;
 260
 261     @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
 262 }
 263
 264 =head2 mro::is_universal($classname)
 265
 266 Returns a boolean status indicating whether or not
 267 the given classname is either C<UNIVERSAL> itself,
 268 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
 269
 270 Any class for which this function returns true is
 271 "universal" in the sense that all classes potentially
 272 inherit methods from it.
 273
 274 =cut
 275
 276 sub __is_universal {
 277     my $classname = shift;
 278     die "mro::is_universal requires a classname" if !$classname;
 279
 280     my $lin = __get_linear_isa('UNIVERSAL');
 281     foreach (@$lin) {
 282         return 1 if $classname eq $_;
 283     }
 284
 285     return 0;
 286 }
 287
 288 =head2 mro::invalidate_all_method_caches
 289
 290 Increments C<PL_sub_generation>, which invalidates method
 291 caching in all packages.
 292
 293 =cut
 294
 295 sub __invalidate_all_method_caches {
 296     # Super secret mystery code :)
 297     @fedcba98::ISA = @fedcba98::ISA;
 298     return;
 299 }
 300
 301 =head2 mro::method_changed_in($classname)
 302
 303 Invalidates the method cache of any classes dependent on the
 304 given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
 305 an alias for C<mro::invalidate_all_method_caches> above, as
 306 pre-5.9.5 Perls have no other way to do this.  It will still
 307 enforce the requirement that you pass it a classname, for
 308 compatibility.
 309
 310 =cut
 311
 312 sub __method_changed_in {
 313     my $classname = shift;
 314     die "mro::method_changed_in requires a classname" if !$classname;
 315
 316     __invalidate_all_method_caches();
 317 }
 318
 319 =head1 USING C3
 320
 321 While this module makes the 5.9.5+ syntaxes
 322 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
 323 on older Perls, it does so merely by passing off the work
 324 to L<Class::C3>.
 325
 326 It does not remove the need for you to call
 327 L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
 328 C<uninitialize()> at the appropriate times
 329 as documented in the L<Class::C3> docs.
 330
 331 Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
 332 and requires it at C<use> time, you can blindly call
 333 those functions in code that uses L<MRO::Compat>.
 334 Under 5.9.5+ with L<MRO::Compat>, your calls to those
 335 functions will become a no-op and everything will work fine.
 336
 337 =head1 SEE ALSO
 338
 339 L<Class::C3>
 340
 341 L<mro>
 342
 343 =head1 AUTHOR
 344
 345 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 346
 347 =head1 COPYRIGHT AND LICENSE
 348
 349 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
 350
 351 This library is free software; you can redistribute it and/or modify
 352 it under the same terms as Perl itself.
 353
 354 =cut
 355
 356 1;