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 - Partial 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 a subset of those interfaces for
  59 earlier versions of Perl (back to 5.6.0 anyways).
  60
  61 It is a harmless no-op to use it on 5.9.5+.  If you're
  62 writing a piece of software that would like to use the
  63 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 Not supported, will die if used on pre-5.9.5 Perls.
 187
 188 =cut
 189
 190 # In theory this could be made to work, but it would
 191 #  be an insanely slow algorithm if any reasonably large
 192 #  number of modules were loaded.
 193 sub __get_isarev {
 194     die "mro::get_isarev() is only supported on Perl 5.9.5+";
 195 }
 196
 197 =head2 mro::is_universal($classname)
 198
 199 Returns a boolean status indicating whether or not
 200 the given classname is either C<UNIVERSAL> itself,
 201 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
 202
 203 Any class for which this function returns true is
 204 "universal" in the sense that all classes potentially
 205 inherit methods from it.
 206
 207 =cut
 208
 209 sub __is_universal {
 210     my $classname = shift;
 211     die "mro::is_universal requires a classname" if !$classname;
 212
 213     my $lin = __get_linear_isa($classname);
 214     foreach (@$lin) {
 215         return 1 if $classname eq $_;
 216     }
 217
 218     return 0;
 219 }
 220
 221 =head2 mro::invalidate_all_method_caches
 222
 223 Increments C<PL_sub_generation>, which invalidates method
 224 caching in all packages.
 225
 226 =cut
 227
 228 sub __invalidate_all_method_caches {
 229     # Super secret mystery code :)
 230     @fedcba98::ISA = @fedcba98::ISA;
 231     return;
 232 }
 233
 234 =head2 mro::method_changed_in($classname)
 235
 236 Invalidates the method cache of any classes dependent on the
 237 given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
 238 an alias for C<mro::invalidate_all_method_caches> above, as
 239 pre-5.9.5 Perls have no other way to do this.  It will still
 240 enforce the requirement that you pass it a classname, for
 241 compatibility.
 242
 243 =cut
 244
 245 sub __method_changed_in {
 246     my $classname = shift;
 247     die "mro::method_changed_in requires a classname" if !$classname;
 248
 249     __invalidate_all_method_caches();
 250 }
 251
 252 =head1 USING C3
 253
 254 While this module makes the 5.9.5+ syntaxes
 255 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
 256 on older Perls, it does so merely by passing off the work
 257 to L<Class::C3>.
 258
 259 It does not remove the need for you to call
 260 L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
 261 C<uninitialize()> at the appropriate times
 262 as documented in the L<Class::C3> docs.
 263
 264 Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
 265 and requires it at C<use> time, you can blindly call
 266 those functions in code that uses L<MRO::Compat>.
 267 Under 5.9.5+ with L<MRO::Compat>, your calls to those
 268 functions will become a no-op and everything will work fine.
 269
 270 =head1 SEE ALSO
 271
 272 L<Class::C3>
 273
 274 L<mro>
 275
 276 =head1 AUTHOR
 277
 278 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 279
 280 =head1 COPYRIGHT AND LICENSE
 281
 282 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
 283
 284 This library is free software; you can redistribute it and/or modify
 285 it under the same terms as Perl itself.
 286
 287 =cut
 288
 289 1;