File Coverage

blib/lib/JIP/ClassField.pm

Criterion	Covered	Total	%
statement	63	63	100.0
branch	20	22	90.9
condition	6	9	66.6
subroutine	14	14	100.0
pod	0	2	0.0
total	103	110	93.6

package JIP::ClassField;

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

our $VERSION = '0.03';

# Will be shipping with Perl 5.22
my $NAME = eval {
    require Sub::Util;
    Sub::Util->can('set_subname');
} || sub { $ARG[1] };

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

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

    croak qq{Class not defined\n}
        unless defined $class and length $class;

    croak qq{Attribute not defined\n}
        unless defined $attr and length $attr;

    my %patch;

    if (exists $param{'get'}) {
        my ($method_name, $getter) = (q{}, $param{'get'});

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

        $patch{$method_name} = sub {
            my $self = shift;
            return $self->{$attr};
        };
    }

    if (exists $param{'set'}) {
        my ($method_name, $setter) = (q{}, $param{'set'});

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

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

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

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

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

    return monkey_patch($class, %patch);
}

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} = $NAME->($full_name, $value);
    }

    return 1;
}

sub import {
    my $caller = caller;

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

1;

__END__