9 # Alias our private functions over to
10 # the mro:: namespace and load
11 # Class::C3 if Perl < 5.9.5
14 *mro::import = \&__import;
15 *mro::get_linear_isa = \&__get_linear_isa;
16 *mro::set_mro = \&__set_mro;
17 *mro::get_mro = \&__get_mro;
18 *mro::get_isarev = \&__get_isarev;
19 *mro::is_universal = \&__is_universal;
20 *mro::method_changed_in = \&__method_changed_in;
21 *mro::invalidate_all_method_caches
22 = \&__invalidate_all_method_caches;
25 # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+
27 no warnings 'redefine';
28 *Class::C3::initialize = sub { 1 };
29 *Class::C3::reinitialize = sub { 1 };
30 *Class::C3::uninitialize = sub { 1 };
36 MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
40 package FooClass; use base qw/X Y Z/;
41 package X; use base qw/ZZZ/;
42 package Y; use base qw/ZZZ/;
43 package Z; use base qw/ZZZ/;
47 my $linear = mro::get_linear_isa('FooClass');
48 print join(q{, }, @$linear);
50 # Prints: "FooClass, X, ZZZ, Y, Z"
54 The "mro" namespace provides several utilities for dealing
55 with method resolution order and method caching in general
56 in Perl 5.9.5 and higher.
58 This module provides those interfaces for
59 earlier versions of Perl (back to 5.6.0 anyways).
61 It is a harmless no-op to use this module on 5.9.5+. If
62 you're writing a piece of software that would like to use
63 the parts of 5.9.5+'s mro:: interfaces that are supported
64 here, and you want compatibility with older Perls, this
65 is the module for you.
67 This module never exports any functions. All calls must
68 be fully qualified with the C<mro::> prefix.
72 =head2 mro::get_linear_isa($classname[, $type])
74 Returns an arrayref which is the linearized MRO of the given class.
75 Uses whichever MRO is currently in effect for that class by default,
76 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
78 The linearized MRO of a class is a single ordered list of all of the
79 classes that would be visited in the process of resolving a method
80 on the given class, starting with itself. It does not include any
83 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
84 part of the MRO of a class, even though all classes implicitly inherit
85 methods from C<UNIVERSAL> and its parents.
89 sub __get_linear_isa_dfs {
92 my $classname = shift;
94 my @lin = ($classname);
96 foreach my $parent (@{"$classname\::ISA"}) {
97 my $plin = __get_linear_isa_dfs($parent);
99 next if exists $stored{$_};
107 sub __get_linear_isa {
108 my ($classname, $type) = @_;
109 die "mro::get_mro requires a classname" if !$classname;
111 $type ||= __get_mro($classname);
113 return __get_linear_isa_dfs($classname);
115 elsif($type eq 'c3') {
116 return [Class::C3::calculateMRO($classname)];
118 die "type argument must be 'dfs' or 'c3'";
123 This allows the C<use mro 'dfs'> and
124 C<use mro 'c3'> syntaxes, providing you
125 L<use MRO::Compat> first. Please see the
126 L</USING C3> section for additional details.
132 goto &Class::C3::import if $_[1] eq 'c3';
133 __set_mro(scalar(caller), $_[1]);
137 =head2 mro::set_mro($classname, $type)
139 Sets the mro of C<$classname> to one of the types
140 C<dfs> or C<c3>. Please see the L</USING C3>
141 section for additional details.
146 my ($classname, $type) = @_;
147 if(!$classname || !$type) {
148 die q{Usage: mro::set_mro($classname, $type)};
151 eval "package $classname; use Class::C3";
155 die q{Invalid mro type "$type"};
158 # In the dfs case, check whether we need to
160 if(defined $Class::C3::MRO{$classname}) {
161 Class::C3::_remove_method_dispatch_table($classname);
163 delete $Class::C3::MRO{$classname};
168 =head2 mro::get_mro($classname)
170 Returns the MRO of the given class (either C<c3> or C<dfs>).
172 It considers any Class::C3-using class to have C3 MRO
173 even before L<Class::C3::initialize()> is called.
178 my $classname = shift;
179 die "mro::get_mro requires a classname" if !$classname;
180 return 'c3' if exists $Class::C3::MRO{$classname};
184 =head2 mro::get_isarev($classname)
186 Returns an array of classes who are subclasses of the
187 given classname. In other words, classes who we exists,
188 however indirectly, in the @ISA inheritancy hierarchy of.
190 This is much slower on pre-5.9.5 Perls with MRO::Compat
191 than it is on 5.9.5+, as it has to search the entire
196 sub __get_all_pkgs_with_isas {
198 no warnings 'recursion';
206 $isa = \@{"$search\::ISA"};
215 push(@retval, $search) if scalar(@$isa);
217 foreach my $cand (keys %{"$search\::"}) {
220 next if $cand eq $search; # skip self-reference (main?)
221 push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
228 sub __get_isarev_recurse {
231 my ($class, $all_isas, $level) = @_;
233 die "Recursive inheritance detected" if $level > 100;
237 foreach my $cand (@$all_isas) {
239 foreach (@{"$cand\::ISA"}) {
247 map { $retval{$_} = 1 }
248 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
251 return [keys %retval];
255 my $classname = shift;
256 die "mro::get_isarev requires a classname" if !$classname;
258 @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
261 =head2 mro::is_universal($classname)
263 Returns a boolean status indicating whether or not
264 the given classname is either C<UNIVERSAL> itself,
265 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
267 Any class for which this function returns true is
268 "universal" in the sense that all classes potentially
269 inherit methods from it.
274 my $classname = shift;
275 die "mro::is_universal requires a classname" if !$classname;
277 my $lin = __get_linear_isa('UNIVERSAL');
279 return 1 if $classname eq $_;
285 =head2 mro::invalidate_all_method_caches
287 Increments C<PL_sub_generation>, which invalidates method
288 caching in all packages.
292 sub __invalidate_all_method_caches {
293 # Super secret mystery code :)
294 @fedcba98::ISA = @fedcba98::ISA;
298 =head2 mro::method_changed_in($classname)
300 Invalidates the method cache of any classes dependent on the
301 given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
302 an alias for C<mro::invalidate_all_method_caches> above, as
303 pre-5.9.5 Perls have no other way to do this. It will still
304 enforce the requirement that you pass it a classname, for
309 sub __method_changed_in {
310 my $classname = shift;
311 die "mro::method_changed_in requires a classname" if !$classname;
313 __invalidate_all_method_caches();
318 While this module makes the 5.9.5+ syntaxes
319 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
320 on older Perls, it does so merely by passing off the work
323 It does not remove the need for you to call
324 L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
325 C<uninitialize()> at the appropriate times
326 as documented in the L<Class::C3> docs.
328 Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
329 and requires it at C<use> time, you can blindly call
330 those functions in code that uses L<MRO::Compat>.
331 Under 5.9.5+ with L<MRO::Compat>, your calls to those
332 functions will become a no-op and everything will work fine.
342 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
344 =head1 COPYRIGHT AND LICENSE
346 Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
348 This library is free software; you can redistribute it and/or modify
349 it under the same terms as Perl itself.