6 # Keep this < 1.00, so people can tell the fake
7 # mro.pm from the real one
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) = @_;
174 if(!defined $classname || !$type) {
175 die q{Usage: mro::set_mro($classname, $type)};
179 eval "package $classname; use Class::C3";
182 elsif($type eq 'dfs') {
183 # In the dfs case, check whether we need to undo C3
184 if(defined $Class::C3::MRO{$classname}) {
185 Class::C3::_remove_method_dispatch_table($classname);
187 delete $Class::C3::MRO{$classname};
190 die qq{Invalid mro type "$type"};
196 =head2 mro::get_mro($classname)
198 Returns the MRO of the given class (either C<c3> or C<dfs>).
200 It considers any Class::C3-using class to have C3 MRO
201 even before L<Class::C3::initialize()> is called.
206 my $classname = shift;
207 die "mro::get_mro requires a classname" if !defined $classname;
208 return 'c3' if exists $Class::C3::MRO{$classname};
212 =head2 mro::get_isarev($classname)
214 Returns an arrayref of classes who are subclasses of the
215 given classname. In other words, classes who we exist,
216 however indirectly, in the @ISA inheritancy hierarchy of.
218 This is much slower on pre-5.9.5 Perls with MRO::Compat
219 than it is on 5.9.5+, as it has to search the entire
224 sub __get_all_pkgs_with_isas {
226 no warnings 'recursion';
233 if(defined $search) {
234 $isa = \@{"$search\::ISA"};
243 push(@retval, $search) if scalar(@$isa);
245 foreach my $cand (keys %{"$search\::"}) {
246 if($cand =~ s/::$//) {
247 next if $cand eq $search; # skip self-reference (main?)
248 push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
255 sub __get_isarev_recurse {
258 my ($class, $all_isas, $level) = @_;
260 die "Recursive inheritance detected" if $level > 100;
264 foreach my $cand (@$all_isas) {
266 foreach (@{"$cand\::ISA"}) {
274 map { $retval{$_} = 1 }
275 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
278 return [keys %retval];
282 my $classname = shift;
283 die "mro::get_isarev requires a classname" if !defined $classname;
285 __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
288 =head2 mro::is_universal($classname)
290 Returns a boolean status indicating whether or not
291 the given classname is either C<UNIVERSAL> itself,
292 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
294 Any class for which this function returns true is
295 "universal" in the sense that all classes potentially
296 inherit methods from it.
301 my $classname = shift;
302 die "mro::is_universal requires a classname" if !defined $classname;
304 my $lin = __get_linear_isa('UNIVERSAL');
306 return 1 if $classname eq $_;
312 =head2 mro::invalidate_all_method_caches
314 Increments C<PL_sub_generation>, which invalidates method
315 caching in all packages.
317 Please note that this is rarely necessary, unless you are
318 dealing with a situation which is known to confuse Perl's
323 sub __invalidate_all_method_caches {
324 # Super secret mystery code :)
325 @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
329 =head2 mro::method_changed_in($classname)
331 Invalidates the method cache of any classes dependent on the
332 given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
333 an alias for C<mro::invalidate_all_method_caches> above, as
334 pre-5.9.5 Perls have no other way to do this. It will still
335 enforce the requirement that you pass it a classname, for
338 Please note that this is rarely necessary, unless you are
339 dealing with a situation which is known to confuse Perl's
344 sub __method_changed_in {
345 my $classname = shift;
346 die "mro::method_changed_in requires a classname" if !defined $classname;
348 __invalidate_all_method_caches();
351 =head2 mro::get_pkg_gen($classname)
353 Returns an integer which is incremented every time a local
354 method of or the C<@ISA> of the given package changes on
355 Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module,
356 it will probably increment a lot more often than necessary.
362 sub __get_pkg_gen_pp {
363 my $classname = shift;
364 die "mro::get_pkg_gen requires a classname" if !defined $classname;
369 sub __get_pkg_gen_c3xs {
370 my $classname = shift;
371 die "mro::get_pkg_gen requires a classname" if !defined $classname;
373 return Class::C3::XS::_plsubgen();
378 While this module makes the 5.9.5+ syntaxes
379 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
380 on older Perls, it does so merely by passing off the work
383 It does not remove the need for you to call
384 C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
385 C<Class::C3::uninitialize()> at the appropriate times
386 as documented in the L<Class::C3> docs. These three functions
387 are always provided by L<MRO::Compat>, either via L<Class::C3>
388 itself on older Perls, or directly as no-ops on 5.9.5+.
398 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
400 =head1 COPYRIGHT AND LICENSE
402 Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
404 This library is free software; you can redistribute it and/or modify
405 it under the same terms as Perl itself.