[gitmo/MRO-Compat.git] / lib / MRO / Compat.pm

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

our $VERSION = '0.01';

BEGIN {
    # Alias our private functions over to
    # the mro:: namespace and load
    # Class::C3 if Perl < 5.9.5
    if($] < 5.009_005) {
        require Class::C3;
        *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;
    }

    # Provide no-op Class::C3::.*initialize() funcs for 5.9.5+
    else {
        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+.  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.

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

=head1 Functions

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

Returns an arrayref which is the linearized MRO 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 MRO 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 !$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(!$classname || !$type) {
        die q{Usage: mro::set_mro($classname, $type)};
    }
    if($type eq 'c3') {
        eval "package $classname; use Class::C3";
        die $@ if $@;
    }
    if($type ne 'dfs') {
        die q{Invalid mro type "$type"};
    }

    # 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};

    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 !$classname;
    return 'c3' if exists $Class::C3::MRO{$classname};
    return 'dfs';
}

=head2 mro::get_isarev($classname)

Returns an array of classes who are subclasses of the
given classname.  In other words, classes who we exists,
however indirectly, in the @ISA inheritancy hierarchy of.

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($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 =~ /::$/) {
            $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 !$classname;

    sort @{__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 !$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.

=cut

sub __invalidate_all_method_caches {
    # Super secret mystery code :)
    @fedcba98::ISA = @fedcba98::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.

=cut

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

    __invalidate_all_method_caches();
}

=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
L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
C<uninitialize()> at the appropriate times
as documented in the L<Class::C3> docs.

Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
and requires it at C<use> time, you can blindly call
those functions in code that uses L<MRO::Compat>.
Under 5.9.5+ with L<MRO::Compat>, your calls to those
functions will become a no-op and everything will work fine.

=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 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
399a1dc7	1	package MRO::Compat;
4c4e4170	2	use strict;
4c4e4170	3	use warnings;
e9b18837	4	require 5.006_000;
4c4e4170	5
4c4e4170	6	our $VERSION = '0.01';
4c4e4170	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	}
4c4e4170	33
4c4e4170	34	=head1 NAME
4c4e4170	35
42915ba4	36	MRO::Compat - 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
399a1dc7	56	in Perl 5.9.5 and higher.
4c4e4170	57
42915ba4	58	This module provides those interfaces for
e9b18837	59	earlier versions of Perl (back to 5.6.0 anyways).
e9b18837	60
42915ba4	61	It is a harmless no-op to use this module on 5.9.5+. If
	62	you're writing a piece of software that would like to use
	63	the parts of 5.9.5+'s mro:: interfaces that are supported
e9b18837	64	here, and you want compatibility with older Perls, this
e9b18837	65	is the module for you.
4c4e4170	66
399a1dc7	67	This module never exports any functions. All calls must
399a1dc7	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
399a1dc7	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	}
399a1dc7	136
4c4e4170	137	=head2 mro::set_mro($classname, $type)
4c4e4170	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)
4c4e4170	185
42915ba4	186	Returns an array of classes who are subclasses of the
	187	given classname. In other words, classes who we exists,
	188	however indirectly, in the @ISA inheritancy hierarchy of.
	189
	190	This is much slower on pre-5.9.5 Perls with MRO::Compat
	191	than it is on 5.9.5+, as it has to search the entire
	192	package namespace.
399a1dc7	193
	194	=cut
	195
