File Coverage

blib/lib/Role/Basic.pm

Criterion	Covered	Total	%
statement	259	268	96.6
branch	83	96	86.4
condition	35	44	79.5
subroutine	34	34	100.0
pod	0	4	0.0
total	411	446	92.1

package Role::Basic;

sub _getglob { \*{ $_[0] } }

use strict;
use warnings FATAL => 'all';

use B qw/svref_2object/;
use Storable ();
use Carp ();
use Data::Dumper ();

our $VERSION = '0.16';

# eventually clean these up
my ( %IS_ROLE, %REQUIRED_BY, %HAS_ROLES, %ALLOWED_BY, %PROVIDES );

sub import {
    my $class  = shift;
    my $target = caller;

    # everybody gets 'with' and 'DOES'
    *{ _getglob "${target}::with" } = sub {
        $class->apply_roles_to_package( $target, @_ );
    };
    # everybody gets 'with' and 'DOES'
    *{ _getglob "${target}::DOES" } = sub {
        my ( $proto, $role ) = @_;
        my $class_or_role = ref $proto || $proto;
        return 1 if $class_or_role eq $role;
        return exists $HAS_ROLES{$class_or_role}{$role} ? 1 : 0;
    };
    if ( 1 == @_ && 'with' eq $_[0] ) {

        # this is a class which is consuming roles
        return;
    }
    elsif ( 2 == @_ && 'allow' eq $_[0] ) {

        # this is a role which allows methods from a foreign class
        my $foreign_class = $_[1];
        push @{ $ALLOWED_BY{$foreign_class} } => $target;
        $class->_declare_role($target);
    }
    elsif (@_) {
        my $args = join ', ' => @_;    # more explicit than $"
        Carp::confess(
            "Multiple or unknown argument(s) in import list: ($args)");
    }
    else {
        $class->_declare_role($target);
    }
}

sub _declare_role {
    my ($class, $target) = @_;
    $IS_ROLE{$target} = 1;
    *{ _getglob "${target}::requires" } = sub {
        $class->add_to_requirements( $target, @_ );
    };
}

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

    $REQUIRED_BY{$role} ||= [];
    push @{ $REQUIRED_BY{$role} } => @methods;
    my %seen;
    @{ $REQUIRED_BY{$role} } =
      grep { not $seen{$_}++ } @{ $REQUIRED_BY{$role} };
}

sub get_required_by {
    my ( $class, $role ) = @_;
    return unless my $requirements = $REQUIRED_BY{$role};
    return @$requirements;
}

sub requires_method {
    my ( $class, $role, $method ) = @_;
    return unless $IS_ROLE{$role};
    my %requires = map { $_ => 1 } $class->get_required_by($role);
    return $requires{$method};
}

sub _roles {
    my ( $class, $target ) = @_;
    return unless $HAS_ROLES{$target};
    my @roles;
    my %seen;
    foreach my $role ( keys %{ $HAS_ROLES{$target} } ) {
        my $modifiers = $HAS_ROLES{$target}{$role};
        my $role_name = $class->_get_role_name($role,$modifiers);
        unless ( $seen{$role_name} ) {
            push @roles => $role_name, $class->_roles($role);
        }
    }
    return @roles;
}

sub apply_roles_to_package {
    my ( $class, $target, @roles ) = @_;

    if ( $HAS_ROLES{$target} ) {
        Carp::confess("with() may not be called more than once for $target");
    }

    my ( %provided_by, %requires );

    my %is_applied;

    # these are roles which a class does not use directly, but are contained in
    # the roles the class consumes.
    my %contained_roles;

    while ( my $role = shift @roles ) {

        # will need to verify that they're actually a role!

        my $role_modifiers = shift @roles if ref $roles[0];
        $role_modifiers ||= {};
        my $role_name = $class->_get_role_name( $role, $role_modifiers );
        $is_applied{$role_name} = 1;
        $class->_load_role( $role, $role_modifiers->{'-version'} );

        # XXX this is awful. Don't tell anyone I wrote this
        my $role_methods = $class->_add_role_methods_to_target(
            $role,
            $target,
            $role_modifiers
        );

        # DOES() in some cases
        if ( my $roles = $HAS_ROLES{$role} ) {
            foreach my $role ( keys %$roles ) {
                $HAS_ROLES{$target}{$role} = $roles->{$role};
            }
        }

        foreach my $method ( $class->get_required_by($role) ) {
            push @{ $requires{$method} } => $role;
        }

        # roles consuming roles should have the same requirements.
        if ( $IS_ROLE{$target} ) {
            $class->add_to_requirements( $target,
                $class->get_required_by($role) );
        }

        while ( my ( $method, $data ) = each %$role_methods ) {
            $PROVIDES{$role_name}{$method} ||= $data;
        }

        # any extra roles contained in applied roles must be added
        # (helps with conflict resolution)
        $contained_roles{$role_name} = 1;
        foreach my $contained_role ( $class->_roles($role) ) {
            next if $is_applied{$contained_role};
            $contained_roles{$contained_role} = 1;
            $is_applied{$contained_role}      = 1;
        }
    }
    foreach my $contained_role (keys %contained_roles) {
        my ( $role, $modifiers ) = split /-/ => $contained_role, 2;
        foreach my $method ( $class->get_required_by($role) ) {
            push @{ $requires{$method} } => $role;
        }
        # a role is not a name. A role is a role plus its alias/exclusion. We
        # now store those in $HAS_ROLE so pull from them
        if ( my $methods = $PROVIDES{$contained_role} ) {
            foreach my $method (keys %$methods) {
                push @{ $provided_by{$method} } => $methods->{$method};
            }
        }
    }

    $class->_check_conflicts( $target, \%provided_by );
    $class->_check_requirements( $target, \%requires );
}

