File Coverage

blib/lib/MRO/Compat.pm
Criterion Covered Total %
statement 27 129 20.9
branch 1 54 1.8
condition 0 9 0.0
subroutine 9 24 37.5
pod n/a
total 37 216 17.1


line stmt bran cond sub pod time code
1             package MRO::Compat;
2 3     3   214122 use strict;
  3         26  
  3         93  
3 3     3   15 use warnings;
  3         6  
  3         753  
4             require 5.006_000;
5              
6             # Keep this < 1.00, so people can tell the fake
7             # mro.pm from the real one
8             our $VERSION = '0.14_01';
9              
10             BEGIN {
11             # Alias our private functions over to
12             # the mro:: namespace and load
13             # Class::C3 if Perl < 5.9.5
14 3 50   3   28 if($] < 5.009_005) {
15 0         0 $mro::VERSION # to fool Module::Install when generating META.yml
16             = $VERSION;
17 0         0 $INC{'mro.pm'} = __FILE__;
18 0         0 *mro::import = \&__import;
19 0         0 *mro::get_linear_isa = \&__get_linear_isa;
20 0         0 *mro::set_mro = \&__set_mro;
21 0         0 *mro::get_mro = \&__get_mro;
22 0         0 *mro::get_isarev = \&__get_isarev;
23 0         0 *mro::is_universal = \&__is_universal;
24 0         0 *mro::method_changed_in = \&__method_changed_in;
25 0         0 *mro::invalidate_all_method_caches
26             = \&__invalidate_all_method_caches;
27 0         0 require Class::C3;
28 0 0 0     0 if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
29 0         0 *mro::get_pkg_gen = \&__get_pkg_gen_c3xs;
30             }
31             else {
32 0         0 *mro::get_pkg_gen = \&__get_pkg_gen_pp;
33             }
34             }
35              
36             # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
37             else {
38 3         38 require mro;
39 3     3   23 no warnings 'redefine';
  3         7  
  3         298  
40 3     1   19 *Class::C3::initialize = sub { 1 };
  1         3178  
41 3     0   11 *Class::C3::reinitialize = sub { 1 };
  0         0  
42 3     0   260 *Class::C3::uninitialize = sub { 1 };
  0         0  
43             }
44             }
45              
46             =head1 NAME
47              
48             MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
49              
50             =head1 SYNOPSIS
51              
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              
57             package FooClass; use base qw/X Y Z/;
58              
59             package main;
60             use MRO::Compat;
61             my $linear = mro::get_linear_isa('FooClass');
62             print join(q{, }, @$linear);
63              
64             # Prints: FooClass, X, PPP, Exporter, Y, Z
65              
66             =head1 DESCRIPTION
67              
68             The "mro" namespace provides several utilities for dealing
69             with method resolution order and method caching in general
70             in Perl 5.9.5 and higher.
71              
72             This module provides those interfaces for
73             earlier versions of Perl (back to 5.6.0 anyways).
74              
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 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
80             the parts of 5.9.5+'s mro:: interfaces that are supported
81             here, and you want compatibility with older Perls, this
82             is the module for you.
83              
84             Some parts of this code will work better and/or faster with
85             L installed (which is an optional prereq
86             of L, which is in turn a prereq of this
87             package), but it's not a requirement.
88              
89             This module never exports any functions. All calls must
90             be fully qualified with the C prefix.
91              
92             The interface documentation here serves only as a quick
93             reference of what the function basically does, and what
94             differences between L and 5.9.5+ one should
95             look out for. The main docs in 5.9.5's L are the real
96             interface docs, and contain a lot of other useful information.
97              
98             =head1 Functions
99              
100             =head2 mro::get_linear_isa($classname[, $type])
101              
102             Returns an arrayref which is the linearized "ISA" of the given class.
103             Uses whichever MRO is currently in effect for that class by default,
104             or the given MRO (either C or C if specified as C<$type>).
105              
106             The linearized ISA of a class is a single ordered list of all of the
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              
111             Note that C (and any members of C's MRO) are not
112             part of the MRO of a class, even though all classes implicitly inherit
113             methods from C and its parents.
114              
115             =cut
116              
117             sub __get_linear_isa_dfs {
118 0     0     my @check = shift;
119 0           my @lin;
120              
121             my %found;
122 0           while (defined(my $check = shift @check)) {
123 0           push @lin, $check;
124 3     3   20 no strict 'refs';
  3         7  
  3         1376  
125 0           unshift @check, grep !$found{$_}++, @{"$check\::ISA"};
  0            
126             }
127              
128 0           return \@lin;
129             }
130              
131             sub __get_linear_isa {
132 0     0     my ($classname, $type) = @_;
133 0 0         die "mro::get_mro requires a classname" if !defined $classname;
134              
135 0   0       $type ||= __get_mro($classname);
136 0 0         if($type eq 'dfs') {
    0          
137 0           return __get_linear_isa_dfs($classname);
138             }
139             elsif($type eq 'c3') {
140 0           return [Class::C3::calculateMRO($classname)];
141             }
142 0           die "type argument must be 'dfs' or 'c3'";
143             }
144              
145             =head2 mro::import
146              
147             This allows the C and
148             C syntaxes, providing you
149             C first. Please see the
150             L section for additional details.
151              
152             =cut
153              
154             sub __import {
155 0 0   0     if($_[1]) {
156 0 0         goto &Class::C3::import if $_[1] eq 'c3';
157 0           __set_mro(scalar(caller), $_[1]);
158             }
159             }
160              
161             =head2 mro::set_mro($classname, $type)
162              
163             Sets the mro of C<$classname> to one of the types
164             C or C. Please see the L
165             section for additional details.
166              
167             =cut
168              
169             sub __set_mro {
170 0     0     my ($classname, $type) = @_;
171              
172 0 0 0       if(!defined $classname || !$type) {
173 0           die q{Usage: mro::set_mro($classname, $type)};
174             }
175              
176 0 0         if($type eq 'c3') {
    0          
177 0           eval "package $classname; use Class::C3";
178 0 0         die $@ if $@;
179             }
180             elsif($type eq 'dfs') {
181             # In the dfs case, check whether we need to undo C3
182 0 0         if(defined $Class::C3::MRO{$classname}) {
183 0           Class::C3::_remove_method_dispatch_table($classname);
184             }
185 0           delete $Class::C3::MRO{$classname};
186             }
187             else {
188 0           die qq{Invalid mro type "$type"};
189             }
190              
191 0           return;
192             }
193              
194             =head2 mro::get_mro($classname)
195              
196             Returns the MRO of the given class (either C or C).
197              
198             It considers any Class::C3-using class to have C3 MRO
199             even before L is called.
200              
201             =cut
202              
203             sub __get_mro {
204 0     0     my $classname = shift;
205 0 0         die "mro::get_mro requires a classname" if !defined $classname;
206 0 0         return 'c3' if exists $Class::C3::MRO{$classname};
207 0           return 'dfs';
208             }
209              
210             =head2 mro::get_isarev($classname)
211              
212             Returns an arrayref of classes who are subclasses of the
213             given classname. In other words, classes in whose @ISA
214             hierarchy we appear, no matter how indirectly.
215              
216             This is much slower on pre-5.9.5 Perls with MRO::Compat
217             than it is on 5.9.5+, as it has to search the entire
218             package namespace.
219              
220             =cut
221              
222             sub __get_all_pkgs_with_isas {
223 3     3   25 no strict 'refs';
  3         5  
  3         98  
224 3     3   15 no warnings 'recursion';
  3         5  
  3         849  
225              
226 0     0     my @retval;
227              
228 0           my $search = shift;
229 0           my $pfx;
230             my $isa;
231 0 0         if(defined $search) {
232 0           $isa = \@{"$search\::ISA"};
  0            
233 0           $pfx = "$search\::";
234             }
235             else {
236 0           $search = 'main';
237 0           $isa = \@main::ISA;
238 0           $pfx = '';
239             }
240              
241 0 0         push(@retval, $search) if scalar(@$isa);
242              
243 0           foreach my $cand (keys %{"$search\::"}) {
  0            
244 0 0         if($cand =~ s/::$//) {
245 0 0         next if $cand eq $search; # skip self-reference (main?)
246 0           push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
  0            
247             }
248             }
249              
250 0           return \@retval;
251             }
252              
253             sub __get_isarev_recurse {
254 3     3   23 no strict 'refs';
  3         7  
  3         1521  
255              
256 0     0     my ($class, $all_isas, $level) = @_;
257              
258 0 0         die "Recursive inheritance detected" if $level > 100;
259              
260 0           my %retval;
261              
262 0           foreach my $cand (@$all_isas) {
263 0           my $found_me;
264 0           foreach (@{"$cand\::ISA"}) {
  0            
265 0 0         if($_ eq $class) {
266 0           $found_me = 1;
267 0           last;
268             }
269             }
270 0 0         if($found_me) {
271 0           $retval{$cand} = 1;
272 0           map { $retval{$_} = 1 }
273 0           @{__get_isarev_recurse($cand, $all_isas, $level+1)};
  0            
274             }
275             }
276 0           return [keys %retval];
277             }
278              
279             sub __get_isarev {
280 0     0     my $classname = shift;
281 0 0         die "mro::get_isarev requires a classname" if !defined $classname;
282              
283 0           __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
284             }
285              
286             =head2 mro::is_universal($classname)
287              
288             Returns a boolean status indicating whether or not
289             the given classname is either C itself,
290             or one of C's parents by C<@ISA> inheritance.
291              
292             Any class for which this function returns true is
293             "universal" in the sense that all classes potentially
294             inherit methods from it.
295              
296             =cut
297              
298             sub __is_universal {
299 0     0     my $classname = shift;
300 0 0         die "mro::is_universal requires a classname" if !defined $classname;
301              
302 0           my $lin = __get_linear_isa('UNIVERSAL');
303 0           foreach (@$lin) {
304 0 0         return 1 if $classname eq $_;
305             }
306              
307 0           return 0;
308             }
309              
310             =head2 mro::invalidate_all_method_caches
311              
312             Increments C, which invalidates method
313             caching in all packages.
314              
315             Please note that this is rarely necessary, unless you are
316             dealing with a situation which is known to confuse Perl's
317             method caching.
318              
319             =cut
320              
321             sub __invalidate_all_method_caches {
322             # Super secret mystery code :)
323 0     0     @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
324 0           return;
325             }
326              
327             =head2 mro::method_changed_in($classname)
328              
329             Invalidates the method cache of any classes dependent on the
330             given class. In L on pre-5.9.5 Perls, this is
331             an alias for C above, as
332             pre-5.9.5 Perls have no other way to do this. It will still
333             enforce the requirement that you pass it a classname, for
334             compatibility.
335              
336             Please note that this is rarely necessary, unless you are
337             dealing with a situation which is known to confuse Perl's
338             method caching.
339              
340             =cut
341              
342             sub __method_changed_in {
343 0     0     my $classname = shift;
344 0 0         die "mro::method_changed_in requires a classname" if !defined $classname;
345              
346 0           __invalidate_all_method_caches();
347             }
348              
349             =head2 mro::get_pkg_gen($classname)
350              
351             Returns an integer which is incremented every time a local
352             method of or the C<@ISA> of the given package changes on
353             Perl 5.9.5+. On earlier Perls with this L module,
354             it will probably increment a lot more often than necessary.
355              
356             =cut
357              
358             {
359             my $__pkg_gen = 2;
360             sub __get_pkg_gen_pp {
361 0     0     my $classname = shift;
362 0 0         die "mro::get_pkg_gen requires a classname" if !defined $classname;
363 0           return $__pkg_gen++;
364             }
365             }
366              
367             sub __get_pkg_gen_c3xs {
368 0     0     my $classname = shift;
369 0 0         die "mro::get_pkg_gen requires a classname" if !defined $classname;
370              
371 0           return Class::C3::XS::_plsubgen();
372             }
373              
374             =head1 USING C3
375              
376             While this module makes the 5.9.5+ syntaxes
377             C and C available
378             on older Perls, it does so merely by passing off the work
379             to L.
380              
381             It does not remove the need for you to call
382             C, C, and/or
383             C at the appropriate times
384             as documented in the L docs. These three functions
385             are always provided by L, either via L
386             itself on older Perls, or directly as no-ops on 5.9.5+.
387              
388             =head1 SEE ALSO
389              
390             L
391              
392             L
393              
394             =head1 AUTHOR
395              
396             Brandon L. Black, Eblblack@gmail.comE
397              
398             =head1 COPYRIGHT AND LICENSE
399              
400             Copyright 2007-2008 Brandon L. Black Eblblack@gmail.comE
401              
402             This library is free software; you can redistribute it and/or modify
403             it under the same terms as Perl itself.
404              
405             =cut
406              
407             1;