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