Abstract-Meta-Class

 view release on metacpan or  search on metacpan

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

            my ($self, @args) = @_;
            $self->$mutator(@args) if scalar(@args) >= 1;
            my $result = $on_read
            ? $on_read ->($self, $attr, 'accessor')
            : get_attribute($self, $storage_key);
            $result;
        }
        : (
           $on_read ?
           sub {
            my ($self, @args) = @_;
            $self->$mutator(@args) if scalar(@args) >= 1;
            my $result = $on_read
            ? $on_read ->($self, $attr, 'accessor')
            : $self->[$storage_key];
            $result;
            } :
            sub {
                my ($self, @args) = @_;
                $self->$mutator(@args) if @args >= 1;
                $self->[$storage_key];
            }
           )
        )
    :
    sub {
        my ($self, @args) = @_;
        $self->$mutator(@args) if scalar(@args) >= 1;
        my $result = $on_read
        ? $on_read ->($self, $attr, 'accessor')
        : $transistent ? get_attribute($self, $storage_key) : $self->{$storage_key};
        $result;
    };
}


=item generate_code_accessor_method

=cut

sub generate_code_accessor_method {
    my $attr = shift;
    $attr->generate_scalar_accessor_method;
}


=item generate_mutator_method

=cut

sub generate_mutator_method {
    my $attr = shift;
    my $storage_key = $attr->storage_key;
    my $transistent = $attr->transistent;    
    my $accessor = $attr->accessor;
    my $required = $attr->required;
    my $default = $attr->default;
    my $associated_class = $attr->associated_class;
    my $perl_type = $attr->perl_type;
    my $index_by = $attr->index_by;
    my $on_change = $attr->on_change;
    my $data_type_validation = $attr->data_type_validation;
    my $on_validate = $attr->on_validate;
    my $array_storage_type = $attr->storage_type eq 'Array';
    $array_storage_type ?
    sub {
        my ($self, $value) = @_;
        if (! defined $value && defined $default) {
            if (ref($default) eq 'CODE') {
                $value = $default->($self, $attr);
            } else {
                $value = $default;
            }
        }

        $on_validate->($self, $attr, 'mutator', \$value) if $on_validate;
        if ($data_type_validation) {
            $value = index_association_data($value, $accessor, $index_by)
                if ($associated_class && $perl_type eq 'Hash');
            $attr->validate_data_type($self, $value, $accessor, $associated_class, $perl_type);
            if($required) {
                if ($perl_type eq 'Hash') {
                    confess "attribute $accessor is required"
                      unless scalar %$value;
                      
                } elsif ($perl_type eq 'Array') {
                    confess "attribute $accessor is required"
                      unless scalar @$value;
                }
            }

        } else {
        confess "attribute $accessor is required"
          if $required && ! defined $value;
        }
        
        $on_change->($self, $attr, 'mutator', \$value) or return $self
          if ($on_change && defined $value);
        

        if ($transistent) {
            set_attribute($self, $storage_key, $value);
        } else {
            $self->[$storage_key] = $value;
        }
        $self;
    }    
    :
    sub {
        my ($self, $value) = @_;
        if (! defined $value && defined $default) {
            if (ref($default) eq 'CODE') {
                $value = $default->($self, $attr);
            } else {
                $value = $default;
            }
        }

        $on_validate->($self, $attr, 'mutator', \$value) if $on_validate;
        if ($data_type_validation) {
            $value = index_association_data($value, $accessor, $index_by)
                if ($associated_class && $perl_type eq 'Hash');
            $attr->validate_data_type($self, $value, $accessor, $associated_class, $perl_type);
            if($required) {
                if ($perl_type eq 'Hash') {
                    confess "attribute $accessor is required"
                      unless scalar %$value;
                      
                } elsif ($perl_type eq 'Array') {
                    confess "attribute $accessor is required"
                      unless scalar @$value;
                }
            }
        } else {
            confess "attribute $accessor is required"
              if $required && ! defined $value;
        }

        
        $on_change->($self, $attr, 'mutator', \$value) or return $self
          if ($on_change && defined $value);
        

        if ($transistent) {
            set_attribute($self, $storage_key, $value);
        } else {
            $self->{$storage_key} = $value;
        }
        $self;
    };
}


=item index_association_data

=cut

sub index_association_data {
    my ($data, $attr_name, $index) = @_;
    return $data if ref($data) eq 'HASH';
    my %result;
    if($index && $$data[0]->can($index)) {
        %result = (map {($_->$index, $_)} @$data);
    } else {
        %result = (map {($_  . "", $_)} @$data);
    }
    \%result;
}


=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);
        }
    }

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

        } 
        : sub {
            my ($self, @args) = @_;
            $self->$mutator(@args) if scalar(@args) >= 1;
            my $result = $on_read
                ? $on_read->($self, $attr, 'accessor')
                : ($transistent ?  get_attribute($self, $storage_key) : ($self->{$storage_key} ||= {}));
            wantarray ? %$result : $result;
     });
}


=item generate_to_many_accessor_method

=cut

sub generate_to_many_accessor_method {
    my $attr = shift; 
    my $mutator = $attr->mutator;
    my $storage_key = $attr->storage_key;
    my $transistent = $attr->transistent;
    my $on_read = $attr->on_read;
    my $array_storage_type = $attr->storage_type eq 'Array';
    $array_storage_type ?
    sub {
        my ($self, @args) = @_;
        $self->$mutator(@args) if scalar(@args) >= 1;
        my $result = $on_read
            ? $on_read->($self, $attr, 'accessor') 
            : ($transistent ? get_attribute($self, $storage_key) : ($self->[$storage_key] ||= {}));
        wantarray ? %$result : $result;            
    }    
    :
    sub {
        my ($self, @args) = @_;
        $self->$mutator(@args) if scalar(@args) >= 1;
        my $result = $on_read
            ? $on_read->($self, $attr, 'accessor') 
            : ($transistent ? get_attribute($self, $storage_key) : ($self->{$storage_key} ||= {}));
        wantarray ? %$result : $result;            
    };
} 


