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_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 VERSION 0.01_01
  75
  76 This is the first dev release of this new module, and on top of that,
  77 the Perl 5.9.5 it seeks to provide compatibility with isn't even
  78 out yet.  Consider it not fully stabilized for the time being.
  79 These interfaces are not necessarily nailed down yet.
  80
  81 =head1 Functions
  82
  83 =head2 mro::get_linear_isa($classname[, $type])
  84
  85 Returns an arrayref which is the linearized MRO of the given class.
  86 Uses whichever MRO is currently in effect for that class by default,
  87 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
  88
  89 The linearized MRO of a class is a single ordered list of all of the
  90 classes that would be visited in the process of resolving a method
  91 on the given class, starting with itself.  It does not include any
  92 duplicate entries.
  93
  94 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
  95 part of the MRO of a class, even though all classes implicitly inherit
  96 methods from C<UNIVERSAL> and its parents.
  97
  98 =cut
  99
 100 sub __get_linear_isa_dfs {
 101     no strict 'refs';
 102
 103     my $classname = shift;
 104
 105     my @lin = ($classname);
 106     my %stored;
 107     foreach my $parent (@{"$classname\::ISA"}) {
 108         my $plin = __get_linear_isa_dfs($parent);
 109         foreach (@$plin) {
 110             next if exists $stored{$_};
 111             push(@lin, $_);
 112             $stored{$_} = 1;
 113         }
 114     }
 115     return \@lin;
 116 }
 117
 118 sub __get_linear_isa {
 119     my ($classname, $type) = @_;
 120     die "mro::get_mro requires a classname" if !$classname;
 121
 122     $type ||= __get_mro($classname);
 123     if($type eq 'dfs') {
 124         return __get_linear_isa_dfs($classname);
 125     }
 126     elsif($type eq 'c3') {
 127         return [Class::C3::calculateMRO($classname)];
 128     }
 129     die "type argument must be 'dfs' or 'c3'";
 130 }
 131
 132 =head2 mro::import
 133
 134 This allows the C<use mro 'dfs'> and
 135 C<use mro 'c3'> syntaxes, providing you
 136 L<use MRO::Compat> first.  Please see the
 137 L</USING C3> section for additional details.
 138
 139 =cut
 140
 141 sub __import {
 142     if($_[1]) {
 143         goto &Class::C3::import if $_[1] eq 'c3';
 144         __set_mro(scalar(caller), $_[1]);
 145     }
 146 }
 147
 148 =head2 mro::set_mro($classname, $type)
 149
 150 Sets the mro of C<$classname> to one of the types
 151 C<dfs> or C<c3>.  Please see the L</USING C3>
 152 section for additional details.
 153
 154 =cut
 155
 156 sub __set_mro {
 157     my ($classname, $type) = @_;
 158     if(!$classname || !$type) {
 159         die q{Usage: mro::set_mro($classname, $type)};
 160     }
 161     if($type eq 'c3') {
 162         eval "package $classname; use Class::C3";
 163         die $@ if $@;
 164     }
 165     if($type ne 'dfs') {
 166         die q{Invalid mro type "$type"};
 167     }
 168
 169     # In the dfs case, check whether we need to undo C3
 170     if(defined $Class::C3::MRO{$classname}) {
 171         Class::C3::_remove_method_dispatch_table($classname);
 172     }
 173     delete $Class::C3::MRO{$classname};
 174
 175     return;
 176 }
 177
 178 =head2 mro::get_mro($classname)
 179
 180 Returns the MRO of the given class (either C<c3> or C<dfs>).
 181
 182 It considers any Class::C3-using class to have C3 MRO
 183 even before L<Class::C3::initialize()> is called.
 184
 185 =cut
 186
 187 sub __get_mro {
 188     my $classname = shift;
 189     die "mro::get_mro requires a classname" if !$classname;
 190     return 'c3' if exists $Class::C3::MRO{$classname};
 191     return 'dfs';
 192 }
 193
 194 =head2 mro::get_isarev($classname)
 195
 196 Returns an array of classes who are subclasses of the
 197 given classname.  In other words, classes who we exists,
 198 however indirectly, in the @ISA inheritancy hierarchy of.
 199
 200 This is much slower on pre-5.9.5 Perls with MRO::Compat
 201 than it is on 5.9.5+, as it has to search the entire
 202 package namespace.
 203
 204 =cut
 205
 206 sub __get_all_pkgs_with_isas {
 207     no strict 'refs';
 208     no warnings 'recursion';
 209
 210     my @retval;
 211
 212     my $search = shift;
 213     my $pfx;
 214     my $isa;
 215     if($search) {
 216         $isa = \@{"$search\::ISA"};
 217         $pfx = "$search\::";
 218     }
 219     else {
 220         $search = 'main';
 221         $isa = \@main::ISA;
 222         $pfx = '';
 223     }
 224
 225     push(@retval, $search) if scalar(@$isa);
 226
 227     foreach my $cand (keys %{"$search\::"}) {
 228         if($cand =~ /::$/) {
 229             $cand =~ s/::$//;
 230             next if $cand eq $search; # skip self-reference (main?)
 231             push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
 232         }
 233     }
 234
 235     return \@retval;
 236 }
 237
 238 sub __get_isarev_recurse {
 239     no strict 'refs';
 240
 241     my ($class, $all_isas, $level) = @_;
 242
 243     die "Recursive inheritance detected" if $level > 100;
 244
 245     my %retval;
 246
 247     foreach my $cand (@$all_isas) {
 248         my $found_me;
 249         foreach (@{"$cand\::ISA"}) {
 250             if($_ eq $class) {
 251                 $found_me = 1;
 252                 last;
 253             }
 254         }
 255         if($found_me) {
 256             $retval{$cand} = 1;
 257             map { $retval{$_} = 1 }
 258                 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
 259         }
 260     }
 261     return [keys %retval];
 262 }
 263
 264 sub __get_isarev {
 265     my $classname = shift;
 266     die "mro::get_isarev requires a classname" if !$classname;
 267
 268     @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
 269 }
 270
 271 =head2 mro::is_universal($classname)
 272
 273 Returns a boolean status indicating whether or not
 274 the given classname is either C<UNIVERSAL> itself,
 275 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
 276
 277 Any class for which this function returns true is
 278 "universal" in the sense that all classes potentially
 279 inherit methods from it.
 280
 281 =cut
 282
 283 sub __is_universal {
 284     my $classname = shift;
 285     die "mro::is_universal requires a classname" if !$classname;
 286
 287     my $lin = __get_linear_isa('UNIVERSAL');
 288     foreach (@$lin) {
 289         return 1 if $classname eq $_;
 290     }
 291
 292     return 0;
 293 }
 294
 295 =head2 mro::invalidate_all_method_caches
 296
 297 Increments C<PL_sub_generation>, which invalidates method
 298 caching in all packages.
 299
 300 =cut
 301
 302 sub __invalidate_all_method_caches {
 303     # Super secret mystery code :)
 304     @fedcba98::ISA = @fedcba98::ISA;
 305     return;
 306 }
 307
 308 =head2 mro::method_changed_in($classname)
 309
 310 Invalidates the method cache of any classes dependent on the
 311 given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
 312 an alias for C<mro::invalidate_all_method_caches> above, as
 313 pre-5.9.5 Perls have no other way to do this.  It will still
 314 enforce the requirement that you pass it a classname, for
 315 compatibility.
 316
 317 =cut
 318
 319 sub __method_changed_in {
 320     my $classname = shift;
 321     die "mro::method_changed_in requires a classname" if !$classname;
 322
 323     __invalidate_all_method_caches();
 324 }
 325
 326 =head1 USING C3
 327
 328 While this module makes the 5.9.5+ syntaxes
 329 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
 330 on older Perls, it does so merely by passing off the work
 331 to L<Class::C3>.
 332
 333 It does not remove the need for you to call
 334 L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
 335 C<uninitialize()> at the appropriate times
 336 as documented in the L<Class::C3> docs.
 337
 338 Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
 339 and requires it at C<use> time, you can blindly call
 340 those functions in code that uses L<MRO::Compat>.
 341 Under 5.9.5+ with L<MRO::Compat>, your calls to those
 342 functions will become a no-op and everything will work fine.
 343
 344 =head1 SEE ALSO
 345
 346 L<Class::C3>
 347
 348 L<mro>
 349
 350 =head1 AUTHOR
 351
 352 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 353
 354 =head1 COPYRIGHT AND LICENSE
 355
 356 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
 357
 358 This library is free software; you can redistribute it and/or modify
 359 it under the same terms as Perl itself.
 360
 361 =cut
 362
 363 1;