sub _uniq (@) {
    my %seen = ();
    grep { not $seen{$_}++ } @_;
}

sub _check_conflicts {
    my ( $class, $target, $provided_by ) = @_;
    my @errors;
    foreach my $method (keys %$provided_by) {
        my $sources = $provided_by->{$method};
        next if 1 == @$sources;

        my %seen;
        # what we're doing here is checking to see if code references point to
        # the same reference. If they do, they can't possibly be in conflict
        # because they're the same method. This seems strange, but it does
        # follow the original spec.
        my @sources = do {
            no warnings 'uninitialized';
            map    { $_->{source} }
              grep { !$seen{ $_->{code} }++ } @$sources;
        };

        # more than one role provides the method and it's not overridden by
        # the consuming class having that method
        if ( @sources > 1 && $target ne _sub_package( $target->can($method) ) )
        {
            my $sources = join "' and '" => sort @sources;
            push @errors =>
"Due to a method name conflict in roles '$sources', the method '$method' must be implemented or excluded by '$target'";
        }
    }
    if ( my $errors = join "\n" => @errors ) {
        Carp::confess($errors);
    }
}

sub _check_requirements {
    my ( $class, $target, $requires ) = @_;

    # we return if the target is a role because requirements can be deferred
    # until final composition
    return if $IS_ROLE{$target};
    my @errors;
    foreach my $method ( keys %$requires ) {
        unless ( $target->can($method) ) {
            my $roles = join '|' => _uniq sort @{ $requires->{$method} };
            push @errors =>
"'$roles' requires the method '$method' to be implemented by '$target'";
        }
    }
    if (@errors) {
        Carp::confess( join "\n" => @errors );
    }
}

sub _get_role_name {
    my ( $class, $role, $modifiers ) = @_;
    local $Data::Dumper::Indent   = 0;
    local $Data::Dumper::Terse    = 1;
    local $Data::Dumper::Sortkeys = 1;
    return "$role-" . Data::Dumper::Dumper($modifiers);
}

sub _add_role_methods_to_target {
    my ( $class, $role, $target, $role_modifiers) = @_;

    my $copied_modifiers = Storable::dclone($role_modifiers);
    my $role_name = $class->_get_role_name( $role, $copied_modifiers );

    my $target_methods    = $class->_get_methods($target);
    my $is_loaded         = $PROVIDES{$role_name};
    my $code_for          = $is_loaded || $class->_get_methods($role);
    my %original_code_for = %$code_for;

    delete $role_modifiers->{'-version'};
    my ( $is_excluded, $aliases ) =
      $class->_get_excludes_and_aliases( $target, $role, $role_modifiers );

    my $stash = do { no strict 'refs'; \%{"${target}::"} };
    while ( my ( $old_method, $new_method ) = each %$aliases ) {
        if ( !$is_loaded ) {
            if ( exists $code_for->{$new_method} && !$is_excluded->{$new_method} ) {
                Carp::confess(
    "Cannot alias '$old_method' to existing method '$new_method' in $role"
                );
            }
            else {
                $code_for->{$new_method} = $original_code_for{$old_method};
            }
        }

        # We do this because $target->can($new_method) wouldn't be appropriate
        # since it's OK for a role method to -alias over an inherited one. You
        # can -alias directly on top of an existing method, though.
        if ( exists $stash->{$new_method} ) {
            Carp::confess("Cannot alias '$old_method' to '$new_method' as a method of that name already exists in $target");
        }
    }

    my %was_aliased = reverse %$aliases;
    foreach my $method ( keys %$code_for ) {
        if ( $is_excluded->{$method} ) {
            unless ($was_aliased{$method}) {
                delete $code_for->{$method};
                $class->add_to_requirements( $target, $method );
                next;
            }
        }

        if ( exists $target_methods->{$method} ) {
            if ( $ENV{PERL_ROLE_OVERRIDE_DIE} ) {
                Carp::confess(
                    "Role '$role' not overriding method '$method' in '$target'"
                );
            }
            if ( $ENV{PERL_ROLE_OVERRIDE_WARN} ) {
                Carp::carp(
                    "Role '$role' not overriding method '$method' in '$target'"
                );
            }
            next;
        }
        # XXX we're going to handle this ourselves
        no strict 'refs';
        no warnings 'redefine';
        *{"${target}::$method"} = $code_for->{$method}{code};
    }
    $HAS_ROLES{$target}{$role} = $copied_modifiers;
    return $code_for;
}