=item generate_hash_mutator_method

=cut

sub generate_hash_mutator_method {
    shift()->generate_mutator_method;
}


=item generate_hash_item_accessor_method

=cut

sub generate_hash_item_accessor_method {
    my $attr = shift;
    my $accesor =  $attr->accessor;
    my $on_change = $attr->on_change;
    my $on_read = $attr->on_read;
    sub {
        my $self = shift;
        my ($key, $value) = (@_);
        my $hash_ref = $self->$accesor();
        if(defined $value) {
            $on_change->($self, $attr, 'item_accessor', \$value, $key) or return $hash_ref->{$key}
              if ($on_change);
            $hash_ref->{$key} = $value;
        }
        $on_read ? $on_read->($self, $attr, 'item_accessor', $key) : $hash_ref->{$key};
    };
}


=item generate_hash_add_method

=cut

sub generate_hash_add_method {
    my $attr = shift;
    my $accessor = $attr->accessor;
    my $item_accessor = $attr->item_accessor;
    my $on_change = $attr->on_change;
    my $on_read = $attr->on_read;
    my $index_by = $attr->index_by;
    sub {
        my ($self, @values) = @_;
        my $hash_ref = $self->$accessor();
        foreach my $value (@values) {
            next unless ref($value);
            my $key = ($index_by ? $value->$index_by : $value . "") or confess "unknown key hash at add_$accessor";
            $attr->validate_associated_class($self, $value);
            $on_change->($self, $attr, 'item_accessor', \$value, $key) or return $hash_ref->{$key}
              if ($on_change);
            $hash_ref->{$key} = $value;
        }
        $self;
    };
}


=item generate_scalar_reset_method

=cut

sub generate_scalar_reset_method {
    my $attr = shift;
    my $mutator = $attr->mutator;
    my $index_by = $attr->index_by;
    sub {
        my ($self, ) = @_;
        $self->$mutator(undef);
    };
}


=item generate_scalar_has_method

=cut

sub generate_scalar_has_method {
    my $attr = shift;
    sub {
        my ($self, ) = @_;
        !! $attr->get_value($self);
    };
}


=item generate_hash_reset_method

=cut

sub generate_hash_reset_method {
    my $attr = shift;
    my $mutator = $attr->mutator;
    my $index_by = $attr->index_by;
    sub {
        my ($self, ) = @_;
        $self->$mutator({});
    };
}



=item generate_hash_has_method

=cut

sub generate_hash_has_method {
    my $attr = shift;
    sub {
        my ($self, ) = @_;
        my $value = $attr->get_value($self);

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

    my $index_by = $attr->index_by;
    sub {
        my ($self, ) = @_;
        $self->$mutator([]);
    };
}


=item generate_array_has_method

=cut

sub generate_array_has_method {
    my $attr = shift;
    sub {
        my ($self, ) = @_;
        my $value = $attr->get_value($self);
        !! ($value && @$value);
    };
}


=item generate_hash_remove_method

=cut

#TODO add on_remove trigger

sub generate_hash_remove_method {
    my $attr = shift;
    my $accessor = $attr->accessor;
    my $item_accessor = $attr->item_accessor;
    my $the_other_end = $attr->the_other_end;
    my $meta =  Abstract::Meta::Class::meta_class($attr->associated_class);
    my $reflective_attribute = $the_other_end && $meta ? $meta->attribute($the_other_end) : undef;
    my $index_by = $attr->index_by;
    sub {
        my ($self, @values) = @_;
        my $hash_ref = $self->$accessor();
        foreach my $value (@values) {
            next unless ref($value);
            my $key = ($index_by && ref($value) ? $value->$index_by : $value . "");
            $attr->deassociate($self);
            $reflective_attribute->set_value($hash_ref->{$key}, undef)
                if $reflective_attribute;
            delete $hash_ref->{$key};
        }
        $self;
    };
}



=item generate_array_item_accessor_method

=cut

sub generate_array_item_accessor_method {
    my $attr = shift;
    my $accesor = $attr->accessor;
    my $on_change = $attr->on_change;
    my $on_read = $attr->on_read;
    sub {
        my $self = shift;
        my ($index, $value) = (@_);
        my $hash_ref = $self->$accesor();
        if (defined $value) {
            $on_change->($self, $attr, 'item_accessor', \$value, $index) or return $hash_ref->[$index]
              if ($on_change);
            $hash_ref->[$index] = $value;
        }
        $on_read ? $on_read->($self, $attr, 'item_accessor', $index) : $hash_ref->[$index];
    };
}


=item generate_array_push_method

=cut

sub generate_array_push_method {
    my $attr = shift;
    my $accesor = $attr->accessor;
    sub {
        my $self = shift;
        my $array_ref = $self->$accesor();
        push @$array_ref, @_;
    };
}


=item generate_array_pop_method

=cut

sub generate_array_pop_method {
    my $attr = shift;
    my $accesor = $attr->accessor;
    sub {
        my $self = shift;
        my $array_ref = $self->$accesor();
        pop @$array_ref;
    };
}


=item generate_array_shift_method

=cut

sub generate_array_shift_method {
    my $attr = shift;
    my $accesor = $attr->accessor;
    sub {
        my $self = shift;
        my $array_ref= $self->$accesor();
        shift @$array_ref;
    };
}


=item generate_array_unshift_method

=cut

sub generate_array_unshift_method {
    my $attr = shift;
    my $accesor = $attr->accessor;
    sub {