File Coverage

blib/lib/Method/Traits.pm

Criterion	Covered	Total	%
statement	62	63	98.4
branch	14	18	77.7
condition	9	10	90.0
subroutine	11	11	100.0
pod	0	1	0.0
total	96	103	93.2

package Method::Traits;
# ABSTRACT: Apply traits to your methods

use strict;
use warnings;

our $VERSION   = '0.06';
our $AUTHORITY = 'cpan:STEVAN';

use Carp            ();
use Scalar::Util    ();
use MOP             (); # this is how we do most of our work
use Module::Runtime (); # trait provider loading

## ...

use Method::Traits::Meta::Provider;

## --------------------------------------------------------
## Importers
## --------------------------------------------------------

sub import {
    my $class = shift;

    return unless @_;

    my @args = @_;
    if ( scalar(@args) == 1 && $args[0] eq ':for_providers' ) {
        # expand this to make it easier for providers
        $args[0] = 'Method::Traits::Meta::Provider';
    }

    $class->import_into( scalar caller, @args );
}

## --------------------------------------------------------
## Trait collection
## --------------------------------------------------------

our %PROVIDERS_BY_PKG;

sub import_into {
    my (undef, $package, @providers) = @_;

    # add in the providers, so we can
    # get to them when needed ...
    Module::Runtime::use_package_optimistically( $_ ) foreach @providers;
    push @{ $PROVIDERS_BY_PKG{ $package } ||=[] } => @providers;

    my $meta = Scalar::Util::blessed( $package ) ? $package : MOP::Class->new( $package );

    # no need to install the collectors
    # if they have already been installed
    # as they are not different
    return
        if $meta->has_method_alias('FETCH_CODE_ATTRIBUTES')
        && $meta->has_method_alias('MODIFY_CODE_ATTRIBUTES');

    # now install the collectors ...

    my %accepted; # shared state between these two methods ...

    $meta->alias_method(
        FETCH_CODE_ATTRIBUTES => sub {
            my (undef, $code) = @_;
            # return just the strings, as expected by attributes ...
            return $accepted{ $code } ? @{ $accepted{ $code } } : ();
        }
    );
    $meta->alias_method(
        MODIFY_CODE_ATTRIBUTES => sub {
            my ($pkg, $code, @attrs) = @_;

            my @providers  = @{ $PROVIDERS_BY_PKG{ $pkg } }; # fetch complete set
            my @attributes = map MOP::Method::Attribute->new( $_ ), @attrs;

            my ( %attr_to_handler_map, @unhandled );
            foreach my $attribute ( @attributes ) {
                my $name = $attribute->name;
                my $h; $h = $_->can( $name ) and last foreach @providers;
                if ( $h ) {
                    $attr_to_handler_map{ $name } = $h;
                }
                else {
                    push @unhandled => $attribute->original;
                }
            }

            # return the bad traits as strings, as expected by attributes ...
            return @unhandled if @unhandled;

            my $klass  = MOP::Class->new( $pkg );
            my $method = MOP::Method->new( $code );

            foreach my $attribute ( @attributes ) {
                my ($name, $args) = ($attribute->name, $attribute->args);
                my $h = $attr_to_handler_map{ $name };

                $h->( $klass, $method, @$args );

                if ( MOP::Method->new( $h )->has_code_attributes('OverwritesMethod') ) {
                    $method = $klass->get_method( $method->name );
                    Carp::croak('Failed to find new overwriten method ('.$method->name.') in class ('.$meta->name.')')
                        unless defined $method;
                }
            }

            # store the traits we applied ...
            $accepted{ $method->body } = [ map $_->original, @attributes ];

            return;
        }
    );
}

1;

__END__