File Coverage

blib/lib/JIP/ClassField.pm

Criterion	Covered	Total	%
statement	73	73	100.0
branch	20	22	90.9
condition	8	9	88.8
subroutine	16	16	100.0
pod	0	3	0.0
total	117	123	95.1

package JIP::ClassField;

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

our $VERSION = '0.04';

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

# Will be shipping with 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 and length $class;

    croak q{Attribute not defined}
        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} = $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) });
}

1;

__END__