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 |
221173f0 |
8 | our $VERSION = '0.01_01'; |
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) { |
e9b18837 |
15 | require Class::C3; |
399a1dc7 |
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; |
763002b3 |
25 | $mro::VERSION = $VERSION; |
26 | $INC{'mro.pm'} = 'Faked by MRO::Compat'; |
4c4e4170 |
27 | } |
e9b18837 |
28 | |
29 | # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+ |
30 | else { |
31 | no warnings 'redefine'; |
32 | *Class::C3::initialize = sub { 1 }; |
33 | *Class::C3::reinitialize = sub { 1 }; |
34 | *Class::C3::uninitialize = sub { 1 }; |
35 | } |
4c4e4170 |
36 | } |
37 | |
4c4e4170 |
38 | =head1 NAME |
39 | |
42915ba4 |
40 | MRO::Compat - mro::* interface compatibility for Perls < 5.9.5 |
4c4e4170 |
41 | |
42 | =head1 SYNOPSIS |
43 | |
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/; |
48 | |
49 | package main; |
399a1dc7 |
50 | use MRO::Compat; |
4c4e4170 |
51 | my $linear = mro::get_linear_isa('FooClass'); |
399a1dc7 |
52 | print join(q{, }, @$linear); |
4c4e4170 |
53 | |
54 | # Prints: "FooClass, X, ZZZ, Y, Z" |
55 | |
56 | =head1 DESCRIPTION |
57 | |
58 | The "mro" namespace provides several utilities for dealing |
399a1dc7 |
59 | with method resolution order and method caching in general |
60 | in Perl 5.9.5 and higher. |
4c4e4170 |
61 | |
42915ba4 |
62 | This module provides those interfaces for |
e9b18837 |
63 | earlier versions of Perl (back to 5.6.0 anyways). |
64 | |
42915ba4 |
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 |
e9b18837 |
68 | here, and you want compatibility with older Perls, this |
69 | is the module for you. |
4c4e4170 |
70 | |
399a1dc7 |
71 | This module never exports any functions. All calls must |
72 | be fully qualified with the C<mro::> prefix. |
4c4e4170 |
73 | |
221173f0 |
74 | =head1 VERSION 0.01_01 |
75 | |
76 | This is the first dev release of this new module, and on top of that, |
77 | the Perl 5.9.5 it seeks to provide compatibility with isn't even |
78 | out yet. Consider it not fully stabilized for the time being. |
79 | These interfaces are not necessarily nailed down yet. |
80 | |
4c4e4170 |
81 | =head1 Functions |
82 | |
83 | =head2 mro::get_linear_isa($classname[, $type]) |
84 | |
85 | Returns an arrayref which is the linearized MRO of the given class. |
86 | Uses whichever MRO is currently in effect for that class by default, |
87 | or the given MRO (either C<c3> or C<dfs> if specified as C<$type>). |
88 | |
89 | The linearized MRO of a class is a single ordered list of all of the |
90 | classes that would be visited in the process of resolving a method |
91 | on the given class, starting with itself. It does not include any |
92 | duplicate entries. |
93 | |
4c4e4170 |
94 | Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not |
95 | part of the MRO of a class, even though all classes implicitly inherit |
96 | methods from C<UNIVERSAL> and its parents. |
97 | |
399a1dc7 |
98 | =cut |
99 | |
ed71cabb |
100 | sub __get_linear_isa_dfs { |
101 | no strict 'refs'; |
102 | |
103 | my $classname = shift; |
104 | |
105 | my @lin = ($classname); |
106 | my %stored; |
107 | foreach my $parent (@{"$classname\::ISA"}) { |
108 | my $plin = __get_linear_isa_dfs($parent); |
109 | foreach (@$plin) { |
110 | next if exists $stored{$_}; |
111 | push(@lin, $_); |
112 | $stored{$_} = 1; |
113 | } |
114 | } |
115 | return \@lin; |
116 | } |
117 | |
399a1dc7 |
118 | sub __get_linear_isa { |
ed71cabb |
119 | my ($classname, $type) = @_; |
120 | die "mro::get_mro requires a classname" if !$classname; |
121 | |
122 | $type ||= __get_mro($classname); |
123 | if($type eq 'dfs') { |
124 | return __get_linear_isa_dfs($classname); |
125 | } |
126 | elsif($type eq 'c3') { |
127 | return [Class::C3::calculateMRO($classname)]; |
128 | } |
129 | die "type argument must be 'dfs' or 'c3'"; |
399a1dc7 |
130 | } |
131 | |
132 | =head2 mro::import |
133 | |
e9b18837 |
134 | This allows the C<use mro 'dfs'> and |
135 | C<use mro 'c3'> syntaxes, providing you |
136 | L<use MRO::Compat> first. Please see the |
137 | L</USING C3> section for additional details. |
399a1dc7 |
138 | |
139 | =cut |
140 | |
141 | sub __import { |
e9b18837 |
142 | if($_[1]) { |
143 | goto &Class::C3::import if $_[1] eq 'c3'; |
144 | __set_mro(scalar(caller), $_[1]); |
145 | } |
399a1dc7 |
146 | } |
147 | |
4c4e4170 |
148 | =head2 mro::set_mro($classname, $type) |
149 | |
e9b18837 |
150 | Sets the mro of C<$classname> to one of the types |
151 | C<dfs> or C<c3>. Please see the L</USING C3> |
152 | section for additional details. |
399a1dc7 |
153 | |
154 | =cut |
155 | |
156 | sub __set_mro { |
e9b18837 |
157 | my ($classname, $type) = @_; |
158 | if(!$classname || !$type) { |
159 | die q{Usage: mro::set_mro($classname, $type)}; |
160 | } |
161 | if($type eq 'c3') { |
162 | eval "package $classname; use Class::C3"; |
163 | die $@ if $@; |
164 | } |
165 | if($type ne 'dfs') { |
166 | die q{Invalid mro type "$type"}; |
167 | } |
168 | |
763002b3 |
169 | # In the dfs case, check whether we need to undo C3 |
e9b18837 |
170 | if(defined $Class::C3::MRO{$classname}) { |
171 | Class::C3::_remove_method_dispatch_table($classname); |
172 | } |
173 | delete $Class::C3::MRO{$classname}; |
174 | |
175 | return; |
399a1dc7 |
176 | } |
4c4e4170 |
177 | |
178 | =head2 mro::get_mro($classname) |
179 | |
180 | Returns the MRO of the given class (either C<c3> or C<dfs>). |
181 | |
e9b18837 |
182 | It considers any Class::C3-using class to have C3 MRO |
183 | even before L<Class::C3::initialize()> is called. |
184 | |
399a1dc7 |
185 | =cut |
186 | |
187 | sub __get_mro { |
ed71cabb |
188 | my $classname = shift; |
399a1dc7 |
189 | die "mro::get_mro requires a classname" if !$classname; |
e9b18837 |
190 | return 'c3' if exists $Class::C3::MRO{$classname}; |
399a1dc7 |
191 | return 'dfs'; |
192 | } |
193 | |
4c4e4170 |
194 | =head2 mro::get_isarev($classname) |
195 | |
42915ba4 |
196 | Returns an array of classes who are subclasses of the |
197 | given classname. In other words, classes who we exists, |
198 | however indirectly, in the @ISA inheritancy hierarchy of. |
199 | |
200 | This is much slower on pre-5.9.5 Perls with MRO::Compat |
201 | than it is on 5.9.5+, as it has to search the entire |
202 | package namespace. |
399a1dc7 |
203 | |
204 | =cut |
205 | |
42915ba4 |
206 | sub __get_all_pkgs_with_isas { |
207 | no strict 'refs'; |
208 | no warnings 'recursion'; |
209 | |
210 | my @retval; |
211 | |
212 | my $search = shift; |
213 | my $pfx; |
214 | my $isa; |
215 | if($search) { |
216 | $isa = \@{"$search\::ISA"}; |
217 | $pfx = "$search\::"; |
218 | } |
219 | else { |
220 | $search = 'main'; |
221 | $isa = \@main::ISA; |
222 | $pfx = ''; |
223 | } |
224 | |
225 | push(@retval, $search) if scalar(@$isa); |
226 | |
227 | foreach my $cand (keys %{"$search\::"}) { |
228 | if($cand =~ /::$/) { |
229 | $cand =~ s/::$//; |
230 | next if $cand eq $search; # skip self-reference (main?) |
231 | push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)}); |
232 | } |
233 | } |
234 | |
235 | return \@retval; |
236 | } |
237 | |
238 | sub __get_isarev_recurse { |
239 | no strict 'refs'; |
240 | |
241 | my ($class, $all_isas, $level) = @_; |
242 | |
243 | die "Recursive inheritance detected" if $level > 100; |
244 | |
245 | my %retval; |
246 | |
247 | foreach my $cand (@$all_isas) { |
248 | my $found_me; |
249 | foreach (@{"$cand\::ISA"}) { |
250 | if($_ eq $class) { |
251 | $found_me = 1; |
252 | last; |
253 | } |
254 | } |
255 | if($found_me) { |
256 | $retval{$cand} = 1; |
257 | map { $retval{$_} = 1 } |
258 | @{__get_isarev_recurse($cand, $all_isas, $level+1)}; |
259 | } |
260 | } |
261 | return [keys %retval]; |
262 | } |
263 | |
399a1dc7 |
264 | sub __get_isarev { |
42915ba4 |
265 | my $classname = shift; |
266 | die "mro::get_isarev requires a classname" if !$classname; |
267 | |
d029d565 |
268 | @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)}; |
399a1dc7 |
269 | } |
4c4e4170 |
270 | |
271 | =head2 mro::is_universal($classname) |
272 | |
273 | Returns a boolean status indicating whether or not |
274 | the given classname is either C<UNIVERSAL> itself, |
275 | or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance. |
276 | |
277 | Any class for which this function returns true is |
278 | "universal" in the sense that all classes potentially |
279 | inherit methods from it. |
280 | |
399a1dc7 |
281 | =cut |
282 | |
283 | sub __is_universal { |
284 | my $classname = shift; |
285 | die "mro::is_universal requires a classname" if !$classname; |
286 | |
ac5a5a7f |
287 | my $lin = __get_linear_isa('UNIVERSAL'); |
399a1dc7 |
288 | foreach (@$lin) { |
289 | return 1 if $classname eq $_; |
290 | } |
291 | |
292 | return 0; |
293 | } |
294 | |
295 | =head2 mro::invalidate_all_method_caches |
4c4e4170 |
296 | |
297 | Increments C<PL_sub_generation>, which invalidates method |
298 | caching in all packages. |
299 | |
399a1dc7 |
300 | =cut |
301 | |
302 | sub __invalidate_all_method_caches { |
303 | # Super secret mystery code :) |
304 | @fedcba98::ISA = @fedcba98::ISA; |
305 | return; |
306 | } |
307 | |
4c4e4170 |
308 | =head2 mro::method_changed_in($classname) |
309 | |
310 | Invalidates the method cache of any classes dependent on the |
399a1dc7 |
311 | given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is |
312 | an alias for C<mro::invalidate_all_method_caches> above, as |
313 | pre-5.9.5 Perls have no other way to do this. It will still |
314 | enforce the requirement that you pass it a classname, for |
315 | compatibility. |
316 | |
317 | =cut |
318 | |
319 | sub __method_changed_in { |
320 | my $classname = shift; |
321 | die "mro::method_changed_in requires a classname" if !$classname; |
322 | |
323 | __invalidate_all_method_caches(); |
324 | } |
4c4e4170 |
325 | |
e9b18837 |
326 | =head1 USING C3 |
327 | |
328 | While this module makes the 5.9.5+ syntaxes |
329 | C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available |
330 | on older Perls, it does so merely by passing off the work |
331 | to L<Class::C3>. |
332 | |
333 | It does not remove the need for you to call |
334 | L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or |
335 | C<uninitialize()> at the appropriate times |
336 | as documented in the L<Class::C3> docs. |
337 | |
338 | Because L<MRO::Compat> has L<Class::C3> as a pre-requisite, |
339 | and requires it at C<use> time, you can blindly call |
340 | those functions in code that uses L<MRO::Compat>. |
341 | Under 5.9.5+ with L<MRO::Compat>, your calls to those |
342 | functions will become a no-op and everything will work fine. |
343 | |
4c4e4170 |
344 | =head1 SEE ALSO |
345 | |
346 | L<Class::C3> |
347 | |
399a1dc7 |
348 | L<mro> |
349 | |
4c4e4170 |
350 | =head1 AUTHOR |
351 | |
352 | Brandon L. Black, E<lt>blblack@gmail.comE<gt> |
353 | |
354 | =head1 COPYRIGHT AND LICENSE |
355 | |
356 | Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt> |
357 | |
358 | This library is free software; you can redistribute it and/or modify |
359 | it under the same terms as Perl itself. |
360 | |
361 | =cut |
362 | |
363 | 1; |