[catagits/Gitalist.git] / local-lib5 / lib / perl5 / MRO / Compat.pm

package MRO::Compat;
use strict;
use warnings;
require 5.006_000;

# Keep this < 1.00, so people can tell the fake
#  mro.pm from the real one
our $VERSION = '0.11';

BEGIN {
    # Alias our private functions over to
    # the mro:: namespace and load
    # Class::C3 if Perl < 5.9.5
    if($] < 5.009_005) {
        $mro::VERSION # to fool Module::Install when generating META.yml
            = $VERSION;
        $INC{'mro.pm'} = __FILE__;
        *mro::import            = \&__import;
        *mro::get_linear_isa    = \&__get_linear_isa;
        *mro::set_mro           = \&__set_mro;
        *mro::get_mro           = \&__get_mro;
        *mro::get_isarev        = \&__get_isarev;
        *mro::is_universal      = \&__is_universal;
        *mro::method_changed_in = \&__method_changed_in;
        *mro::invalidate_all_method_caches
                                = \&__invalidate_all_method_caches;
        require Class::C3;
        if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
            *mro::get_pkg_gen   = \&__get_pkg_gen_c3xs;
        }
        else {
            *mro::get_pkg_gen   = \&__get_pkg_gen_pp;
        }
    }

    # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
    else {
        require mro;
        no warnings 'redefine';
        *Class::C3::initialize = sub { 1 };
        *Class::C3::reinitialize = sub { 1 };
        *Class::C3::uninitialize = sub { 1 };
    }
}

=head1 NAME

MRO::Compat - mro::* interface compatibility for Perls < 5.9.5

=head1 SYNOPSIS

   package FooClass; use base qw/X Y Z/;
   package X;        use base qw/ZZZ/;
   package Y;        use base qw/ZZZ/;
   package Z;        use base qw/ZZZ/;

   package main;
   use MRO::Compat;
   my $linear = mro::get_linear_isa('FooClass');
   print join(q{, }, @$linear);

   # Prints: "FooClass, X, ZZZ, Y, Z"

=head1 DESCRIPTION

The "mro" namespace provides several utilities for dealing
with method resolution order and method caching in general
in Perl 5.9.5 and higher.

This module provides those interfaces for
earlier versions of Perl (back to 5.6.0 anyways).

It is a harmless no-op to use this module on 5.9.5+.  That
is to say, code which properly uses L<MRO::Compat> will work
unmodified on both older Perls and 5.9.5+.

If you're writing a piece of software that would like to use
the parts of 5.9.5+'s mro:: interfaces that are supported
here, and you want compatibility with older Perls, this
is the module for you.

Some parts of this code will work better and/or faster with
L<Class::C3::XS> installed (which is an optional prereq
of L<Class::C3>, which is in turn a prereq of this
package), but it's not a requirement.

This module never exports any functions.  All calls must
be fully qualified with the C<mro::> prefix.

The interface documentation here serves only as a quick
reference of what the function basically does, and what
differences between L<MRO::Compat> and 5.9.5+ one should
look out for.  The main docs in 5.9.5's L<mro> are the real
interface docs, and contain a lot of other useful information.

=head1 Functions

=head2 mro::get_linear_isa($classname[, $type])

Returns an arrayref which is the linearized "ISA" of the given class.
Uses whichever MRO is currently in effect for that class by default,
or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).

The linearized ISA of a class is a single ordered list of all of the
classes that would be visited in the process of resolving a method
on the given class, starting with itself.  It does not include any
duplicate entries.

Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
part of the MRO of a class, even though all classes implicitly inherit
methods from C<UNIVERSAL> and its parents.

=cut

sub __get_linear_isa_dfs {
    no strict 'refs';

    my $classname = shift;

    my @lin = ($classname);
    my %stored;
    foreach my $parent (@{"$classname\::ISA"}) {
        my $plin = __get_linear_isa_dfs($parent);
        foreach (@$plin) {
            next if exists $stored{$_};
            push(@lin, $_);
            $stored{$_} = 1;
        }
    }
    return \@lin;
}

sub __get_linear_isa {
    my ($classname, $type) = @_;
    die "mro::get_mro requires a classname" if !defined $classname;

    $type ||= __get_mro($classname);
    if($type eq 'dfs') {
        return __get_linear_isa_dfs($classname);
    }
    elsif($type eq 'c3') {
        return [Class::C3::calculateMRO($classname)];
    }
    die "type argument must be 'dfs' or 'c3'";
}

=head2 mro::import

This allows the C<use mro 'dfs'> and
C<use mro 'c3'> syntaxes, providing you
L<use MRO::Compat> first.  Please see the
L</USING C3> section for additional details.

=cut

sub __import {
    if($_[1]) {
        goto &Class::C3::import if $_[1] eq 'c3';
        __set_mro(scalar(caller), $_[1]);
    }
}

=head2 mro::set_mro($classname, $type)

Sets the mro of C<$classname> to one of the types
C<dfs> or C<c3>.  Please see the L</USING C3>
section for additional details.

=cut

