Commit | Line | Data |
399a1dc7 |
1 | package MRO::Compat; |
4c4e4170 |
2 | use strict; |
3 | use warnings; |
e9b18837 |
4 | require 5.006_000; |
4c4e4170 |
5 | |
4c4e4170 |
6 | our $VERSION = '0.01'; |
7 | |
4c4e4170 |
8 | BEGIN { |
e9b18837 |
9 | # Alias our private functions over to |
10 | # the mro:: namespace and load |
11 | # Class::C3 if Perl < 5.9.5 |
399a1dc7 |
12 | if($] < 5.009_005) { |
e9b18837 |
13 | require Class::C3; |
399a1dc7 |
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; |
4c4e4170 |
23 | } |
e9b18837 |
24 | |
25 | # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+ |
26 | else { |
27 | no warnings 'redefine'; |
28 | *Class::C3::initialize = sub { 1 }; |
29 | *Class::C3::reinitialize = sub { 1 }; |
30 | *Class::C3::uninitialize = sub { 1 }; |
31 | } |
4c4e4170 |
32 | } |
33 | |
4c4e4170 |
34 | =head1 NAME |
35 | |
399a1dc7 |
36 | MRO::Compat - Partial mro::* interface compatibility for Perls < 5.9.5 |
4c4e4170 |
37 | |
38 | =head1 SYNOPSIS |
39 | |
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/; |
44 | |
45 | package main; |
399a1dc7 |
46 | use MRO::Compat; |
4c4e4170 |
47 | my $linear = mro::get_linear_isa('FooClass'); |
399a1dc7 |
48 | print join(q{, }, @$linear); |
4c4e4170 |
49 | |
50 | # Prints: "FooClass, X, ZZZ, Y, Z" |
51 | |
52 | =head1 DESCRIPTION |
53 | |
54 | The "mro" namespace provides several utilities for dealing |
399a1dc7 |
55 | with method resolution order and method caching in general |
56 | in Perl 5.9.5 and higher. |
4c4e4170 |
57 | |
399a1dc7 |
58 | This module provides a subset of those interfaces for |
e9b18837 |
59 | earlier versions of Perl (back to 5.6.0 anyways). |
60 | |
61 | It is a harmless no-op to use it on 5.9.5+. If you're |
62 | writing a piece of software that would like to use the |
63 | 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. |
4c4e4170 |
66 | |
399a1dc7 |
67 | This module never exports any functions. All calls must |
68 | be fully qualified with the C<mro::> prefix. |
4c4e4170 |
69 | |
70 | =head1 Functions |
71 | |
72 | =head2 mro::get_linear_isa($classname[, $type]) |
73 | |
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>). |
77 | |
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 |
81 | duplicate entries. |
82 | |
4c4e4170 |
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. |
86 | |
399a1dc7 |
87 | =cut |
88 | |
ed71cabb |
89 | sub __get_linear_isa_dfs { |
90 | no strict 'refs'; |
91 | |
92 | my $classname = shift; |
93 | |
94 | my @lin = ($classname); |
95 | my %stored; |
96 | foreach my $parent (@{"$classname\::ISA"}) { |
97 | my $plin = __get_linear_isa_dfs($parent); |
98 | foreach (@$plin) { |
99 | next if exists $stored{$_}; |
100 | push(@lin, $_); |
101 | $stored{$_} = 1; |
102 | } |
103 | } |
104 | return \@lin; |
105 | } |
106 | |
399a1dc7 |
107 | sub __get_linear_isa { |
ed71cabb |
108 | my ($classname, $type) = @_; |
109 | die "mro::get_mro requires a classname" if !$classname; |
110 | |
111 | $type ||= __get_mro($classname); |
112 | if($type eq 'dfs') { |
113 | return __get_linear_isa_dfs($classname); |
114 | } |
115 | elsif($type eq 'c3') { |
116 | return [Class::C3::calculateMRO($classname)]; |
117 | } |
118 | die "type argument must be 'dfs' or 'c3'"; |
399a1dc7 |
119 | } |
120 | |
121 | =head2 mro::import |
122 | |
e9b18837 |
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. |
399a1dc7 |
127 | |
128 | =cut |
129 | |
130 | sub __import { |
e9b18837 |
131 | if($_[1]) { |
132 | goto &Class::C3::import if $_[1] eq 'c3'; |
133 | __set_mro(scalar(caller), $_[1]); |
134 | } |
399a1dc7 |
135 | } |
136 | |
4c4e4170 |
137 | =head2 mro::set_mro($classname, $type) |
138 | |
e9b18837 |
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. |
399a1dc7 |
142 | |
143 | =cut |
144 | |
145 | sub __set_mro { |
e9b18837 |
146 | my ($classname, $type) = @_; |
147 | if(!$classname || !$type) { |
148 | die q{Usage: mro::set_mro($classname, $type)}; |
149 | } |
150 | if($type eq 'c3') { |
151 | eval "package $classname; use Class::C3"; |
152 | die $@ if $@; |
153 | } |
154 | if($type ne 'dfs') { |
155 | die q{Invalid mro type "$type"}; |
156 | } |
157 | |
158 | # In the dfs case, check whether we need to |
159 | # undo C3 |
160 | if(defined $Class::C3::MRO{$classname}) { |
161 | Class::C3::_remove_method_dispatch_table($classname); |
162 | } |
163 | delete $Class::C3::MRO{$classname}; |
164 | |
165 | return; |
399a1dc7 |
166 | } |
4c4e4170 |
167 | |
168 | =head2 mro::get_mro($classname) |
169 | |
170 | Returns the MRO of the given class (either C<c3> or C<dfs>). |
171 | |
e9b18837 |
172 | It considers any Class::C3-using class to have C3 MRO |
173 | even before L<Class::C3::initialize()> is called. |
174 | |
399a1dc7 |
175 | =cut |
176 | |
177 | sub __get_mro { |
ed71cabb |
178 | my $classname = shift; |
399a1dc7 |
179 | die "mro::get_mro requires a classname" if !$classname; |
e9b18837 |
180 | return 'c3' if exists $Class::C3::MRO{$classname}; |
399a1dc7 |
181 | return 'dfs'; |
182 | } |
183 | |
4c4e4170 |
184 | =head2 mro::get_isarev($classname) |
185 | |
399a1dc7 |
186 | Not supported, will die if used on pre-5.9.5 Perls. |
187 | |
188 | =cut |
189 | |
e9b18837 |
190 | # In theory this could be made to work, but it would |
191 | # be an insanely slow algorithm if any reasonably large |
192 | # number of modules were loaded. |
399a1dc7 |
193 | sub __get_isarev { |
194 | die "mro::get_isarev() is only supported on Perl 5.9.5+"; |
195 | } |
4c4e4170 |
196 | |
197 | =head2 mro::is_universal($classname) |
198 | |
199 | Returns a boolean status indicating whether or not |
200 | the given classname is either C<UNIVERSAL> itself, |
201 | or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance. |
202 | |
203 | Any class for which this function returns true is |
204 | "universal" in the sense that all classes potentially |
205 | inherit methods from it. |
206 | |
399a1dc7 |
207 | =cut |
208 | |
209 | sub __is_universal { |
210 | my $classname = shift; |
211 | die "mro::is_universal requires a classname" if !$classname; |
212 | |
213 | my $lin = __get_linear_isa($classname); |
214 | foreach (@$lin) { |
215 | return 1 if $classname eq $_; |
216 | } |
217 | |
218 | return 0; |
219 | } |
220 | |
221 | =head2 mro::invalidate_all_method_caches |
4c4e4170 |
222 | |
223 | Increments C<PL_sub_generation>, which invalidates method |
224 | caching in all packages. |
225 | |
399a1dc7 |
226 | =cut |
227 | |
228 | sub __invalidate_all_method_caches { |
229 | # Super secret mystery code :) |
230 | @fedcba98::ISA = @fedcba98::ISA; |
231 | return; |
232 | } |
233 | |
4c4e4170 |
234 | =head2 mro::method_changed_in($classname) |
235 | |
236 | Invalidates the method cache of any classes dependent on the |
399a1dc7 |
237 | given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is |
238 | an alias for C<mro::invalidate_all_method_caches> above, as |
239 | pre-5.9.5 Perls have no other way to do this. It will still |
240 | enforce the requirement that you pass it a classname, for |
241 | compatibility. |
242 | |
243 | =cut |
244 | |
245 | sub __method_changed_in { |
246 | my $classname = shift; |
247 | die "mro::method_changed_in requires a classname" if !$classname; |
248 | |
249 | __invalidate_all_method_caches(); |
250 | } |
4c4e4170 |
251 | |
e9b18837 |
252 | =head1 USING C3 |
253 | |
254 | While this module makes the 5.9.5+ syntaxes |
255 | C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available |
256 | on older Perls, it does so merely by passing off the work |
257 | to L<Class::C3>. |
258 | |
259 | It does not remove the need for you to call |
260 | L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or |
261 | C<uninitialize()> at the appropriate times |
262 | as documented in the L<Class::C3> docs. |
263 | |
264 | Because L<MRO::Compat> has L<Class::C3> as a pre-requisite, |
265 | and requires it at C<use> time, you can blindly call |
266 | those functions in code that uses L<MRO::Compat>. |
267 | Under 5.9.5+ with L<MRO::Compat>, your calls to those |
268 | functions will become a no-op and everything will work fine. |
269 | |
4c4e4170 |
270 | =head1 SEE ALSO |
271 | |
272 | L<Class::C3> |
273 | |
399a1dc7 |
274 | L<mro> |
275 | |
4c4e4170 |
276 | =head1 AUTHOR |
277 | |
278 | Brandon L. Black, E<lt>blblack@gmail.comE<gt> |
279 | |
280 | =head1 COPYRIGHT AND LICENSE |
281 | |
282 | Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt> |
283 | |
284 | This library is free software; you can redistribute it and/or modify |
285 | it under the same terms as Perl itself. |
286 | |
287 | =cut |
288 | |
289 | 1; |