sub _get_excludes_and_aliases {
    my ( $class, $target, $role, $role_modifiers ) = @_;
    # figure out which methods to exclude
    my $excludes = delete $role_modifiers->{'-excludes'} || [];
    my $aliases  = delete $role_modifiers->{'-alias'}    || {};
    my $renames  = delete $role_modifiers->{'-rename'}   || {};

    $excludes = [$excludes] unless ref $excludes;
    my %is_excluded = map { $_ => 1 } @$excludes;

    while ( my ( $old_method, $new_method ) = each %$renames ) {
        $is_excluded{$old_method} = 1;
        $aliases->{$old_method} = $new_method;
    }

    unless ( 'ARRAY' eq ref $excludes ) {
        Carp::confess(
"Argument to '-excludes' in package $target must be a scalar or array reference"
        );
    }

    # rename methods to alias
    unless ( 'HASH' eq ref $aliases ) {
        Carp::confess(
            "Argument to '-alias' in package $target must be a hash reference"
        );
    }

    if ( my $unknown = join ', ' => keys %$role_modifiers ) {
        Carp::confess("Unknown arguments in 'with()' statement for $role");
    }
    return ( \%is_excluded, $aliases );
}

# We can cache this at some point, but for now, the return value is munged
sub _get_methods {
    my ( $class, $target ) = @_;

    my $stash = do { no strict 'refs'; \%{"${target}::"} };

    my %methods;
    foreach my $name ( keys %$stash ) {
        my $item = $stash->{$name};

        next unless my $code = _get_valid_method( $target, $item );

        # this prevents a "modification of read-only value" error.
        my $source = _sub_package($code);
        $methods{$name} = {
            code   => $code,
            source => $source,
        };
    }
    return \%methods;
}

sub _get_valid_method {
    my ( $target, $item ) = @_;
    my $code = ref $item eq 'CODE' ? $item
             : ref \$item eq 'GLOB' ? *$item{CODE}
             : undef;
    return if !defined $code;

    my $source = _sub_package($code) or return;

    # XXX There's a potential bug where some idiot could use Role::Basic to
    # create exportable functions and those get exported into a role. That's
    # far-fetched enough that I'm not worried about it.
    my $is_valid =
      # declared in package, not imported
      $target eq $source
      ||
      # unless we're a role and they're composed from another role
      $IS_ROLE{$target} && $IS_ROLE{$source};

    unless ($is_valid) {
        foreach my $role (@{ $ALLOWED_BY{$source} }) {
            return $code if $target->DOES($role);
        }
    }
    return $is_valid ? $code : ();
}

sub _sub_package {
    my ($code) = @_;
    my $source_package;
    eval {
        my $stash = svref_2object($code)->STASH;
        if ( $stash && $stash->can('NAME') ) {
            $source_package = $stash->NAME;
        }
        else {
            $source_package = '';
        }
    };
    if ( my $error = $@ ) {
        warn "Could not determine calling source_package: $error";
    }
    return $source_package || '';
}

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

    $version ||= '';
    my $stash = do { no strict 'refs'; \%{"${role}::"} };
    if ( exists $stash->{requires} ) {
        my $package = $role;
        $package =~ s{::}{/}g;
        $package .= ".pm";
        if ( not exists $INC{$package} ) {

            # embedded role, not a separate package
            $INC{"$package"} = "added to inc by $class";
        }
    }
    eval "use $role $version";
    Carp::confess($@) if $@;

    return 1 if $IS_ROLE{$role};

    my $requires = $role->can('requires');
    if ( !$requires || $class ne _sub_package($requires) ) {
        Carp::confess(
            "Only roles defined with $class may be loaded with _load_role.  '$role' is not allowed.");
    }
    $IS_ROLE{$role} = 1;
    return 1;
}

1;

__END__