File Coverage

blib/lib/Object/Simple/Accessor.pm

Criterion	Covered	Total	%
statement	119	123	96.7
branch	77	86	89.5
condition	27	34	79.4
subroutine	23	24	95.8
pod	0	6	0.0
total	246	273	90.1

# Deprecated class
package Object::Simple::Accessor;

use strict;
use warnings;

use Carp 'croak';

sub create_accessors {
    my ($type, $class, $attrs, @options) = @_;

    # To array
    $attrs = [$attrs] unless ref $attrs eq 'ARRAY';

    # Arrange options
    my $options = @options > 1 ? {@options} : {default => $options[0]};

    # Check options
    foreach my $oname (keys %$options) {
        croak "'$oname' is invalid option"
         if  !($oname eq 'default' || $oname eq 'inherit')
           || ($type eq 'attr' && $oname ne 'default');
    }

    # Create accessors
    foreach my $attr (@$attrs) {

        # Create accessor
        my $code = $type eq 'attr'
                 ? create_accessor($class, $attr, $options)

                 : $type eq 'class_attr'
                 ? create_class_accessor($class, $attr, $options)

                 : $type eq 'dual_attr'
                 ? create_dual_accessor($class, $attr, $options)

                 : undef;

        # Import
        no strict 'refs';
        *{"${class}::$attr"} = $code;
    }
}

sub create_attr_accessor {
    my $class = shift;


}

sub create_accessor {
    my ($class, $attr, $options, $type) = @_;

    # Options
    my $default = $options->{default};
    my $inherit = $options->{inherit} || '';

    if ($inherit) {

        # Rearrange Inherit option
        $options->{inherit} = $inherit eq 'scalar_copy' ? sub { $_[0]      }
                            : $inherit eq 'array_copy'  ? sub { [@{$_[0]}] }
                            : $inherit eq 'hash_copy'   ? sub { return {%{$_[0]}} }
                            : undef
          unless ref $inherit eq 'CODE';

        # Check inherit options
        croak "'inherit' opiton must be 'scalar_copy', 'array_copy', " .
              "'hash_copy', or code reference (${class}::$attr)"
          unless $options->{inherit};
    }

    # Check default option
    croak "'default' option must be scalar or code ref (${class}::$attr)"
      unless !ref $default || ref $default eq 'CODE';

    my $code;
    # Class Accessor
    if (($type || '') eq 'class') {

        # With inherit option
        if ($inherit) {





            return sub {

                my $self = shift;

                croak "${class}::$attr must be called from class."
                  if ref $self;

                my $class_attrs = do {
                    no strict 'refs';
                    ${"${self}::CLASS_ATTRS"} ||= {};
                };

                inherit_attribute($self, $attr, $options)
                  if @_ == 0 && ! exists $class_attrs->{$attr};

                if(@_ > 0) {

                    croak qq{One argument must be passed to "${class}::$attr()"}
                      if @_ > 1;

                    $class_attrs->{$attr} = $_[0];

                    return $self;
                }

                return $class_attrs->{$attr};
            };





        }

        # With default option
        elsif (defined $default) {





            return sub {

                my $self = shift;

                croak "${class}::$attr must be called from class."
                  if ref $self;

                my $class_attrs = do {
                    no strict 'refs';
                    ${"${self}::CLASS_ATTRS"} ||= {};
                };

                $class_attrs->{$attr} = ref $default ? $default->($self) : $default
                  if @_ == 0 && ! exists $class_attrs->{$attr};

                if(@_ > 0) {

                    croak qq{One argument must be passed to "${class}::$attr()"}
                      if @_ > 1;

                    $class_attrs->{$attr} = $_[0];

                    return $self;
                }

                return $class_attrs->{$attr};

            };





        }

        # Without option
        else {





            return sub {

                my $self = shift;

                croak "${class}::$attr must be called from class."
                  if ref $self;

                my $class_attrs = do {
                    no strict 'refs';
                    ${"${self}::CLASS_ATTRS"} ||= {};
                };

                if(@_ > 0) {

                    croak qq{One argument must be passed to "${class}::$attr()"}
                      if @_ > 1;

                    $class_attrs->{$attr} = $_[0];

                    return $self;
                }

                return $class_attrs->{$attr};
            };





        }
    }

    # Normal accessor
    else {

        # With inherit option
        if ($inherit) {





            return sub {

                my $self = shift;

                inherit_attribute($self, $attr, $options)
                  if @_ == 0 && ! exists $self->{$attr};

                if(@_ > 0) {

                    croak qq{One argument must be passed to "${class}::$attr()"}
                      if @_ > 1;

                    $self->{$attr} = $_[0];

                    return $self;
                }

                return $self->{$attr};
            };






        }

        # With default option
        elsif (defined $default) {





            return sub {

                my $self = shift;

                $self->{$attr} = ref $default ? $default->($self) : $default
                  if @_ == 0 && ! exists $self->{$attr};

                if(@_ > 0) {

                    croak qq{One argument must be passed to "${class}::$attr()"}                      if @_ > 1;

                    $self->{$attr} = $_[0];

                    return $self;
                }

                return $self->{$attr};
            };





        }

        # Without option
        else {





            return sub {

                my $self = shift;

                if(@_ > 0) {

                    croak qq{One argument must be passed to "${class}::$attr()"}                      if @_ > 1;

                    $self->{$attr} = $_[0];

                    return $self;
                }

                return $self->{$attr};
            };





        }
    }
}

sub create_class_accessor  { create_accessor(@_, 'class') }

sub create_dual_accessor {

    # Create dual accessor
    my $accessor       = create_accessor(@_);
    my $class_accessor = create_class_accessor(@_);

    return sub { ref $_[0] ? $accessor->(@_) : $class_accessor->(@_) };
}

sub inherit_attribute {
    my ($proto, $attr, $options) = @_;

    # Options
    my $inherit = $options->{inherit};
    my $default = $options->{default};

    # Called from a object
    if (my $class = ref $proto) {
        $proto->{$attr} = $inherit->($class->$attr);
    }

    # Called from a class
    else {
        my $base =  do {
            no strict 'refs';
            ${"${proto}::ISA"}[0];
        };
        $proto->$attr(eval { $base->can($attr) }
                    ? $inherit->($base->$attr)
                    : ref $default ? $default->($proto) : $default);
    }
}

1;

=head1 NAME

Object::Simple::Accessor - DEPRECATED!

=cut