Commit | Line | Data |
399a1dc7 |
1 | package MRO::Compat; |
4c4e4170 |
2 | use strict; |
3 | use warnings; |
e9b18837 |
4 | require 5.006_000; |
4c4e4170 |
5 | |
763002b3 |
6 | # Keep this < 1.00, so people can tell the fake |
7 | # mro.pm from the real one |
385554b5 |
8 | our $VERSION = '0.12'; |
4c4e4170 |
9 | |
4c4e4170 |
10 | BEGIN { |
e9b18837 |
11 | # Alias our private functions over to |
12 | # the mro:: namespace and load |
13 | # Class::C3 if Perl < 5.9.5 |
399a1dc7 |
14 | if($] < 5.009_005) { |
cbb1ce9a |
15 | $mro::VERSION # to fool Module::Install when generating META.yml |
16 | = $VERSION; |
7fbc4482 |
17 | $INC{'mro.pm'} = __FILE__; |
399a1dc7 |
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; |
a9edfcb9 |
27 | require Class::C3; |
28 | if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) { |
29 | *mro::get_pkg_gen = \&__get_pkg_gen_c3xs; |
30 | } |
31 | else { |
32 | *mro::get_pkg_gen = \&__get_pkg_gen_pp; |
33 | } |
4c4e4170 |
34 | } |
e9b18837 |
35 | |
0f01303c |
36 | # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+ |
e9b18837 |
37 | else { |
0f01303c |
38 | require mro; |
e9b18837 |
39 | no warnings 'redefine'; |
40 | *Class::C3::initialize = sub { 1 }; |
41 | *Class::C3::reinitialize = sub { 1 }; |
42 | *Class::C3::uninitialize = sub { 1 }; |
43 | } |
4c4e4170 |
44 | } |
45 | |
4c4e4170 |
46 | =head1 NAME |
47 | |
42915ba4 |
48 | MRO::Compat - mro::* interface compatibility for Perls < 5.9.5 |
4c4e4170 |
49 | |
50 | =head1 SYNOPSIS |
51 | |
78e400de |
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/; |
56 | |
4c4e4170 |
57 | package FooClass; use base qw/X Y Z/; |
4c4e4170 |
58 | |
59 | package main; |
399a1dc7 |
60 | use MRO::Compat; |
4c4e4170 |
61 | my $linear = mro::get_linear_isa('FooClass'); |
399a1dc7 |
62 | print join(q{, }, @$linear); |
4c4e4170 |
63 | |
78e400de |
64 | # Prints: FooClass, X, PPP, Exporter, Y, Z |
4c4e4170 |
65 | |
66 | =head1 DESCRIPTION |
67 | |
68 | The "mro" namespace provides several utilities for dealing |
399a1dc7 |
69 | with method resolution order and method caching in general |
70 | in Perl 5.9.5 and higher. |
4c4e4170 |
71 | |
42915ba4 |
72 | This module provides those interfaces for |
e9b18837 |
73 | earlier versions of Perl (back to 5.6.0 anyways). |
74 | |
81350029 |
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+. |
78 | |
79 | If you're writing a piece of software that would like to use |
42915ba4 |
80 | the parts of 5.9.5+'s mro:: interfaces that are supported |
e9b18837 |
81 | here, and you want compatibility with older Perls, this |
82 | is the module for you. |
4c4e4170 |
83 | |
81350029 |
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. |
a9edfcb9 |
88 | |
399a1dc7 |
89 | This module never exports any functions. All calls must |
90 | be fully qualified with the C<mro::> prefix. |
4c4e4170 |
91 | |
a9edfcb9 |
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. |
221173f0 |
97 | |
4c4e4170 |
98 | =head1 Functions |
99 | |
100 | =head2 mro::get_linear_isa($classname[, $type]) |
101 | |
602f6319 |
102 | Returns an arrayref which is the linearized "ISA" of the given class. |
4c4e4170 |
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>). |
105 | |
602f6319 |
106 | The linearized ISA of a class is a single ordered list of all of the |
4c4e4170 |
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 |
109 | duplicate entries. |
110 | |
4c4e4170 |
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. |
114 | |
399a1dc7 |
115 | =cut |
116 | |
ed71cabb |
117 | sub __get_linear_isa_dfs { |
118 | no strict 'refs'; |
119 | |
120 | my $classname = shift; |
121 | |
122 | my @lin = ($classname); |
123 | my %stored; |
124 | foreach my $parent (@{"$classname\::ISA"}) { |
125 | my $plin = __get_linear_isa_dfs($parent); |
126 | foreach (@$plin) { |
127 | next if exists $stored{$_}; |
128 | push(@lin, $_); |
129 | $stored{$_} = 1; |
130 | } |
131 | } |
132 | return \@lin; |
133 | } |
134 | |
399a1dc7 |
135 | sub __get_linear_isa { |
ed71cabb |
136 | my ($classname, $type) = @_; |
81350029 |
137 | die "mro::get_mro requires a classname" if !defined $classname; |
ed71cabb |
138 | |
139 | $type ||= __get_mro($classname); |
140 | if($type eq 'dfs') { |
141 | return __get_linear_isa_dfs($classname); |
142 | } |
143 | elsif($type eq 'c3') { |
144 | return [Class::C3::calculateMRO($classname)]; |
145 | } |
146 | die "type argument must be 'dfs' or 'c3'"; |
399a1dc7 |
147 | } |
148 | |
149 | =head2 mro::import |
150 | |
e9b18837 |
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. |
399a1dc7 |
155 | |
156 | =cut |
157 | |
158 | sub __import { |
e9b18837 |
159 | if($_[1]) { |
160 | goto &Class::C3::import if $_[1] eq 'c3'; |
161 | __set_mro(scalar(caller), $_[1]); |
162 | } |
399a1dc7 |
163 | } |
164 | |
4c4e4170 |
165 | =head2 mro::set_mro($classname, $type) |
166 | |
e9b18837 |
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. |
399a1dc7 |
170 | |
171 | =cut |
172 | |
173 | sub __set_mro { |
e9b18837 |
174 | my ($classname, $type) = @_; |
fd0bf490 |
175 | |
81350029 |
176 | if(!defined $classname || !$type) { |
e9b18837 |
177 | die q{Usage: mro::set_mro($classname, $type)}; |
178 | } |
fd0bf490 |
179 | |
e9b18837 |
180 | if($type eq 'c3') { |
181 | eval "package $classname; use Class::C3"; |
182 | die $@ if $@; |
183 | } |
fd0bf490 |
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); |
188 | } |
189 | delete $Class::C3::MRO{$classname}; |
e9b18837 |
190 | } |
fd0bf490 |
191 | else { |
192 | die qq{Invalid mro type "$type"}; |
e9b18837 |
193 | } |
e9b18837 |
194 | |
195 | return; |
399a1dc7 |
196 | } |
4c4e4170 |
197 | |
198 | =head2 mro::get_mro($classname) |
199 | |
200 | Returns the MRO of the given class (either C<c3> or C<dfs>). |
201 | |
e9b18837 |
202 | It considers any Class::C3-using class to have C3 MRO |
203 | even before L<Class::C3::initialize()> is called. |
204 | |
399a1dc7 |
205 | =cut |
206 | |
207 | sub __get_mro { |
ed71cabb |
208 | my $classname = shift; |
81350029 |
209 | die "mro::get_mro requires a classname" if !defined $classname; |
e9b18837 |
210 | return 'c3' if exists $Class::C3::MRO{$classname}; |
399a1dc7 |
211 | return 'dfs'; |
212 | } |
213 | |
4c4e4170 |
214 | =head2 mro::get_isarev($classname) |
215 | |
a9edfcb9 |
216 | Returns an arrayref of classes who are subclasses of the |
1e7b24f4 |
217 | given classname. In other words, classes in whose @ISA |
218 | hierarchy we appear, no matter how indirectly. |
42915ba4 |
219 | |
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 |
222 | package namespace. |
399a1dc7 |
223 | |
224 | =cut |
225 | |
42915ba4 |
226 | sub __get_all_pkgs_with_isas { |
227 | no strict 'refs'; |
228 | no warnings 'recursion'; |
229 | |
230 | my @retval; |
231 | |
232 | my $search = shift; |
233 | my $pfx; |
234 | my $isa; |
66b426e8 |
235 | if(defined $search) { |
42915ba4 |
236 | $isa = \@{"$search\::ISA"}; |
237 | $pfx = "$search\::"; |
238 | } |
239 | else { |
240 | $search = 'main'; |
241 | $isa = \@main::ISA; |
242 | $pfx = ''; |
243 | } |
244 | |
245 | push(@retval, $search) if scalar(@$isa); |
246 | |
247 | foreach my $cand (keys %{"$search\::"}) { |
81350029 |
248 | if($cand =~ s/::$//) { |
42915ba4 |
249 | next if $cand eq $search; # skip self-reference (main?) |
250 | push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)}); |
251 | } |
252 | } |
253 | |
254 | return \@retval; |
255 | } |
256 | |
257 | sub __get_isarev_recurse { |
258 | no strict 'refs'; |
259 | |
260 | my ($class, $all_isas, $level) = @_; |
261 | |
262 | die "Recursive inheritance detected" if $level > 100; |
263 | |
264 | my %retval; |
265 | |
266 | foreach my $cand (@$all_isas) { |
267 | my $found_me; |
268 | foreach (@{"$cand\::ISA"}) { |
269 | if($_ eq $class) { |
270 | $found_me = 1; |
271 | last; |
272 | } |
273 | } |
274 | if($found_me) { |
275 | $retval{$cand} = 1; |
276 | map { $retval{$_} = 1 } |
277 | @{__get_isarev_recurse($cand, $all_isas, $level+1)}; |
278 | } |
279 | } |
280 | return [keys %retval]; |
281 | } |
282 | |
399a1dc7 |
283 | sub __get_isarev { |
42915ba4 |
284 | my $classname = shift; |
81350029 |
285 | die "mro::get_isarev requires a classname" if !defined $classname; |
42915ba4 |
286 | |
a9edfcb9 |
287 | __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0); |
399a1dc7 |
288 | } |
4c4e4170 |
289 | |
290 | =head2 mro::is_universal($classname) |
291 | |
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. |
295 | |
296 | Any class for which this function returns true is |
297 | "universal" in the sense that all classes potentially |
298 | inherit methods from it. |
299 | |
399a1dc7 |
300 | =cut |
301 | |
302 | sub __is_universal { |
303 | my $classname = shift; |
81350029 |
304 | die "mro::is_universal requires a classname" if !defined $classname; |
399a1dc7 |
305 | |
ac5a5a7f |
306 | my $lin = __get_linear_isa('UNIVERSAL'); |
399a1dc7 |
307 | foreach (@$lin) { |
308 | return 1 if $classname eq $_; |
309 | } |
310 | |
311 | return 0; |
312 | } |
313 | |
314 | =head2 mro::invalidate_all_method_caches |
4c4e4170 |
315 | |
316 | Increments C<PL_sub_generation>, which invalidates method |
317 | caching in all packages. |
318 | |
a9edfcb9 |
319 | Please note that this is rarely necessary, unless you are |
320 | dealing with a situation which is known to confuse Perl's |
321 | method caching. |
322 | |
399a1dc7 |
323 | =cut |
324 | |
325 | sub __invalidate_all_method_caches { |
326 | # Super secret mystery code :) |
81350029 |
327 | @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA; |
399a1dc7 |
328 | return; |
329 | } |
330 | |
4c4e4170 |
331 | =head2 mro::method_changed_in($classname) |
332 | |
333 | Invalidates the method cache of any classes dependent on the |
399a1dc7 |
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 |
338 | compatibility. |
339 | |
a9edfcb9 |
340 | Please note that this is rarely necessary, unless you are |
341 | dealing with a situation which is known to confuse Perl's |
342 | method caching. |
343 | |
399a1dc7 |
344 | =cut |
345 | |
346 | sub __method_changed_in { |
347 | my $classname = shift; |
81350029 |
348 | die "mro::method_changed_in requires a classname" if !defined $classname; |
399a1dc7 |
349 | |
350 | __invalidate_all_method_caches(); |
351 | } |
4c4e4170 |
352 | |
a9edfcb9 |
353 | =head2 mro::get_pkg_gen($classname) |
354 | |
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. |
359 | |
360 | =cut |
361 | |
81350029 |
362 | { |
363 | my $__pkg_gen = 2; |
364 | sub __get_pkg_gen_pp { |
365 | my $classname = shift; |
366 | die "mro::get_pkg_gen requires a classname" if !defined $classname; |
367 | return $__pkg_gen++; |
368 | } |
a9edfcb9 |
369 | } |
370 | |
371 | sub __get_pkg_gen_c3xs { |
372 | my $classname = shift; |
81350029 |
373 | die "mro::get_pkg_gen requires a classname" if !defined $classname; |
a9edfcb9 |
374 | |
375 | return Class::C3::XS::_plsubgen(); |
376 | } |
377 | |
e9b18837 |
378 | =head1 USING C3 |
379 | |
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 |
383 | to L<Class::C3>. |
384 | |
385 | It does not remove the need for you to call |
81350029 |
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+. |
e9b18837 |
391 | |
4c4e4170 |
392 | =head1 SEE ALSO |
393 | |
394 | L<Class::C3> |
395 | |
399a1dc7 |
396 | L<mro> |
397 | |
4c4e4170 |
398 | =head1 AUTHOR |
399 | |
400 | Brandon L. Black, E<lt>blblack@gmail.comE<gt> |
401 | |
402 | =head1 COPYRIGHT AND LICENSE |
403 | |
602f6319 |
404 | Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt> |
4c4e4170 |
405 | |
406 | This library is free software; you can redistribute it and/or modify |
407 | it under the same terms as Perl itself. |
408 | |
409 | =cut |
410 | |
411 | 1; |