File Coverage

blib/lib/Class/Accessor/FactoryTyped.pm

Criterion	Covered	Total	%
statement	102	149	68.4
branch	27	82	32.9
condition	12	66	18.1
subroutine	25	46	54.3
pod	2	2	100.0
total	168	345	48.7

use 5.008;
use strict;
use warnings;

package Class::Accessor::FactoryTyped;
BEGIN {
  $Class::Accessor::FactoryTyped::VERSION = '1.100970';
}

# ABSTRACT: Accessors whose values come from a factory
use Carp 'croak';
use Data::Miscellany 'set_push';
use UNIVERSAL::require;
use parent qw(
  Class::Accessor::Complex
  Class::Accessor::Installer
);
__PACKAGE__->mk_class_array_accessors(
    qw(factory_typed_accessors factory_typed_array_accessors));

sub mk_factory_typed_accessors {
    my ($self, $factory_class_name, @args) = @_;
    my $class = ref $self || $self;
    $factory_class_name->require or die $@;
    while (@args) {
        my $type = shift @args;
        my $list = shift @args or die "No slot names for $class";

        # Allow a list of hashrefs.
        my @list = (ref($list) eq 'ARRAY') ? @$list : ($list);
        for my $obj_def (@list) {
            my ($name, @composites);
            if (!ref $obj_def) {
                $name = $obj_def;
            } else {
                $name = $obj_def->{slot};
                my $composites = $obj_def->{comp_mthds};
                @composites =
                    ref($composites) eq 'ARRAY' ? @$composites
                  : defined $composites ? ($composites)
                  :                       ();
            }
            for my $meth (@composites) {
                $self->install_accessor(
                    name => $meth,
                    code => sub {
                        local $DB::sub = local *__ANON__ = "${class}::{$meth}"
                          if defined &DB::DB && !$Devel::DProf::VERSION;
                        my ($self, @args) = @_;
                        $self->$name()->$meth(@args);
                    },
                );
                $self->document_accessor(
                    name => $meth,
                    purpose => <
Calls $meth() with the given arguments on the object stored in the $name slot.
If there is no such object, a new $type object is constructed - no arguments
are passed to the constructor - and stored in the $name slot before forwarding
$meth() onto it.
EODOC
                    examples => [ "\$obj->$meth(\@args);", "\$obj->$meth;", ],
                );
            }
            my $expected_class;

            # use a class list to the target package to keep track of which
            # framework_objects the class has, for introspection purposes
            $self->factory_typed_accessors_push($name);
            $self->install_accessor(
                name => $name,
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${name}"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self, @args) = @_;
                    unless ($expected_class) {
                        $expected_class =
                          $factory_class_name->get_registered_class($type);
                        die "no factory class name for type [$type]"
                          unless $expected_class;

                      # need to load the class to do UNIVERSAL::isa stuff on the
                      # class name
                        $expected_class->require or die $@;
                    }

                    # if (ref $args[0] eq $expected_class) {
                    if (defined($args[0])
                        && UNIVERSAL::isa($args[0], $expected_class)) {
                        return $self->{$name} = $args[0];
                    } elsif (@args || !defined $self->{$name}) {

                      # We accept a hashref of args as well and have to deref it
                      # first, since we're going to push args onto the @args
                      # array.
                        @args =
                          (scalar(@args == 1) && ref($args[0]) eq 'HASH')
                          ? %{ $args[0] }
                          : @args;

                      # Create an object if args are given, or autovivify one if
                      # no args are given and it doesn't exist yet.
                        return $self->{$name} =
                          $factory_class_name->make_object_for_type($type,
                            @args);
                    }

                # Still here? Hm, shouldn't happen, but return the value anyway.
                    $self->{$name};
                }
            );
            $self->install_accessor(
                name => [ "clear_${name}", "${name}_clear" ],
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${name}_clear"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    $_[0]->{$name} = undef;
                }
            );
            $self->install_accessor(
                name => [ "exists_${name}", "${name}_exists" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${name}_exists"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    exists $_[0]->{$name};
                }
            );
        }
    }
    $self;    # for chaining
}

