File Coverage

blib/lib/Class/Accessor/Lite.pm

Criterion	Covered	Total	%
statement	81	84	96.4
branch	18	20	90.0
condition	1	3	33.3
subroutine	24	25	96.0
pod	5	6	83.3
total	129	138	93.4

package Class::Accessor::Lite;

use strict;

our $VERSION = '0.08';

sub croak {require Carp; Carp::croak(@_)}

sub import {
    shift;
    my %args = @_;
    my $pkg = caller(0);
    my %key_ctor = (
        rw => \&_mk_accessors,
        ro => \&_mk_ro_accessors,
        wo => \&_mk_wo_accessors,
    );
    for my $key (sort keys %key_ctor) {
        if (defined $args{$key}) {
            croak("value of the '$key' parameter should be an arrayref")
                unless ref($args{$key}) eq 'ARRAY';
            $key_ctor{$key}->($pkg, @{$args{$key}});
        }
    }
    _mk_new($pkg)
        if $args{new};
    1;
}

sub mk_new_and_accessors {
    (undef, my @properties) = @_;
    my $pkg = caller(0);
    _mk_new($pkg);
    _mk_accessors($pkg, @properties);
}

sub mk_new {
    my $pkg = caller(0);
    _mk_new($pkg);
}

sub mk_accessors {
    (undef, my @properties) = @_;
    my $pkg = caller(0);
    _mk_accessors($pkg, @properties);
}

sub mk_ro_accessors {
    (undef, my @properties) = @_;
    my $pkg = caller(0);
    _mk_ro_accessors($pkg, @properties);
}

sub mk_wo_accessors {
    (undef, my @properties) = @_;
    my $pkg = caller(0);
    _mk_wo_accessors($pkg, @properties);
}

sub _mk_new {
    my $pkg = shift;
    no strict 'refs';
    *{$pkg . '::new'} = __m_new($pkg);
}

sub _mk_accessors {
    my $pkg = shift;
    no strict 'refs';
    for my $n (@_) {
        *{$pkg . '::' . $n} = __m($n);
    }
}

sub _mk_ro_accessors {
    my $pkg = shift;
    no strict 'refs';
    for my $n (@_) {
        *{$pkg . '::' . $n} = __m_ro($pkg, $n);
    }
}

sub _mk_wo_accessors {
    my $pkg = shift;
    no strict 'refs';
    for my $n (@_) {
        *{$pkg . '::' . $n} = __m_wo($pkg, $n);
    }
}

sub __m_new {
    my $pkg = shift;
    no strict 'refs';
    return sub {
        my $klass = shift;
        bless {
            (@_ == 1 && ref($_[0]) eq 'HASH' ? %{$_[0]} : @_),
        }, $klass;
    };
}

sub __m {
    my $n = shift;
    sub {
        return $_[0]->{$n} if @_ == 1;
        return $_[0]->{$n} = $_[1] if @_ == 2;
        shift->{$n} = \@_;
    };
}

sub __m_ro {
    my ($pkg, $n) = @_;
    sub {
        if (@_ == 1) {
            return $_[0]->{$n} if @_ == 1;
        } else {
            my $caller = caller(0);
            croak("'$caller' cannot access the value of '$n' on objects of class '$pkg'");
        }
    };
}

sub __m_wo {
    my ($pkg, $n) = @_;
    sub {
        if (@_ == 1) {
            my $caller = caller(0);
            croak("'$caller' cannot alter the value of '$n' on objects of class '$pkg'")
        } else {
            return $_[0]->{$n} = $_[1] if @_ == 2;
            shift->{$n} = \@_;
        }
    };
}


1;

__END__