lib/MRO/Compat.pm

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