lib/MRO/Compat.pm

   1 package MRO::Compat;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '0.01';
   6
   7 # Is Class::C3 installed locally?
   8 our $C3_INSTALLED;
   9
  10 BEGIN {
  11     # Don't do anything if 5.9.5+
  12     if($] < 5.009_005) {
  13         # Find out if we have Class::C3 at all
  14         eval { require Class::C3 };
  15         $C3_INSTALLED = 1 if !$@;
  16
  17         # Alias our private functions over to
  18         # the mro:: namespace
  19         *mro::import            = \&__import;
  20         *mro::get_linear_isa    = \&__get_linear_isa;
  21         *mro::set_mro           = \&__set_mro;
  22         *mro::get_mro           = \&__get_mro;
  23         *mro::get_isarev        = \&__get_isarev;
  24         *mro::is_universal      = \&__is_universal;
  25         *mro::method_changed_in = \&__method_changed_in;
  26         *mro::invalidate_all_method_caches
  27                                 = \&__invalidate_all_method_caches;
  28     }
  29 }
  30
  31 =head1 NAME
  32
  33 MRO::Compat - Partial mro::* interface compatibility for Perls < 5.9.5
  34
  35 =head1 SYNOPSIS
  36
  37    package FooClass; use base qw/X Y Z/;
  38    package X;        use base qw/ZZZ/;
  39    package Y;        use base qw/ZZZ/;
  40    package Z;        use base qw/ZZZ/;
  41
  42    package main;
  43    use MRO::Compat;
  44    my $linear = mro::get_linear_isa('FooClass');
  45    print join(q{, }, @$linear);
  46
  47    # Prints: "FooClass, X, ZZZ, Y, Z"
  48
  49 =head1 DESCRIPTION
  50
  51 The "mro" namespace provides several utilities for dealing
  52 with method resolution order and method caching in general
  53 in Perl 5.9.5 and higher.
  54
  55 This module provides a subset of those interfaces for
  56 earlier versions of Perl.  It is a harmless no-op to use
  57 it on 5.9.5+.  If you're writing a piece of software
  58 that would like to use the parts of 5.9.5+'s mro::
  59 interfaces that are supported here, and you want
  60 compatibility with older Perls, this is the module
  61 for you.
  62
  63 This module never exports any functions.  All calls must
  64 be fully qualified with the C<mro::> prefix.
  65
  66 =head1 Functions
  67
  68 =head2 mro::get_linear_isa($classname[, $type])
  69
  70 Returns an arrayref which is the linearized MRO of the given class.
  71 Uses whichever MRO is currently in effect for that class by default,
  72 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
  73
  74 The linearized MRO of a class is a single ordered list of all of the
  75 classes that would be visited in the process of resolving a method
  76 on the given class, starting with itself.  It does not include any
  77 duplicate entries.
  78
  79 On pre-5.9.5 Perls with MRO::Compat, explicitly asking for the C<c3>
  80 MRO of a class will die if L<Class::C3> is not installed.  If
  81 L<Class::C3> is installed, it will detect C3 classes and return the
  82 correct C3 MRO unless explicitly asked to return the C<dfs> MRO.
  83
  84 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
  85 part of the MRO of a class, even though all classes implicitly inherit
  86 methods from C<UNIVERSAL> and its parents.
  87
  88 =cut
  89
  90 sub __get_linear_isa {
  91 }
  92
  93 =head2 mro::import
  94
  95 Not supported, and hence 5.9.5's "use mro 'foo'" is also not supported.
  96 These will die if used on pre-5.9.5 Perls.
  97
  98 =cut
  99
 100 sub __import {
 101     die q{The "use mro 'foo'" is only supported on Perl 5.9.5+};
 102 }
 103
 104 =head2 mro::set_mro($classname, $type)
 105
 106 Not supported, will die if used on pre-5.9.5 Perls.
 107
 108 =cut
 109
 110 sub __set_mro {
 111     die q{mro::set_mro() is only supported on Perl 5.9.5+};
 112 }
 113
 114 =head2 mro::get_mro($classname)
 115
 116 Returns the MRO of the given class (either C<c3> or C<dfs>).
 117
 118 =cut
 119
 120 sub __get_mro {
 121     my $classname = shift
 122     die "mro::get_mro requires a classname" if !$classname;
 123     if($C3_INSTALLED && exists $Class::C3::MRO{$classname}
 124        && $Class::C3::_initialized) {
 125         return 'c3';
 126     }
 127     return 'dfs';
 128 }
 129
 130 =head2 mro::get_isarev($classname)
 131
 132 Not supported, will die if used on pre-5.9.5 Perls.
 133
 134 =cut
 135
 136 sub __get_isarev {
 137     die "mro::get_isarev() is only supported on Perl 5.9.5+";
 138 }
 139
 140 =head2 mro::is_universal($classname)
 141
 142 Returns a boolean status indicating whether or not
 143 the given classname is either C<UNIVERSAL> itself,
 144 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
 145
 146 Any class for which this function returns true is
 147 "universal" in the sense that all classes potentially
 148 inherit methods from it.
 149
 150 =cut
 151
 152 sub __is_universal {
 153     my $classname = shift;
 154     die "mro::is_universal requires a classname" if !$classname;
 155
 156     my $lin = __get_linear_isa($classname);
 157     foreach (@$lin) {
 158         return 1 if $classname eq $_;
 159     }
 160
 161     return 0;
 162 }
 163
 164 =head2 mro::invalidate_all_method_caches
 165
 166 Increments C<PL_sub_generation>, which invalidates method
 167 caching in all packages.
 168
 169 =cut
 170
 171 sub __invalidate_all_method_caches {
 172     # Super secret mystery code :)
 173     @fedcba98::ISA = @fedcba98::ISA;
 174     return;
 175 }
 176
 177 =head2 mro::method_changed_in($classname)
 178
 179 Invalidates the method cache of any classes dependent on the
 180 given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
 181 an alias for C<mro::invalidate_all_method_caches> above, as
 182 pre-5.9.5 Perls have no other way to do this.  It will still
 183 enforce the requirement that you pass it a classname, for
 184 compatibility.
 185
 186 =cut
 187
 188 sub __method_changed_in {
 189     my $classname = shift;
 190     die "mro::method_changed_in requires a classname" if !$classname;
 191
 192     __invalidate_all_method_caches();
 193 }
 194
 195 =head1 SEE ALSO
 196
 197 L<Class::C3>
 198
 199 L<mro>
 200
 201 =head1 AUTHOR
 202
 203 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 204
 205 =head1 COPYRIGHT AND LICENSE
 206
 207 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
 208
 209 This library is free software; you can redistribute it and/or modify
 210 it under the same terms as Perl itself.
 211
 212 =cut
 213
 214 1;