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 PPP; use base qw/Exporter/;
53 package X; use base qw/PPP/;
54 package Y; use base qw/PPP/;
55 package Z; use base qw/PPP/;
57 package FooClass; use base qw/X Y Z/;
61 my $linear = mro::get_linear_isa('FooClass');
62 print join(q{, }, @$linear);
64 # Prints: FooClass, X, PPP, Exporter, Y, Z
68 The "mro" namespace provides several utilities for dealing
69 with method resolution order and method caching in general
70 in Perl 5.9.5 and higher.
72 This module provides those interfaces for
73 earlier versions of Perl (back to 5.6.0 anyways).
75 It is a harmless no-op to use this module on 5.9.5+. That
76 is to say, code which properly uses L<MRO::Compat> will work
77 unmodified on both older Perls and 5.9.5+.
79 If you're writing a piece of software that would like to use
80 the parts of 5.9.5+'s mro:: interfaces that are supported
81 here, and you want compatibility with older Perls, this
82 is the module for you.
84 Some parts of this code will work better and/or faster with
85 L<Class::C3::XS> installed (which is an optional prereq
86 of L<Class::C3>, which is in turn a prereq of this
87 package), but it's not a requirement.
89 This module never exports any functions. All calls must
90 be fully qualified with the C<mro::> prefix.
92 The interface documentation here serves only as a quick
93 reference of what the function basically does, and what
94 differences between L<MRO::Compat> and 5.9.5+ one should
95 look out for. The main docs in 5.9.5's L<mro> are the real
96 interface docs, and contain a lot of other useful information.
100 =head2 mro::get_linear_isa($classname[, $type])
102 Returns an arrayref which is the linearized "ISA" of the given class.
103 Uses whichever MRO is currently in effect for that class by default,
104 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
106 The linearized ISA of a class is a single ordered list of all of the
107 classes that would be visited in the process of resolving a method
108 on the given class, starting with itself. It does not include any
111 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
112 part of the MRO of a class, even though all classes implicitly inherit
113 methods from C<UNIVERSAL> and its parents.
117 sub __get_linear_isa_dfs {
120 my $classname = shift;
122 my @lin = ($classname);
124 foreach my $parent (@{"$classname\::ISA"}) {
125 my $plin = __get_linear_isa_dfs($parent);
127 next if exists $stored{$_};
135 sub __get_linear_isa {
136 my ($classname, $type) = @_;
137 die "mro::get_mro requires a classname" if !defined $classname;
139 $type ||= __get_mro($classname);
141 return __get_linear_isa_dfs($classname);
143 elsif($type eq 'c3') {
144 return [Class::C3::calculateMRO($classname)];
146 die "type argument must be 'dfs' or 'c3'";
151 This allows the C<use mro 'dfs'> and
152 C<use mro 'c3'> syntaxes, providing you
153 L<use MRO::Compat> first. Please see the
154 L</USING C3> section for additional details.
160 goto &Class::C3::import if $_[1] eq 'c3';
161 __set_mro(scalar(caller), $_[1]);
165 =head2 mro::set_mro($classname, $type)
167 Sets the mro of C<$classname> to one of the types
168 C<dfs> or C<c3>. Please see the L</USING C3>
169 section for additional details.
174 my ($classname, $type) = @_;
176 if(!defined $classname || !$type) {
177 die q{Usage: mro::set_mro($classname, $type)};
181 eval "package $classname; use Class::C3";
184 elsif($type eq 'dfs') {
185 # In the dfs case, check whether we need to undo C3
186 if(defined $Class::C3::MRO{$classname}) {
187 Class::C3::_remove_method_dispatch_table($classname);
189 delete $Class::C3::MRO{$classname};
192 die qq{Invalid mro type "$type"};
198 =head2 mro::get_mro($classname)
200 Returns the MRO of the given class (either C<c3> or C<dfs>).
202 It considers any Class::C3-using class to have C3 MRO
203 even before L<Class::C3::initialize()> is called.
208 my $classname = shift;
209 die "mro::get_mro requires a classname" if !defined $classname;
210 return 'c3' if exists $Class::C3::MRO{$classname};
214 =head2 mro::get_isarev($classname)
216 Returns an arrayref of classes who are subclasses of the
217 given classname. In other words, classes in whose @ISA
218 hierarchy we appear, no matter how indirectly.
220 This is much slower on pre-5.9.5 Perls with MRO::Compat
221 than it is on 5.9.5+, as it has to search the entire
226 sub __get_all_pkgs_with_isas {
228 no warnings 'recursion';
235 if(defined $search) {
236 $isa = \@{"$search\::ISA"};
245 push(@retval, $search) if scalar(@$isa);
247 foreach my $cand (keys %{"$search\::"}) {
248 if($cand =~ s/::$//) {
249 next if $cand eq $search; # skip self-reference (main?)
250 push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
257 sub __get_isarev_recurse {
260 my ($class, $all_isas, $level) = @_;
262 die "Recursive inheritance detected" if $level > 100;
266 foreach my $cand (@$all_isas) {
268 foreach (@{"$cand\::ISA"}) {
276 map { $retval{$_} = 1 }
277 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
280 return [keys %retval];
284 my $classname = shift;
285 die "mro::get_isarev requires a classname" if !defined $classname;
287 __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
290 =head2 mro::is_universal($classname)
292 Returns a boolean status indicating whether or not
293 the given classname is either C<UNIVERSAL> itself,
294 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
296 Any class for which this function returns true is
297 "universal" in the sense that all classes potentially
298 inherit methods from it.
303 my $classname = shift;
304 die "mro::is_universal requires a classname" if !defined $classname;
306 my $lin = __get_linear_isa('UNIVERSAL');
308 return 1 if $classname eq $_;
314 =head2 mro::invalidate_all_method_caches
316 Increments C<PL_sub_generation>, which invalidates method
317 caching in all packages.
319 Please note that this is rarely necessary, unless you are
320 dealing with a situation which is known to confuse Perl's
325 sub __invalidate_all_method_caches {
326 # Super secret mystery code :)
327 @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
331 =head2 mro::method_changed_in($classname)
333 Invalidates the method cache of any classes dependent on the
334 given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
335 an alias for C<mro::invalidate_all_method_caches> above, as
336 pre-5.9.5 Perls have no other way to do this. It will still
337 enforce the requirement that you pass it a classname, for
340 Please note that this is rarely necessary, unless you are
341 dealing with a situation which is known to confuse Perl's
346 sub __method_changed_in {
347 my $classname = shift;
348 die "mro::method_changed_in requires a classname" if !defined $classname;
350 __invalidate_all_method_caches();
353 =head2 mro::get_pkg_gen($classname)
355 Returns an integer which is incremented every time a local
356 method of or the C<@ISA> of the given package changes on
357 Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module,
358 it will probably increment a lot more often than necessary.
364 sub __get_pkg_gen_pp {
365 my $classname = shift;
366 die "mro::get_pkg_gen requires a classname" if !defined $classname;
371 sub __get_pkg_gen_c3xs {
372 my $classname = shift;
373 die "mro::get_pkg_gen requires a classname" if !defined $classname;
375 return Class::C3::XS::_plsubgen();
380 While this module makes the 5.9.5+ syntaxes
381 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
382 on older Perls, it does so merely by passing off the work
385 It does not remove the need for you to call
386 C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
387 C<Class::C3::uninitialize()> at the appropriate times
388 as documented in the L<Class::C3> docs. These three functions
389 are always provided by L<MRO::Compat>, either via L<Class::C3>
390 itself on older Perls, or directly as no-ops on 5.9.5+.
400 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
402 =head1 COPYRIGHT AND LICENSE
404 Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
406 This library is free software; you can redistribute it and/or modify
407 it under the same terms as Perl itself.