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