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