File Coverage

blib/lib/decorators/providers/accessors.pm

Criterion	Covered	Total	%
statement	55	99	55.5
branch	14	50	28.0
condition	3	27	11.1
subroutine	20	26	76.9
pod	5	5	100.0
total	97	207	46.8

package decorators::providers::accessors;
# ABSTRACT: A set of decorators to generate accessor methods

use strict;
use warnings;

use decorators ':for_providers';

use Carp      ();
use MOP::Util ();

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

sub ro : Decorator : CreateMethod {
    my ( $meta, $method, @args ) = @_;

    my $method_name = $method->name;

    my $slot_name;
    if ( $args[0] ) {
        if ( $args[0] eq '_' ) {
            $slot_name = '_'.(($method_name =~ /^get_(.*)$/)[0] || $method_name);
        }
        else {
            $slot_name = shift @args;
        }
    }
    else {
        if ( $method_name =~ /^get_(.*)$/ ) {
            $slot_name = $1;
        }
        else {
            $slot_name = $method_name;
        }
    }

    Carp::confess('Unable to build `ro` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.')
        unless $meta->has_slot( $slot_name )
            || $meta->has_slot_alias( $slot_name );

    $meta->add_method( $method_name => sub {
        Carp::confess("Cannot assign to `$slot_name`, it is a readonly") if scalar @_ != 1;
        $_[0]->{ $slot_name };
    });
}

sub rw : Decorator : CreateMethod {
    my ( $meta, $method, @args ) = @_;

    my $method_name = $method->name;

    my $slot_name;
    if ( $args[0] ) {
        if ( $args[0] eq '_' ) {
            $slot_name = '_'.$method_name;
        }
        else {
            $slot_name = shift @args;
        }
    }
    else {
        $slot_name = $method_name;
    }

    Carp::confess('Unable to build `rw` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.')
        if ($meta->name)->isa('UNIVERSAL::Object::Immutable');

    Carp::confess('Unable to build `rw` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.')
        unless $meta->has_slot( $slot_name )
            || $meta->has_slot_alias( $slot_name );

    $meta->add_method( $method_name => sub {
        $_[0]->{ $slot_name } = $_[1] if scalar( @_ ) > 1;
        $_[0]->{ $slot_name };
    });
}

sub wo : Decorator : CreateMethod {
    my ( $meta, $method, @args ) = @_;

    my $method_name = $method->name;

    my $slot_name;
    if ( $args[0] ) {
        if ( $args[0] eq '_' ) {
            $slot_name = '_'.(($method_name =~ /^set_(.*)$/)[0] || $method_name);
        }
        else {
            $slot_name = shift @args;
        }
    }
    else {
        if ( $method_name =~ /^set_(.*)$/ ) {
            $slot_name = $1;
        }
        else {
            $slot_name = $method_name;
        }
    }

    Carp::confess('Unable to build `wo` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.')
        if ($meta->name)->isa('UNIVERSAL::Object::Immutable');

    Carp::confess('Unable to build `wo` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.')
        unless $meta->has_slot( $slot_name )
            || $meta->has_slot_alias( $slot_name );

    $meta->add_method( $method_name => sub {
        Carp::confess("You must supply a value to write to `$slot_name`") if scalar(@_) < 1;
        $_[0]->{ $slot_name } = $_[1];
    });
}

sub predicate : Decorator : CreateMethod {
    my ( $meta, $method, @args ) = @_;

    my $method_name = $method->name;

    my $slot_name;
    if ( $args[0] ) {
        if ( $args[0] eq '_' ) {
            $slot_name = '_'.(($method_name =~ /^has_(.*)$/)[0] || $method_name);
        }
        else {
            $slot_name = shift @args;
        }
    }
    else {
        if ( $method_name =~ /^has_(.*)$/ ) {
            $slot_name = $1;
        }
        else {
            $slot_name = $method_name;
        }
    }

    Carp::confess('Unable to build predicate for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.')
        unless $meta->has_slot( $slot_name )
            || $meta->has_slot_alias( $slot_name );

    $meta->add_method( $method_name => sub { defined $_[0]->{ $slot_name } } );
}

sub clearer : Decorator : CreateMethod {
    my ( $meta, $method, @args ) = @_;

    my $method_name = $method->name;

    my $slot_name;
    if ( $args[0] ) {
        if ( $args[0] eq '_' ) {
            $slot_name = '_'.(($method_name =~ /^clear_(.*)$/)[0] || $method_name);
        }
        else {
            $slot_name = shift @args;
        }
    }
    else {
        if ( $method_name =~ /^clear_(.*)$/ ) {
            $slot_name = $1;
        }
        else {
            $slot_name = $method_name;
        }
    }

    Carp::confess('Unable to build `clearer` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.')
        if ($meta->name)->isa('UNIVERSAL::Object::Immutable');

    Carp::confess('Unable to build `clearer` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.')
        unless $meta->has_slot( $slot_name )
            || $meta->has_slot_alias( $slot_name );

    $meta->add_method( $method_name => sub { undef $_[0]->{ $slot_name } } );
}


1;

__END__