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
16 *mro::import = \&__import;
17 *mro::get_linear_isa = \&__get_linear_isa;
18 *mro::set_mro = \&__set_mro;
19 *mro::get_mro = \&__get_mro;
20 *mro::get_isarev = \&__get_isarev;
21 *mro::is_universal = \&__is_universal;
22 *mro::method_changed_in = \&__method_changed_in;
23 *mro::invalidate_all_method_caches
24 = \&__invalidate_all_method_caches;
25 $mro::VERSION = $VERSION;
26 $INC{'mro.pm'} = 'Faked by MRO::Compat';
29 # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+
31 no warnings 'redefine';
32 *Class::C3::initialize = sub { 1 };
33 *Class::C3::reinitialize = sub { 1 };
34 *Class::C3::uninitialize = sub { 1 };
40 MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
44 package FooClass; use base qw/X Y Z/;
45 package X; use base qw/ZZZ/;
46 package Y; use base qw/ZZZ/;
47 package Z; use base qw/ZZZ/;
51 my $linear = mro::get_linear_isa('FooClass');
52 print join(q{, }, @$linear);
54 # Prints: "FooClass, X, ZZZ, Y, Z"
58 The "mro" namespace provides several utilities for dealing
59 with method resolution order and method caching in general
60 in Perl 5.9.5 and higher.
62 This module provides those interfaces for
63 earlier versions of Perl (back to 5.6.0 anyways).
65 It is a harmless no-op to use this module on 5.9.5+. If
66 you're writing a piece of software that would like to use
67 the parts of 5.9.5+'s mro:: interfaces that are supported
68 here, and you want compatibility with older Perls, this
69 is the module for you.
71 This module never exports any functions. All calls must
72 be fully qualified with the C<mro::> prefix.
76 =head2 mro::get_linear_isa($classname[, $type])
78 Returns an arrayref which is the linearized MRO of the given class.
79 Uses whichever MRO is currently in effect for that class by default,
80 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
82 The linearized MRO of a class is a single ordered list of all of the
83 classes that would be visited in the process of resolving a method
84 on the given class, starting with itself. It does not include any
87 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
88 part of the MRO of a class, even though all classes implicitly inherit
89 methods from C<UNIVERSAL> and its parents.
93 sub __get_linear_isa_dfs {
96 my $classname = shift;
98 my @lin = ($classname);
100 foreach my $parent (@{"$classname\::ISA"}) {
101 my $plin = __get_linear_isa_dfs($parent);
103 next if exists $stored{$_};
111 sub __get_linear_isa {
112 my ($classname, $type) = @_;
113 die "mro::get_mro requires a classname" if !$classname;
115 $type ||= __get_mro($classname);
117 return __get_linear_isa_dfs($classname);
119 elsif($type eq 'c3') {
120 return [Class::C3::calculateMRO($classname)];
122 die "type argument must be 'dfs' or 'c3'";
127 This allows the C<use mro 'dfs'> and
128 C<use mro 'c3'> syntaxes, providing you
129 L<use MRO::Compat> first. Please see the
130 L</USING C3> section for additional details.
136 goto &Class::C3::import if $_[1] eq 'c3';
137 __set_mro(scalar(caller), $_[1]);
141 =head2 mro::set_mro($classname, $type)
143 Sets the mro of C<$classname> to one of the types
144 C<dfs> or C<c3>. Please see the L</USING C3>
145 section for additional details.
150 my ($classname, $type) = @_;
151 if(!$classname || !$type) {
152 die q{Usage: mro::set_mro($classname, $type)};
155 eval "package $classname; use Class::C3";
159 die q{Invalid mro type "$type"};
162 # In the dfs case, check whether we need to undo C3
163 if(defined $Class::C3::MRO{$classname}) {
164 Class::C3::_remove_method_dispatch_table($classname);
166 delete $Class::C3::MRO{$classname};
171 =head2 mro::get_mro($classname)
173 Returns the MRO of the given class (either C<c3> or C<dfs>).
175 It considers any Class::C3-using class to have C3 MRO
176 even before L<Class::C3::initialize()> is called.
181 my $classname = shift;
182 die "mro::get_mro requires a classname" if !$classname;
183 return 'c3' if exists $Class::C3::MRO{$classname};
187 =head2 mro::get_isarev($classname)
189 Returns an array of classes who are subclasses of the
190 given classname. In other words, classes who we exists,
191 however indirectly, in the @ISA inheritancy hierarchy of.
193 This is much slower on pre-5.9.5 Perls with MRO::Compat
194 than it is on 5.9.5+, as it has to search the entire
199 sub __get_all_pkgs_with_isas {
201 no warnings 'recursion';
209 $isa = \@{"$search\::ISA"};
218 push(@retval, $search) if scalar(@$isa);
220 foreach my $cand (keys %{"$search\::"}) {
223 next if $cand eq $search; # skip self-reference (main?)
224 push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
231 sub __get_isarev_recurse {
234 my ($class, $all_isas, $level) = @_;
236 die "Recursive inheritance detected" if $level > 100;
240 foreach my $cand (@$all_isas) {
242 foreach (@{"$cand\::ISA"}) {
250 map { $retval{$_} = 1 }
251 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
254 return [keys %retval];
258 my $classname = shift;
259 die "mro::get_isarev requires a classname" if !$classname;
261 @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
264 =head2 mro::is_universal($classname)
266 Returns a boolean status indicating whether or not
267 the given classname is either C<UNIVERSAL> itself,
268 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
270 Any class for which this function returns true is
271 "universal" in the sense that all classes potentially
272 inherit methods from it.
277 my $classname = shift;
278 die "mro::is_universal requires a classname" if !$classname;
280 my $lin = __get_linear_isa('UNIVERSAL');
282 return 1 if $classname eq $_;
288 =head2 mro::invalidate_all_method_caches
290 Increments C<PL_sub_generation>, which invalidates method
291 caching in all packages.
295 sub __invalidate_all_method_caches {
296 # Super secret mystery code :)
297 @fedcba98::ISA = @fedcba98::ISA;
301 =head2 mro::method_changed_in($classname)
303 Invalidates the method cache of any classes dependent on the
304 given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
305 an alias for C<mro::invalidate_all_method_caches> above, as
306 pre-5.9.5 Perls have no other way to do this. It will still
307 enforce the requirement that you pass it a classname, for
312 sub __method_changed_in {
313 my $classname = shift;
314 die "mro::method_changed_in requires a classname" if !$classname;
316 __invalidate_all_method_caches();
321 While this module makes the 5.9.5+ syntaxes
322 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
323 on older Perls, it does so merely by passing off the work
326 It does not remove the need for you to call
327 L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
328 C<uninitialize()> at the appropriate times
329 as documented in the L<Class::C3> docs.
331 Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
332 and requires it at C<use> time, you can blindly call
333 those functions in code that uses L<MRO::Compat>.
334 Under 5.9.5+ with L<MRO::Compat>, your calls to those
335 functions will become a no-op and everything will work fine.
345 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
347 =head1 COPYRIGHT AND LICENSE
349 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
351 This library is free software; you can redistribute it and/or modify
352 it under the same terms as Perl itself.