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