File Coverage

blib/lib/Class/C3.pm

Criterion	Covered	Total	%
statement	46	120	38.3
branch	10	56	17.8
condition	0	12	0.0
subroutine	15	22	68.1
pod	3	3	100.0
total	74	213	34.7

package Class::C3;

use strict;
use warnings;

our $VERSION = '0.35';

our $C3_IN_CORE;
our $C3_XS;

BEGIN {
    if($] > 5.009_004) {
        $C3_IN_CORE = 1;
        require mro;
    }
    elsif($C3_XS or not defined $C3_XS) {
        my $error = do {
            local $@;
            eval { require Class::C3::XS };
            $@;
        };

        if ($error) {
            die $error if $error !~ /\blocate\b/;

            if ($C3_XS) {
                require Carp;
                Carp::croak( "XS explicitly requested but Class::C3::XS is not available" );
            }

            require Algorithm::C3;
            require Class::C3::next;
        }
        else {
            $C3_XS = 1;
        }
    }
}

# this is our global stash of both
# MRO's and method dispatch tables
# the structure basically looks like
# this:
#
#   $MRO{$class} = {
#      MRO => [  ],
#      methods => {
#          orig => ,
#          code => \&
#      },
#      has_overload_fallback => (1 | 0)
#   }
#
our %MRO;

# use these for debugging ...
sub _dump_MRO_table { %MRO }
our $TURN_OFF_C3 = 0;

# state tracking for initialize()/uninitialize()
our $_initialized = 0;

sub import {
    my $class = caller();
    # skip if the caller is main::
    # since that is clearly not relevant
    return if $class eq 'main';

    return if $TURN_OFF_C3;
    mro::set_mro($class, 'c3') if $C3_IN_CORE;

    # make a note to calculate $class
    # during INIT phase
    $MRO{$class} = undef unless exists $MRO{$class};
}

## initializers

# This prevents silly warnings when Class::C3 is
#  used explicitly along with MRO::Compat under 5.9.5+

{ no warnings 'redefine';

sub initialize {
    %next::METHOD_CACHE = ();
    # why bother if we don't have anything ...
    return unless keys %MRO;
    if($C3_IN_CORE) {
        mro::set_mro($_, 'c3') for keys %MRO;
    }
    else {
        if($_initialized) {
            uninitialize();
            $MRO{$_} = undef foreach keys %MRO;
        }
        _calculate_method_dispatch_tables();
        _apply_method_dispatch_tables();
        $_initialized = 1;
    }
}

sub uninitialize {
    # why bother if we don't have anything ...
    %next::METHOD_CACHE = ();
    return unless keys %MRO;
    if($C3_IN_CORE) {
        mro::set_mro($_, 'dfs') for keys %MRO;
    }
    else {
        _remove_method_dispatch_tables();
        $_initialized = 0;
    }
}

sub reinitialize { goto &initialize }

} # end of "no warnings 'redefine'"

## functions for applying C3 to classes

sub _calculate_method_dispatch_tables {
    return if $C3_IN_CORE;
    my %merge_cache;
    foreach my $class (keys %MRO) {
        _calculate_method_dispatch_table($class, \%merge_cache);
    }
}

sub _calculate_method_dispatch_table {
    return if $C3_IN_CORE;
    my ($class, $merge_cache) = @_;
    no strict 'refs';
    my @MRO = calculateMRO($class, $merge_cache);
    $MRO{$class} = { MRO => \@MRO };
    my $has_overload_fallback;
    my %methods;
    # NOTE:
    # we do @MRO[1 .. $#MRO] here because it
    # makes no sense to interrogate the class
    # which you are calculating for.
    foreach my $local (@MRO[1 .. $#MRO]) {
        # if overload has tagged this module to
        # have use "fallback", then we want to
        # grab that value
        $has_overload_fallback = ${"${local}::()"}
            if !defined $has_overload_fallback && defined ${"${local}::()"};
        foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
            # skip if already overridden in local class
            next unless !defined *{"${class}::$method"}{CODE};
            $methods{$method} = {
                orig => "${local}::$method",
                code => \&{"${local}::$method"}
            } unless exists $methods{$method};
        }
    }
    # now stash them in our %MRO table
    $MRO{$class}->{methods} = \%methods;
    $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
}

sub _apply_method_dispatch_tables {
    return if $C3_IN_CORE;
    foreach my $class (keys %MRO) {
        _apply_method_dispatch_table($class);
    }
}

sub _apply_method_dispatch_table {
    return if $C3_IN_CORE;
    my $class = shift;
    no strict 'refs';
    ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
        if !defined &{"${class}::()"}
           && defined $MRO{$class}->{has_overload_fallback};
    foreach my $method (keys %{$MRO{$class}->{methods}}) {
        if ( $method =~ /^\(/ ) {
            my $orig = $MRO{$class}->{methods}->{$method}->{orig};
            ${"${class}::$method"} = $$orig if defined $$orig;
        }
        *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
    }
}

sub _remove_method_dispatch_tables {
    return if $C3_IN_CORE;
    foreach my $class (keys %MRO) {
        _remove_method_dispatch_table($class);
    }
}

sub _remove_method_dispatch_table {
    return if $C3_IN_CORE;
    my $class = shift;
    no strict 'refs';
    delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
    foreach my $method (keys %{$MRO{$class}->{methods}}) {
        delete ${"${class}::"}{$method}
            if defined *{"${class}::${method}"}{CODE} &&
               (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
    }
}

sub calculateMRO {
    my ($class, $merge_cache) = @_;

    return Algorithm::C3::merge($class, sub {
        no strict 'refs';
        @{$_[0] . '::ISA'};
    }, $merge_cache);
}

# Method overrides to support 5.9.5+ or Class::C3::XS

sub _core_calculateMRO { @{mro::get_linear_isa($_[0], 'c3')} }

if($C3_IN_CORE) {
    no warnings 'redefine';
    *Class::C3::calculateMRO = \&_core_calculateMRO;
}
elsif($C3_XS) {
    no warnings 'redefine';
    *Class::C3::calculateMRO = \&Class::C3::XS::calculateMRO;
    *Class::C3::_calculate_method_dispatch_table
        = \&Class::C3::XS::_calculate_method_dispatch_table;
}

1;

__END__