File Coverage

blib/lib/Perl6/Roles.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	18	18	100.0
condition	10	11	90.9
subroutine	13	13	100.0
pod	1	1	100.0
total	118	119	99.1

package Perl6::Roles;

use 5.6.0;

use strict;
use warnings;

our $VERSION = '0.01';

use Scalar::Util qw( blessed refaddr );
use List::MoreUtils qw( uniq );

my %does; # {class}{role} = 1
my %from; # {class}{method} = role

sub _get_all_roles {
    my $r = shift;

    my @roles = ( $r );
    push @roles, map { _get_all_roles($_) } keys %{$does{$r} ||= {}};
    return uniq( @roles );
}

sub apply {
    my ($role, $class) = @_;

    if ( my $old_class = blessed($class) ) {
        no strict 'refs';

        $class = "${old_class}::" . refaddr($class);
        push @{ "${class}::ISA" }, $old_class;

        # This requires direct access into @_ in order to affect the parameter,
        # not just the copy of the parameter.
        bless $_[1], $class;
    }

    my @methods;
    foreach my $r ( _get_all_roles( $role ) ) {
        no strict 'refs';

        # A role is valid if-and-only-if the following conditions hold:
        # 1) It is a direct descendent of __PACKAGE__
        # 2) Its only ancestor is __PACKAGE__
        my @isa = @{ "${r}::ISA" };
        if ( @isa > 1 || $isa[0] ne __PACKAGE__ ) {
            die "$r is an invalid role because it has inheritance other than "
              . __PACKAGE__ . "\n";
        }

        # No matter what, mark $class as "does $role"
        $does{ $class }{ $r } = 1;

        push @methods, map { [ $r, $_ ] } grep {
            *{"${r}::${_}"}{CODE}
        } keys %{"${r}::"};
    }

    # Only compose methods in if the $class isn't, itself, a role.
    # Roles don't flatten until they are composed into a class.
    if ( !$class->isa( __PACKAGE__ ) ) {
        METHOD:
        foreach my $item (@methods) {
            my ($r, $method) = @$item;
            no strict 'refs';

            # Don't override a method that already exists, but we need to
            # check for conflicts.
            if (*{"${class}::${method}"}{CODE}) {

                # If the method was installed by another role, die in order to
                # force the class owner to resolve the conflict.
                my $conflict = $from{ $class }{ $method };
                if ( $conflict && $conflict ne $r ) {
                    die "Attempt to re-compose '$method' into '$class'\n"
                      . "\tConflicting roles: '$conflict' <-> '$r'\n";
                }

                # Otherwise, we skip this method because the class owner has
                # already (apparently) resolved the conflict.
                next METHOD;
            }

            # Install the method ...
            *{"${class}::${method}"} = \&{"${r}::${method}"};

            # ... and record which role provides this method.
            $from{ $class }{ $method } = $r;
        }
    }

    return 1;
}

sub _check_isa {
    my ($class, $role) = @_;

    no strict 'refs';
    for my $parent ( @{ "${class}::ISA" } ) {
        return 1 if $parent->does( $role ) or _check_isa( $parent, $role );
    }

    return;
}

*UNIVERSAL::does = sub {
    my ($proto, $role) = @_;

    my $class = blessed $proto;
    $class = $proto unless $class;

    return 1 if $class eq $role;
    return 1 if $does{ $class }{ $role };

    return _check_isa( $class, $role );
};

1;
__END__