File Coverage

blib/lib/JIP/Object.pm

Criterion	Covered	Total	%
statement	125	125	100.0
branch	50	50	100.0
condition	8	8	100.0
subroutine	30	31	96.7
pod	6	10	60.0
total	219	224	97.7

package JIP::Object;

use 5.006;
use strict;
use warnings;
use Carp qw(croak);
use Scalar::Util qw(blessed);
use English qw(-no_match_vars);

our $VERSION = '0.031';
our $AUTOLOAD;

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 new {
    my ($class, %param) = @ARG;

    croak q{Class already blessed} if blessed $class;

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

        croak q{Bad argument "proto"}
            unless (blessed $proto || q{}) eq __PACKAGE__;
    }

    return bless({}, $class)
        ->_set_stash({})
        ->_set_meta({})
        ->set_proto($proto);
}

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

    croak q{Can't call "has" as a class method} unless blessed $self;

    croak q{Attribute not defined} unless defined $attr and 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;

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

        # setter
        {
            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->_stash->{$attr} = shift;
                    }
                    elsif (ref $default_value eq 'CODE') {
                        $self->_stash->{$attr} = $maybe_set_subname->(
                            'default_value',
                            $default_value,
                        )->($self);
                    }
                    else {
                        $self->_stash->{$attr} = $default_value;
                    }

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

        push @patches, \%patch;
    }

    for my $each_patch (@patches) {
        while (my ($method_name, $code) = each %{ $each_patch }) {
            $self->_meta->{$method_name} = $maybe_set_subname->($method_name, $code);
        }
    }

    return $self;
}

sub method {
    my ($self, $method_name, $code) = @ARG;

    croak q{Can't call "method" as a class method}
        unless blessed $self;

    croak q{First argument must be a non empty string}
        unless defined $method_name and length $method_name;

    croak sprintf(q{First argument "%s" invalid}, $method_name)
        unless $method_name =~ m{^[a-zA-Z_]\w*$}x;

    croak q{Second argument must be a code ref}
        unless ref($code) eq 'CODE';

    $self->_meta->{$method_name} = $maybe_set_subname->($method_name, $code);

    return $self;
}

sub own_method {
    my ($self, $method_name) = @ARG;

    return unless exists $self->_meta->{$method_name};

    return $self->_meta->{$method_name};
}

# http://perldoc.perl.org/perlobj.html#Default-UNIVERSAL-methods
sub isa {
    no warnings 'misc';
    goto &UNIVERSAL::isa;
}

sub DOES {
    # DOES is equivalent to isa by default
    goto &isa;
}

sub VERSION {
    no warnings 'misc';
    goto &UNIVERSAL::VERSION;
}

sub can {
    my ($self, $method_name) = @ARG;

    if (blessed $self) {
        no warnings 'misc';
        goto &UNIVERSAL::can;
    }
    else {
        my $code;
        no warnings 'misc';
        $code = UNIVERSAL::can($self, $method_name);

        return $code;
    }
}

sub DESTROY {}

sub AUTOLOAD {
    my ($self) = @ARG;

    croak q{Can't call "AUTOLOAD" as a class method} unless blessed $self;

    my ($package, $method_name) = ($AUTOLOAD =~ m{^(.+)::([^:]+)$}x);
    undef $AUTOLOAD;

    if (defined(my $code = $self->own_method($method_name))) {
        goto &$code;
    }
    elsif (defined(my $proto = $self->proto)) {
        shift @ARG;
        $proto->$method_name(@ARG);
    }
    else {
        croak(sprintf q{Can't locate object method "%s" in this instance}, $method_name);
    }
}

sub proto {
    return $ARG[0]->{'proto'};
}

sub set_proto {
    $ARG[0]->{'proto'} = $ARG[1];
    return $ARG[0];
}

# private methods
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;
}

sub _meta {
    return $ARG[0]->{'meta'};
}
sub _set_meta {
    $ARG[0]->{'meta'} = $ARG[1];
    return $ARG[0];
}

sub _stash {
    return $ARG[0]->{'stash'};
}
sub _set_stash {
    $ARG[0]->{'stash'} = $ARG[1];
    return $ARG[0];
}

1;

__END__