File Coverage

blib/lib/mro/EVERY.pm

Criterion	Covered	Total	%
statement	37	41	90.2
branch	5	12	41.6
condition			n/a
subroutine	12	12	100.0
pod			n/a
total	54	65	83.0

########################################################################
# housekeeping
########################################################################
use v5.24;

package mro::EVERY v1.0.3;
use mro;

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

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

our @CARP_NOT   = ( __PACKAGE__, qw( mro ) );
my %class2dfs   = ();

########################################################################
# 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'";

    # class at entry point gets to decide the mro type.

    my $mro     = $class2dfs{ $class } || $class->mro::get_mro;
    my @isa     = $class->mro::get_linear_isa( $mro )->@*;

    # @found preserves array context of map.
    #
    # this should never croak afer the can
    # check unless they have an overloaded
    # can and forgot qw( autoload );

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

    @found
};

my $find_auto
= 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->@*;

    # @found preserves array context of map.

    my @found
    = 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
};

my $finder  = $find_name;

sub import
{
    shift;
    my $caller  = caller;

    for( @_ )
    {
        my ( $status, $arg ) = m{ (no)? (dfs|autoload) }x;

        if( $arg eq 'dfs' )
        {
            # delay the lookup of mro::get_mro until runtim
            # to allow classes to fiddle with it at runtime.

            if( $status  )
            {
                delete $class2dfs{ $caller }
            }
            else
            {
                $class2dfs{ $caller } = 'dfs'
            }
        }
        elsif( $arg eq 'autoload' )
        {
            $finder
            = $status
            ? $find_name
            : $find_auto
        }
        else
        {
            croak "Botched EVERY: unknown argument '$_'";
        }
    }

    return
}

########################################################################
# downstream packages
########################################################################

package EVERY;
use Carp            qw( croak   );
use List::Util      qw( uniq    );

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 uniq $proto->$finder( $AUTOLOAD );
}

package EVERY::LAST;
use Carp            qw( croak   );
use List::Util      qw( uniq    );

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 uniq reverse $proto->$finder( $AUTOLOAD );
}

# keep require happy
1
__END__