sub __set_mro {
    my ($classname, $type) = @_;

    if(!defined $classname || !$type) {
        die q{Usage: mro::set_mro($classname, $type)};
    }

    if($type eq 'c3') {
        eval "package $classname; use Class::C3";
        die $@ if $@;
    }
    elsif($type eq 'dfs') {
        # In the dfs case, check whether we need to undo C3
        if(defined $Class::C3::MRO{$classname}) {
            Class::C3::_remove_method_dispatch_table($classname);
        }
        delete $Class::C3::MRO{$classname};
    }
    else {
        die qq{Invalid mro type "$type"};
    }

    return;
}

=head2 mro::get_mro($classname)

Returns the MRO of the given class (either C<c3> or C<dfs>).

It considers any Class::C3-using class to have C3 MRO
even before L<Class::C3::initialize()> is called.

=cut

sub __get_mro {
    my $classname = shift;
    die "mro::get_mro requires a classname" if !defined $classname;
    return 'c3' if exists $Class::C3::MRO{$classname};
    return 'dfs';
}

=head2 mro::get_isarev($classname)

Returns an arrayref of classes who are subclasses of the
given classname.  In other words, classes in whose @ISA
hierarchy we appear, no matter how indirectly.

This is much slower on pre-5.9.5 Perls with MRO::Compat
than it is on 5.9.5+, as it has to search the entire
package namespace.

=cut

sub __get_all_pkgs_with_isas {
    no strict 'refs';
    no warnings 'recursion';

    my @retval;

    my $search = shift;
    my $pfx;
    my $isa;
    if(defined $search) {
        $isa = \@{"$search\::ISA"};
        $pfx = "$search\::";
    }
    else {
        $search = 'main';
        $isa = \@main::ISA;
        $pfx = '';
    }

    push(@retval, $search) if scalar(@$isa);

    foreach my $cand (keys %{"$search\::"}) {
        if($cand =~ s/::$//) {
            next if $cand eq $search; # skip self-reference (main?)
            push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
        }
    }

    return \@retval;
}

sub __get_isarev_recurse {
    no strict 'refs';

    my ($class, $all_isas, $level) = @_;

    die "Recursive inheritance detected" if $level > 100;

    my %retval;

    foreach my $cand (@$all_isas) {
        my $found_me;
        foreach (@{"$cand\::ISA"}) {
            if($_ eq $class) {
                $found_me = 1;
                last;
            }
        }
        if($found_me) {
            $retval{$cand} = 1;
            map { $retval{$_} = 1 }
                @{__get_isarev_recurse($cand, $all_isas, $level+1)};
        }
    }
    return [keys %retval];
}

sub __get_isarev {
    my $classname = shift;
    die "mro::get_isarev requires a classname" if !defined $classname;

    __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
}

=head2 mro::is_universal($classname)

Returns a boolean status indicating whether or not
the given classname is either C<UNIVERSAL> itself,
or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.

Any class for which this function returns true is
"universal" in the sense that all classes potentially
inherit methods from it.

=cut

sub __is_universal {
    my $classname = shift;
    die "mro::is_universal requires a classname" if !defined $classname;

    my $lin = __get_linear_isa('UNIVERSAL');
    foreach (@$lin) {
        return 1 if $classname eq $_;
    }

    return 0;
}

=head2 mro::invalidate_all_method_caches

Increments C<PL_sub_generation>, which invalidates method
caching in all packages.

Please note that this is rarely necessary, unless you are
dealing with a situation which is known to confuse Perl's
method caching.

=cut

sub __invalidate_all_method_caches {
    # Super secret mystery code :)
    @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
    return;
}

=head2 mro::method_changed_in($classname)

Invalidates the method cache of any classes dependent on the
given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
an alias for C<mro::invalidate_all_method_caches> above, as
pre-5.9.5 Perls have no other way to do this.  It will still
enforce the requirement that you pass it a classname, for
compatibility.

Please note that this is rarely necessary, unless you are
dealing with a situation which is known to confuse Perl's
method caching.

=cut

sub __method_changed_in {
    my $classname = shift;
    die "mro::method_changed_in requires a classname" if !defined $classname;

    __invalidate_all_method_caches();
}

=head2 mro::get_pkg_gen($classname)

Returns an integer which is incremented every time a local
method of or the C<@ISA> of the given package changes on
Perl 5.9.5+.  On earlier Perls with this L<MRO::Compat> module,
it will probably increment a lot more often than necessary.

=cut

{
    my $__pkg_gen = 2;
    sub __get_pkg_gen_pp {
        my $classname = shift;
        die "mro::get_pkg_gen requires a classname" if !defined $classname;
        return $__pkg_gen++;
    }
}

sub __get_pkg_gen_c3xs {
    my $classname = shift;
    die "mro::get_pkg_gen requires a classname" if !defined $classname;

    return Class::C3::XS::_plsubgen();
}

=head1 USING C3

While this module makes the 5.9.5+ syntaxes
C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
on older Perls, it does so merely by passing off the work
to L<Class::C3>.

It does not remove the need for you to call
C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
C<Class::C3::uninitialize()> at the appropriate times
as documented in the L<Class::C3> docs.  These three functions
are always provided by L<MRO::Compat>, either via L<Class::C3>
itself on older Perls, or directly as no-ops on 5.9.5+.

=head1 SEE ALSO

L<Class::C3>

L<mro>

=head1 AUTHOR

Brandon L. Black, E<lt>blblack@gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut

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