view release on metacpan or  search on metacpan

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

=head1 EXPORT

None.

=head2 METHODS

=over

=item new

=cut


sub new {
    my $class = shift;
    unshift @_, $class;
    bless {&initialise}, $class;
}


=item initialise

Initialises attribute

=cut

{
   my %supported_type = (
      '$' => 'Scalar',
      '@' => 'Array',
      '%' => 'Hash',
      '&' => 'Code',
    );

    sub initialise {
        my ($class, %args) = @_;
        foreach my $k (keys %args) {
            confess "unknown attribute $k"
            unless Abstract::Meta::Attribute->can($k);
        }
        my $name = $args{name} or confess "name is requried";
        my $storage_type = $args{storage_type} = $args{transistent} ? 'Hash' : $args{storage_type} || '';
        
        my $attribute_index = 0;
        if($storage_type  eq 'Array')  {
            my $meta_class= Abstract::Meta::Class::meta_class($args{class});
            $attribute_index = $#{$meta_class->all_attributes} + 1;
        }
        
        my ($type, $accessor_name) = ($name =~ /^([\$\@\%\&])\.(.*)$/);
        confess "invalid attribute defintion ${class}::" .($accessor_name || $name) .", supported prefixes are \$.,%.,\@.,&."
          if ! $type || ! $supported_type{$type};

        my %options;
        $args{data_type_validation} = 1
        if (! exists($args{data_type_validation})
            && ($type eq '@' || $type eq '%' || $args{associated_class}));

        $options{'&.' . $_ } = $args{$_}
            for grep {exists $args{$_}} (qw(on_read on_change on_validate));
        
        
        my $storage_key = $storage_type eq 'Array' ? $attribute_index : $args{storage_key} || $args{name};

        $options{'$.name'} = $accessor_name;
        $options{'$.storage_key'} = $storage_key;
        $options{'$.mutator'} = "set_$accessor_name";
        $options{'$.accessor'} = $accessor_name;
        $options{'$.' . $_ } = $args{$_}
          for grep {exists $args{$_}}
            (qw(class required default item_accessor associated_class data_type_validation index_by the_other_end transistent storage_type));
          
        $options{'$.perl_type'} = $supported_type{$type};
        unless  ($args{default}) {
            if($type eq '%') {
                $options{'$.default'} = sub{ {} };
            } elsif ($type eq '@') {
                $options{'$.default'} = sub { [] };
            }
        }        
        %options;
    }
}


=item name

Returns attribute name

=cut

sub name { shift()->{'$.name'} }


=item class

Attribute's class name.

=cut

sub class { shift()->{'$.class'} }


=item storage_key

Returns storage attribute key in object

=cut

sub storage_key { shift()->{'$.storage_key'} }



=item perl_type

Returns attribute type, Scalar, Hash, Array, Code

=cut

sub perl_type { shift()->{'$.perl_type'} }

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

    has '@.array_attrs.' => (
        item_accessor => 'array_item'
        on_read => sub {
            my ($self, $attribute, $scope, $index) = @_;
            my $values = $attribute->get_values($self);
            if ($scope eq 'accessor') {
                return $values;
            } else {
                return $values->[$index];
            }
        },
    );

=cut

sub on_read { shift()->{'&.on_read'} }


=item set_on_read

Sets  code reference that will be replace data read routine

   my $attr = MyClass->meta->attribute('attrs'); 
    $attr->set_on_read(sub {
        my ($self, $attribute, $scope, $key) = @_;
        #do some stuff
    });

=cut

sub set_on_read {
    my ($attr, $value) = @_;
    $attr->{'&.on_read'} = $value;
    my $meta= $attr->class->meta;
    $meta->install_attribute_methods($attr, 1);
}


=item on_change

Code reference that will be executed when data is set,
Takes reference to the variable to be set.

=cut

sub on_change { shift()->{'&.on_change'} }



=item set_on_change

Sets code reference that will be executed when data is set,

   my $attr = MyClass->meta->attribute('attrs'); 
   $attr->set_on_change(sub {
           my ($self, $attribute, $scope, $value, $key) = @_;
            if($scope eq 'mutator') {
                my $hash = $$value;
                foreach my $k (keys %$hash) {
                    #  do some stuff
                    #$self->validate_trigger($k, $hash->{$k});
                }
            } else {
                # do some stuff
                $self->validate_trigger($key. $$value);
            }
            $self;      
    });

=cut

sub set_on_change {
    my ($attr, $value) = @_;               
    $attr->{'&.on_change'} = $value;
    my $meta= $attr->class->meta;
    $meta->install_attribute_methods($attr, 1);
}





=item on_validate

Returns on validate code reference.
It is executed before the data type validation happens.

=cut

sub on_validate { shift()->{'&.on_validate'} }


=item set_on_validate

Sets  code reference that will be replace data read routine

   my $attr = MyClass->meta->attribute('attrs'); 
    $attr->set_on_read(sub {
        my ($self, $attribute, $scope, $key) = @_;
        #do some stuff
    });

=cut

sub set_on_validate {
    my ($attr, $value) = @_;
    $attr->{'&.on_validate'} = $value;
    my $meta= $attr->class->meta;
    $meta->install_attribute_methods($attr, 1);
}




1;    

__END__

=back

=head1 SEE ALSO

L<Abstract::Meta::Class>.

=head1 COPYRIGHT AND LICENSE

The Abstract::Meta::Attribute module is free software. You may distribute under the terms of
either the GNU General Public License or the Artistic License, as specified in
the Perl README file.

=head1 AUTHOR

Adrian Witas, adrian@webapp.strefa.pl

=cut