File Coverage

blib/lib/decorators.pm

Criterion	Covered	Total	%
statement	72	73	98.6
branch	29	40	72.5
condition	4	9	44.4
subroutine	14	14	100.0
pod	0	1	0.0
total	119	137	86.8

package decorators;
# ABSTRACT: Apply decorators to your methods

use strict;
use warnings;

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

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

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

sub import {
    my $class = shift;
    $class->import_into( scalar caller, @_ );
}

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

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

    Carp::confess('You must provide a valid package argument')
        unless $package;

    Carp::confess('The package argument cannot be a reference or blessed object')
        if ref $package;

    # convert this into a metaobject
    my $meta = MOP::Role->new( $package );

    Carp::confess('Cannot install decorator collectors, MODIFY_CODE_ATTRIBUTES method already exists')
        if $meta->has_method('MODIFY_CODE_ATTRIBUTES') || $meta->has_method_alias('MODIFY_CODE_ATTRIBUTES');

    Carp::confess('Cannot install decorator collectors, FETCH_CODE_ATTRIBUTES method already exists')
        if $meta->has_method('FETCH_CODE_ATTRIBUTES') || $meta->has_method_alias('FETCH_CODE_ATTRIBUTES');

    # now install the collectors ...

    my %accepted; # shared data between the collectors ...

    $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 $role       = MOP::Role->new( $pkg );    # the actual Package that Perl is talking about ...
            my $method     = MOP::Method->new( $code ); # the actual CV that Perl is talking about ...
            my @attributes = map MOP::Method::Attribute->new( $_ ), @attrs; # inflate the attributes ...

            my $decorators = _create_decorator_meta_object_for( $role->name );
            # preparing the attrbutes returns the ones that are unhandled ...
            # my @unhandled = map $_->original, $decorators->filter_unhandled( @attributes );
            my @unhandled  = map $_->original, grep !_has_decorator( $decorators, $_->name ), @attributes;

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

            # process the attributes ...
            foreach my $attribute ( @attributes ) {
                my $d = _get_decorator( $decorators, $attribute->name );

                $d or die 'This should never happen, as we have already checked this above ^^';

                # we know that this will be a no-op,
                # so, we no-op and go to the next one
                next if $d->has_code_attributes('TagMethod');

                if ( $d->has_code_attributes('CreateMethod') ) {
                    $method->is_required
                        or die 'The method ('.$method->name.') must be bodyless for a `CreateMethod` decorator ('.$d->name.') '
                              .'to be applied to it, please check the order of your decorators, `CreateMethod` decorators '
                              .'should usually be applied early in the list when possible.';
                }

                $d->body->( $role, $method, @{ $attribute->args || [] } );

                if ( $d->has_code_attributes('WrapMethod') || $d->has_code_attributes('CreateMethod') ) {
                    my $name = $method->name;
                    $method = $role->get_method( $name );
                    Carp::croak('Failed to find new overwriten method ('.$name.') in class ('.$role->name.')')
                        unless defined $method;
                }
            }

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

            return;
        }
    );

    if ( @providers ) {
        # so we can use lowercase attributes ...
        warnings->unimport('reserved')
            if grep /^:/, @providers;

        # expand any tags, they should match
        # the provider names available in the
        # decorators::providers::* namespace
        @providers = map /^\:/ ? 'decorators::providers:'.$_ : $_, @providers;

        # load the providers, and then ...
        Module::Runtime::use_package_optimistically( $_ ) foreach @providers;

        _set_decorator_providers(
            _create_decorator_meta_object_for( $package ),
            @providers
        );
    }

    return;
}

## methods to deal with the internals

sub _create_decorator_meta_object_for {
    my ($namespace) = @_;
    return MOP::Role->new( $namespace.'::__DECORATORS__' );
}

sub _set_decorator_providers {
    my ($decorators, @providers) = @_;
    $decorators->set_roles( @providers );
    MOP::Util::compose_roles( $decorators );
}

# methods to deal with locating decorators

sub _has_decorator {
    my ($decorators, $name) = @_;

    return unless $decorators->has_method( $name );

    my $method = $decorators->get_method( $name );
    return 1 if $method->origin_stash eq 'decorators::providers::for_providers';
    return 1 if $method->has_code_attributes('Decorator');
    return;
}

sub _get_decorator {
    my ($decorators, $name) = @_;
    return unless _has_decorator( $decorators, $name );
    return $decorators->get_method( $name );
}

1;

__END__