6 # Keep this < 1.00, so people can tell the fake
7 # mro.pm from the real one
8 our $VERSION = '0.06_01';
11 # Alias our private functions over to
12 # the mro:: namespace and load
13 # Class::C3 if Perl < 5.9.5
15 $mro::VERSION # to fool Module::Install when generating META.yml
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;
28 if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
29 *mro::get_pkg_gen = \&__get_pkg_gen_c3xs;
32 *mro::get_pkg_gen = \&__get_pkg_gen_pp;
36 # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
39 no warnings 'redefine';
40 *Class::C3::initialize = sub { 1 };
41 *Class::C3::reinitialize = sub { 1 };
42 *Class::C3::uninitialize = sub { 1 };
48 MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
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/;
59 my $linear = mro::get_linear_isa('FooClass');
60 print join(q{, }, @$linear);
62 # Prints: "FooClass, X, ZZZ, Y, Z"
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.
70 This module provides those interfaces for
71 earlier versions of Perl (back to 5.6.0 anyways).
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+.
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.
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.
87 This module never exports any functions. All calls must
88 be fully qualified with the C<mro::> prefix.
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.
98 =head2 mro::get_linear_isa($classname[, $type])
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>).
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
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.
115 sub __get_linear_isa_dfs {
118 my $classname = shift;
120 my @lin = ($classname);
122 foreach my $parent (@{"$classname\::ISA"}) {
123 my $plin = __get_linear_isa_dfs($parent);
125 next if exists $stored{$_};
133 sub __get_linear_isa {
134 my ($classname, $type) = @_;
135 die "mro::get_mro requires a classname" if !defined $classname;
137 $type ||= __get_mro($classname);
139 return __get_linear_isa_dfs($classname);
141 elsif($type eq 'c3') {
142 return [Class::C3::calculateMRO($classname)];
144 die "type argument must be 'dfs' or 'c3'";
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.
158 goto &Class::C3::import if $_[1] eq 'c3';
159 __set_mro(scalar(caller), $_[1]);
163 =head2 mro::set_mro($classname, $type)
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.
172 my ($classname, $type) = @_;
173 if(!defined $classname || !$type) {
174 die q{Usage: mro::set_mro($classname, $type)};
177 eval "package $classname; use Class::C3";
181 die q{Invalid mro type "$type"};
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);
188 delete $Class::C3::MRO{$classname};
193 =head2 mro::get_mro($classname)
195 Returns the MRO of the given class (either C<c3> or C<dfs>).
197 It considers any Class::C3-using class to have C3 MRO
198 even before L<Class::C3::initialize()> is called.
203 my $classname = shift;
204 die "mro::get_mro requires a classname" if !defined $classname;
205 return 'c3' if exists $Class::C3::MRO{$classname};
209 =head2 mro::get_isarev($classname)
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.
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
221 sub __get_all_pkgs_with_isas {
223 no warnings 'recursion';
230 if(defined $search) {
231 $isa = \@{"$search\::ISA"};
240 push(@retval, $search) if scalar(@$isa);
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)});
252 sub __get_isarev_recurse {
255 my ($class, $all_isas, $level) = @_;
257 die "Recursive inheritance detected" if $level > 100;
261 foreach my $cand (@$all_isas) {
263 foreach (@{"$cand\::ISA"}) {
271 map { $retval{$_} = 1 }
272 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
275 return [keys %retval];
279 my $classname = shift;
280 die "mro::get_isarev requires a classname" if !defined $classname;
282 __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
285 =head2 mro::is_universal($classname)
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.
291 Any class for which this function returns true is
292 "universal" in the sense that all classes potentially
293 inherit methods from it.
298 my $classname = shift;
299 die "mro::is_universal requires a classname" if !defined $classname;
301 my $lin = __get_linear_isa('UNIVERSAL');
303 return 1 if $classname eq $_;
309 =head2 mro::invalidate_all_method_caches
311 Increments C<PL_sub_generation>, which invalidates method
312 caching in all packages.
314 Please note that this is rarely necessary, unless you are
315 dealing with a situation which is known to confuse Perl's
320 sub __invalidate_all_method_caches {
321 # Super secret mystery code :)
322 @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
326 =head2 mro::method_changed_in($classname)
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
335 Please note that this is rarely necessary, unless you are
336 dealing with a situation which is known to confuse Perl's
341 sub __method_changed_in {
342 my $classname = shift;
343 die "mro::method_changed_in requires a classname" if !defined $classname;
345 __invalidate_all_method_caches();
348 =head2 mro::get_pkg_gen($classname)
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.
359 sub __get_pkg_gen_pp {
360 my $classname = shift;
361 die "mro::get_pkg_gen requires a classname" if !defined $classname;
366 sub __get_pkg_gen_c3xs {
367 my $classname = shift;
368 die "mro::get_pkg_gen requires a classname" if !defined $classname;
370 return Class::C3::XS::_plsubgen();
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
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+.
395 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
397 =head1 COPYRIGHT AND LICENSE
399 Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
401 This library is free software; you can redistribute it and/or modify
402 it under the same terms as Perl itself.