File Coverage

blib/lib/JIP/ClassField.pm

Criterion	Covered	Total	%
statement	88	88	100.0
branch	26	26	100.0
condition	8	9	88.8
subroutine	44	44	100.0
pod	0	3	0.0
total	166	170	97.6

package JIP::ClassField;

use 5.006;
use strict;
use warnings;
use Carp qw(croak);
use English qw(-no_match_vars);

our $VERSION = '0.051';

my $maybe_set_subname = sub { $ARG[1]; };

# Supported on Perl 5.22+
eval {
    require Sub::Util;

    if (my $set_subname = Sub::Util->can('set_subname')) {
        $maybe_set_subname = $set_subname;
    }
};

sub attr {
    my ($self, $attr, %param) = @ARG;

    my $class = ref $self || $self;

    croak q{Class not defined}
        unless defined $class && length $class;

    croak q{Attribute not defined}
        unless defined $attr && length $attr;

    my @patches;

    for my $each_attr (@{ ref $attr eq 'ARRAY' ? $attr : [$attr] }) {
        croak sprintf(q{Attribute "%s" invalid}, $each_attr)
            unless $each_attr =~ m{^[a-zA-Z_]\w*$}x;

        my %patch;

        $patch{_define_name_of_getter($each_attr, \%param)} = sub {
            my $self = shift;
            return $self->{$each_attr};
        };

        {
            my $method_name = _define_name_of_setter($each_attr, \%param);

            if (exists $param{'default'}) {
                my $default_value = $param{'default'};

                $patch{$method_name} = sub {
                    my $self = shift;

                    if (@ARG == 1) {
                        $self->{$each_attr} = shift;
                    }
                    else {
                        $self->{$each_attr} = ref($default_value) eq 'CODE' ?
                            $default_value->($self) : $default_value;
                    }

                    return $self;
                };
            }
            else {
                $patch{$method_name} = sub {
                    my ($self, $value) = @ARG;
                    $self->{$each_attr} = $value;
                    return $self;
                };
            }
        }

        push @patches, \%patch;
    }

    monkey_patch($class, %{ $_ }) for @patches;
}

sub monkey_patch {
    my ($class, %patch) = @ARG;

    no strict 'refs';
    no warnings 'redefine';

    while (my ($method_name, $value) = each %patch) {
        my $full_name = $class .q{::}. $method_name;

        *{$full_name} = $maybe_set_subname->($full_name, $value);
    }

    return 1;
}

sub cleanup_namespace {
    my @names  = @ARG;
    my $caller = caller;

    no strict 'refs';
    my $ref = \%{ $caller .'::' };

    map { delete $ref->{$_} } @names;

    return 1;
}

sub import {
    my $caller = caller;

    return monkey_patch($caller, 'has', sub { attr($caller, @ARG) });
}

sub _define_name_of_getter {
    my ($attr, $param) = @ARG;

    my $method_name;

    if (exists $param->{'get'}) {
        my $getter = $param->{'get'};

        if ($getter eq q{+}) {
            $method_name = $attr;
        }
        elsif ($getter eq q{-}) {
            $method_name = q{_}. $attr;
        }
        else {
            $method_name = $getter;
        }
    }
    else {
        $method_name = $attr;
    }

    return $method_name;
}

sub _define_name_of_setter {
    my ($attr, $param) = @ARG;

    my $method_name;

    if (exists $param->{'set'}) {
        my $setter = $param->{'set'};

        if ($setter eq q{+}) {
            $method_name = q{set_}. $attr;
        }
        elsif ($setter eq q{-}) {
            $method_name = q{_set_}. $attr;
        }
        else {
            $method_name = $setter;
        }
    }
    else {
        $method_name = q{set_}. $attr;
    }

    return $method_name;
}

1;

__END__