view release on metacpan or  search on metacpan

lib/Abstract/Meta/Attribute/Method.pm  view on Meta::CPAN

}


=item validate_data_type

=cut

sub validate_data_type {
    my ($attr, $self, $value, $accessor, $associated_class, $perl_type) = @_;
    my $array_storage_type = $attr->storage_type eq 'Array';
    if ($perl_type eq 'Array') {
        confess "$accessor must be $perl_type type"
            unless (ref($value) eq 'ARRAY');
        if ($associated_class) {
            validate_associated_class($attr, $self, $_)
              for @$value;
        }
    } elsif ($perl_type eq 'Hash') {
        confess "$accessor must be $perl_type type"
          unless (ref($value) eq 'HASH');
        if ($associated_class) {
            validate_associated_class($attr, $self, $_)
              for values %$value;
        }
    } elsif ($associated_class) {
        my $transistent = $attr->transistent;    
        my $storage_key = $attr->storage_key;
        my $current_value = $transistent ? get_attribute($self, $storage_key) : ($array_storage_type ? $self->[$storage_key] : $self->{$storage_key});
        return if ($value && $current_value && $value eq $current_value);
        $attr->deassociate($self);
        if (defined $value) {
            validate_associated_class($attr, $self, $value);
        }
    }
}


=item validate_associated_class

=cut

sub validate_associated_class {
    my ($attr, $self, $value) = @_;
    my $associated_class = $attr->associated_class;
    my $name = $attr->name;
    my $value_type = ref($value)
      or confess "$name must be of the $associated_class type";    
    return &associate_the_other_end if $value_type eq $associated_class;
    return &associate_the_other_end if $value->isa($associated_class);
    confess "$name must be of the $associated_class type, is $value_type";      
}


=item pending_transation

=cut

{   my %pending_association;


=item start_association_process

Start association process (to avoid infinitive look of associating the others ends)
Takes obj reference.

=cut

    sub start_association_process {
    my ($self) = @_;
        $pending_association{$self} = 1;
    }


=item has_pending_association

Returns true is object is during association process.

=cut

    sub has_pending_association {
        my ($self) = @_;
        $pending_association{$self}; 
    }


=item end_association_process

Compleetes association process.

=cut

    sub end_association_process {
        my ($self) = @_;
        delete $pending_association{$self};
    }

}


=item associate_the_other_end

Associate current object reference to the the other end associated class.

TODO

=cut

sub associate_the_other_end {
    my ($attr, $self, $value) = @_;
    my $the_other_end = $attr->the_other_end;
    my $name = $attr->name;
    return if ! $the_other_end || has_pending_association($self);
    my $associated_class = $attr->associated_class;
    my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);

    confess "missing other end attribute on ". ref($value) . "::" . $the_other_end
        unless $the_other_end_attribute;

    confess "invalid definition for " . ref($self) ."::". $name
    . " - associatied class not defined on " . ref($value) ."::" . $the_other_end
        unless $the_other_end_attribute->associated_class;

    start_association_process($value);
    eval {
            my $association_call = 'associate_' . lc($the_other_end_attribute->perl_type) . '_as_the_other_end';
            $attr->$association_call($self, $value);
    };
    end_association_process($value);
    die $@ if $@;
}



=item associate_scalar_as_the_other_end

=cut

sub associate_scalar_as_the_other_end {
    my ($attr, $self, $value) = @_;
    my $the_other_end = $attr->the_other_end;
    $value->$the_other_end($self);
}


=item associate_hash_as_the_other_end

=cut

sub associate_hash_as_the_other_end {
    my ($attr, $self, $value) = @_;
    my $the_other_end = $attr->the_other_end;
    my $associated_class = $attr->associated_class;
    my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
    my $item_accessor = $the_other_end_attribute->item_accessor;
    my $index_by = $the_other_end_attribute->index_by;
    if ($index_by) {
        $value->$item_accessor($self->$index_by, $self);
    } else {
        $value->$item_accessor($self . "", $self);
    }
}


=item associate_array_as_the_other_end

=cut

sub associate_array_as_the_other_end {
    my ($attr, $self, $value) = @_;
    my $the_other_end = $attr->the_other_end;
    my $associated_class = $attr->associated_class;    
    my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
    my $other_end_accessor = $the_other_end_attribute->accessor;
    my $setter = "push_${other_end_accessor}";
    $value->$setter($self);
}


=item deassociate

Deassociates assoication values

=cut

sub deassociate {
    my ($attr, $self) = @_;
    my $transistent = $attr->transistent;    
    my $storage_key = $attr->storage_key;
    my $array_storage_type = $attr->storage_type eq 'Array';
    my $value = ($transistent ? get_attribute($self, $storage_key) : ($array_storage_type ? $self->[$storage_key] : $self->{$storage_key})) or return;
    my $the_other_end = $attr->the_other_end;
    return if ! $the_other_end || has_pending_association($value);
    start_association_process($self);
    my $associated_class = $attr->associated_class;
    my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
    my $deassociation_call = 'deassociate_' . lc($the_other_end_attribute->perl_type) . '_as_the_other_end';
    if(ref($value) eq 'ARRAY') {
        $the_other_end_attribute->$deassociation_call($self, $_) for @$value;
    } elsif(ref($value) eq 'HASH') {
        $the_other_end_attribute->$deassociation_call($self, $value->{$_}) for(keys %$value);
    } else {
        $the_other_end_attribute->$deassociation_call($self, $value);
    }
    end_association_process($self);
}


=item deassociate_scalar_as_the_other_end

=cut

sub deassociate_scalar_as_the_other_end {
    my ($attr, $self, $the_other_end_obj) = @_;
    $the_other_end_obj or return;
    my $accessor = $attr->accessor;
    $the_other_end_obj->$accessor(undef);
    undef;
}


=item deassociate_hash_as_the_other_end

=cut

sub deassociate_hash_as_the_other_end {
    my ($attr, $self, $the_other_end_obj) = @_;
    my $accessor = $attr->accessor;
    my $value = $the_other_end_obj->$accessor;
    my $index_by = $attr->index_by;
    if ($index_by) {
        delete $value->{$self->$index_by} if exists($value->{$self->$index_by});
    } else {
        my @keys = keys %$value;
        foreach my $k (@keys) {
            if ($value->{$k} eq $self) {
                delete $value->{$k};
                return;
            }
        }
    }
    undef;
}


=item deassociate_array_as_the_other_end

=cut

sub deassociate_array_as_the_other_end {
    my ($attr, $self, $the_other_end_obj) = @_;
    my $accessor = $attr->accessor;
    my $value = $the_other_end_obj->$accessor;
    for my $i (0 .. $#{$value}) {
        if ($value->[$i] eq $self) {
            splice @$value, $i--, 1;
        }
    }
    undef;
}


=item generate_scalar_mutator_method

=cut