42915ba4	196	sub __get_all_pkgs_with_isas {
	197	no strict 'refs';
	198	no warnings 'recursion';
	199
	200	my @retval;
	201
	202	my $search = shift;
	203	my $pfx;
	204	my $isa;
	205	if($search) {
	206	$isa = \@{"$search\::ISA"};
	207	$pfx = "$search\::";
	208	}
	209	else {
	210	$search = 'main';
	211	$isa = \@main::ISA;
	212	$pfx = '';
	213	}
	214
	215	push(@retval, $search) if scalar(@$isa);
	216
	217	foreach my $cand (keys %{"$search\::"}) {
	218	if($cand =~ /::$/) {
	219	$cand =~ s/::$//;
	220	next if $cand eq $search; # skip self-reference (main?)
	221	push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
	222	}
	223	}
	224
	225	return \@retval;
	226	}
	227
	228	sub __get_isarev_recurse {
	229	no strict 'refs';
	230
	231	my ($class, $all_isas, $level) = @_;
	232
	233	die "Recursive inheritance detected" if $level > 100;
	234
	235	my %retval;
	236
	237	foreach my $cand (@$all_isas) {
	238	my $found_me;
	239	foreach (@{"$cand\::ISA"}) {
	240	if($_ eq $class) {
	241	$found_me = 1;
	242	last;
	243	}
	244	}
	245	if($found_me) {
	246	$retval{$cand} = 1;
	247	map { $retval{$_} = 1 }
	248	@{__get_isarev_recurse($cand, $all_isas, $level+1)};
	249	}
	250	}
	251	return [keys %retval];
	252	}
	253
399a1dc7	254	sub __get_isarev {
42915ba4	255	my $classname = shift;
	256	die "mro::get_isarev requires a classname" if !$classname;
	257
	258	sort @{__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0)};
399a1dc7	259	}
4c4e4170	260
	261	=head2 mro::is_universal($classname)
	262
	263	Returns a boolean status indicating whether or not
	264	the given classname is either C<UNIVERSAL> itself,
	265	or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
	266
	267	Any class for which this function returns true is
	268	"universal" in the sense that all classes potentially
	269	inherit methods from it.
	270
399a1dc7	271	=cut
	272
	273	sub __is_universal {
	274	my $classname = shift;
	275	die "mro::is_universal requires a classname" if !$classname;
	276
ac5a5a7f	277	my $lin = __get_linear_isa('UNIVERSAL');
399a1dc7	278	foreach (@$lin) {
	279	return 1 if $classname eq $_;
	280	}
	281
	282	return 0;
	283	}
	284
	285	=head2 mro::invalidate_all_method_caches
4c4e4170	286
	287	Increments C<PL_sub_generation>, which invalidates method
	288	caching in all packages.
	289
399a1dc7	290	=cut
	291
	292	sub __invalidate_all_method_caches {
	293	# Super secret mystery code :)
	294	@fedcba98::ISA = @fedcba98::ISA;
	295	return;
	296	}
	297
4c4e4170	298	=head2 mro::method_changed_in($classname)
	299
	300	Invalidates the method cache of any classes dependent on the
399a1dc7	301	given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
	302	an alias for C<mro::invalidate_all_method_caches> above, as
	303	pre-5.9.5 Perls have no other way to do this. It will still
	304	enforce the requirement that you pass it a classname, for
	305	compatibility.
	306
	307	=cut
	308
	309	sub __method_changed_in {
	310	my $classname = shift;
	311	die "mro::method_changed_in requires a classname" if !$classname;
	312
	313	__invalidate_all_method_caches();
	314	}
4c4e4170	315
e9b18837	316	=head1 USING C3
	317
	318	While this module makes the 5.9.5+ syntaxes
	319	C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
	320	on older Perls, it does so merely by passing off the work
	321	to L<Class::C3>.
	322
	323	It does not remove the need for you to call
	324	L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
	325	C<uninitialize()> at the appropriate times
	326	as documented in the L<Class::C3> docs.
	327
	328	Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
	329	and requires it at C<use> time, you can blindly call
	330	those functions in code that uses L<MRO::Compat>.
	331	Under 5.9.5+ with L<MRO::Compat>, your calls to those
	332	functions will become a no-op and everything will work fine.
	333
4c4e4170	334	=head1 SEE ALSO
	335
	336	L<Class::C3>
	337
399a1dc7	338	L<mro>
399a1dc7	339
4c4e4170	340	=head1 AUTHOR
	341
	342	Brandon L. Black, E<lt>blblack@gmail.comE<gt>
	343
	344	=head1 COPYRIGHT AND LICENSE
	345
	346	Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
	347
	348	This library is free software; you can redistribute it and/or modify
	349	it under the same terms as Perl itself.
	350
	351	=cut
	352
	353	1;