sub mk_factory_typed_array_accessors {
    my ($self, $factory_class_name, @args) = @_;
    my $class = ref $self || $self;
    $factory_class_name->require or die $@;
    while (@args) {
        my $object_type_const = shift @args;
        my $list = shift @args or die "No slot names for $class";

        # Allow a list of hashrefs.
        my @list = (ref($list) eq 'ARRAY') ? @$list : ($list);
        for my $field (@list) {
            my $normalize = "${field}_normalize";
            $self->install_accessor(
                name => $normalize,
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${normalize}"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my $self = shift;
                    map {
                        ref $_
                          ? $_
                          : $factory_class_name->make_object_for_type(
                            $object_type_const, $_,);
                      }
                      map {
                        ref $_ eq 'ARRAY' ? @$_ : ($_)
                      } @_;
                }
            );

            # use a class list to the target package to keep track of which
            # framework_list_objects the class has, for introspection purposes
            $self->factory_typed_array_accessors_push($field);
            $self->install_accessor(
                name => $field,
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${field}"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my $self = shift;
                    defined $self->{$field} or $self->{$field} = [];
                    @{ $self->{$field} } = $self->$normalize(@_) if @_;
                    wantarray ? @{ $self->{$field} } : $self->{$field};
                }
            );
            $self->install_accessor(
                name => [ "pop_${field}", "${field}_pop" ],
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${field}_pop"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self) = @_;
                    pop @{ $self->{$field} };
                }
            );
            $self->install_accessor(
                name => [ "set_push_${field}", "${field}_set_push" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_set_push"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self, @values) = @_;
                    set_push @{ $self->{$field} }, $self->$normalize(@values);
                }
            );
            $self->install_accessor(
                name => [ "push_${field}", "${field}_push" ],
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${field}_push"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self, @values) = @_;
                    push @{ $self->{$field} }, $self->$normalize(@values);
                }
            );
            $self->install_accessor(
                name => [ "shift_${field}", "${field}_shift" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_shift"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self) = @_;
                    shift @{ $self->{$field} };
                }
            );
            $self->install_accessor(
                name => [ "unshift_${field}", "${field}_unshift" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_unshift"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self, @values) = @_;
                    unshift @{ $self->{$field} }, $self->$normalize(@values);
                }
            );
            $self->install_accessor(
                name => [ "splice_${field}", "${field}_splice" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_splice"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self, $offset, $len, @list) = @_;
                    splice(@{ $self->{$field} }, $offset, $len, @list);
                }
            );
            $self->install_accessor(
                name => [ "clear_${field}", "${field}_clear" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_clear"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self) = @_;
                    @{ $self->{$field} } = ();
                }
            );
            $self->install_accessor(
                name => [ "count_${field}", "${field}_count" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_count"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self) = @_;
                    exists $self->{$field} ? scalar @{ $self->{$field} } : 0;
                }
            );
            $self->install_accessor(
                name => [ "index_${field}", "${field}_index" ],
                code => sub {
                    local $DB::sub = local *__ANON__ =
                      "${class}::${field}_index"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my $self = shift;
                    my (@indices) = @_;
                    my @Result;
                    push @Result, $self->{$field}->[$_] for @indices;
                    return $Result[0] if @_ == 1;
                    wantarray ? @Result : \@Result;
                }
            );
            $self->install_accessor(
                name => [ "set_${field}", "${field}_set" ],
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${field}_set"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my $self = shift;
                    my @args = @_;
                    croak "${field}_set expects an even number of fields\n"
                      if @args % 2;
                    while (my ($index, $value) = splice @args, 0, 2) {
                        $self->{$field}->[$index] = $self->$normalize($value);
                    }
                    return @_ / 2;
                }
            );
            $self->install_accessor(
                name => [ "ref_${field}", "${field}_ref" ],
                code => sub {
                    local $DB::sub = local *__ANON__ = "${class}::${field}_ref"
                      if defined &DB::DB && !$Devel::DProf::VERSION;
                    my ($self) = @_;
                    $self->{$field};
                }
            );
        }
    }
    $self;    # for chaining
}
1;


__END__