File Coverage

blib/lib/mro/EVERY.pm

Criterion	Covered	Total	%
statement	37	37	100.0
branch	6	10	60.0
condition			n/a
subroutine	13	13	100.0
pod			n/a
total	56	60	93.3

########################################################################
# housekeeping
########################################################################

package mro::EVERY v0.1.4;
use v5.24;
use mro;

use Carp            qw( croak           );
use List::Util      qw( uniq            );
use Scalar::Util    qw( blessed         );
use Symbol          qw( qualify_to_ref  );

########################################################################
# package varaibles
########################################################################

our @CARP_NOT   = ( __PACKAGE__, qw( mro ) );
my $find_subs   = '';
my $with_auto   = '';

########################################################################
# utility subs
########################################################################

my $find_name
= sub
{
    my $proto   = shift;
    my $auto    = shift;
    my ($name)  = $auto =~ m{ (\w+) $}x;
    my $class   = blessed $proto || $proto;

    $proto->can( $name )
    or croak "Botched EVERY: '$proto' cannot '$name'";

    # if they handle this via AUTOLOAD then we have
    # problem at this point, see find_with_autoload.
    #
    # if the dispatching class has no ancestors then
    # treat it as its own ancestor.

    local $"    = ',';
    my @isa     = $class->mro::get_linear_isa->@*;

    # uniq avoids case of multiple-dispatch of
    # hardwired inherited methods at multiple
    # places in the tree.

    my @found
    = uniq
    grep
    {
        $_
    }
    map
    {
        *{ qualify_to_ref $name => $_ }{ CODE }
    }
    @isa
    or
    croak "Bogus $proto: '$name' not in @isa";

    @found
};

my $find_with_autoload
= sub
{
    my $proto   = shift;
    my $auto    = shift;
    my ($name)  = $auto =~ m{ (\w+) $}x;

    $proto->can( $name )
    or croak "Botched EVERY: '$proto' cannot '$name'";

    local $"    = ',';
    my @isa     = $proto->mro::get_linear_isa->@*;

    # uniq avoids multiple-dispatch in case where
    # AUTOLOAD handling $name is inherited.

    my @found
    = uniq
    grep
    {
        $_
    }
    map
    {
        *{ qualify_to_ref $name => $_ }{ CODE }
        or
        do
        {
            my $isa = qualify_to_ref ISA        => $_;
            my $ref = qualify_to_ref AUTOLOAD   => $_;

            local *$isa = [];

            # at this point can is isolated to the
            # single pacakge.

            my $al
            = $_->can( $name )
            ? *{ $ref }{ CODE }
            : ''
            ;

            $al
            ?   sub
                {
                    # at this point if package can $name and
                    # has an AUTOLOAD but not the named sub.
                    #
                    # install $AUTOLOAD and bon voyage!

                    local *{ $ref } = $auto;
                    goto &$al;
                }
            : ()
            ;
        }
    }
    @isa
    or
    croak "Bogus $proto: '$name' & AUTOLOAD not in @isa";

    @found
};

sub import
{
    shift;  # discard this package

    for( @_ )
    {
        m{^   autoload $}x and $with_auto = 1;
        m{^ noautoload $}x and $with_auto = '';
    }

    $find_subs
    = $with_auto
    ? $find_with_autoload
    : $find_name
    ;

    return
}

########################################################################
# pseudo-packages
########################################################################

package EVERY;
use v5.22;
use Carp    qw( croak );

our @CARP_NOT   = ( __PACKAGE__, qw( mro ) );
our $AUTOLOAD   = '';

AUTOLOAD
{
    my $proto   = shift
    or croak "Bogus EVERY, called without an object.";

    # remaining arguments left on the stack.

    $proto->$_( @_ )
    for $proto->$find_subs( $AUTOLOAD );
}

package EVERY::LAST;
use v5.22;
use Carp    qw( croak );

our @CARP_NOT   = ( __PACKAGE__, qw( mro ) );
our $AUTOLOAD   = '';

AUTOLOAD
{
    my $proto   = shift
    or croak "Bogus EVERY::LAST, called without an object.";

    # remaining arguments left on the stack.

    $proto->$_( @_ )
    for reverse $proto->$find_subs( $AUTOLOAD );
}

# keep require happy
1
__END__