view release on metacpan or  search on metacpan

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

Adds class to meta repository.

=cut

    sub install_meta_class {
        my ($class) = @_;
        $meta{$class} = __PACKAGE__->new(
            associated_class  => $class,
            attributes        => [],
            initialise_method => 'initialise'
        );
        add_method($class, 'meta', sub{$meta{$class}});
    }


=item meta_class

Returns meta class object for passed in class name.

=cut

    sub meta_class {
        my ($class) = @_;
        install_meta_class($class)unless $meta{$class};
        $meta{$class};
    }
}


=item add_attribute

=cut

sub add_attribute {
    my ($self, $attribute) = @_;
    $self->install_attribute_methods($attribute);
    push @{$self->attributes}, $attribute;
}


=item attribute_class

Returns meta attribute class

=cut

sub attribute_class { 'Abstract::Meta::Attribute' }


=item has

Creates a meta attribute.

Takes attribute name, and the following attribute options:
see also L<Abstract::Meta::Attribute>

=cut

sub has {
    my $name = shift;
    my $package = caller();
    my $meta_class = meta_class($package);
    my $attribute = $meta_class->attribute_class->new(name => $name, @_, class => $package, storage_type => $meta_class->storage_type);
    $meta_class->add_attribute($attribute);
    $meta_class->install_cleanup
        if($attribute->transistent || $attribute->index_by);
    $meta_class->install_destructor
        if $attribute->transistent;
    $attribute;
}


=item storage_type

Sets storage type for the attributes.
allowed values are Array/Hash

=cut

sub storage_type {
    my ($param) = @_;
    return $param->{'$.storage_type'} ||= 'Hash'
        if (ref($param));
    my $type = $param;
    confess "unknown storage type $type - should be Array or Hash"
        unless($type =~ /Array|Hash/);
    my $package = caller();
    my $meta_class = meta_class($package);
    $meta_class->{'$.storage_type'} = $type;
    remove_method($meta_class->associated_class, 'new');
    $meta_class->install_constructor();
   
}


=item abstract

Creates an abstract method

=cut

sub abstract {
    my $name = shift;
    my $package = caller();
    my $meta_class = meta_class($package);
    $meta_class->install_abstract_methods($name);
}



=item abstract_class

Creates an abstract method

=cut

sub abstract_class {
    my $name = shift;
    my $package = caller();
    my $meta_class = meta_class($package);
    $meta_class->set_abstract(1);
    no warnings 'redefine';
    no strict 'refs';
    *{"${package}::new"} = sub {
        confess "Can't instantiate abstract class " . $package;
    };
}

=item install_abstract_methods

=cut

sub install_abstract_methods {
    my ($self, $method_name) = @_;
    add_method($self->associated_class, $method_name, sub {
       confess $method_name . " is an abstract method"; 
    });
}


=item install_attribute_methods

Installs attribute methods.

=cut

sub install_attribute_methods {
    my ($self, $attribute, $remove_existing_method) = @_;
    my $accessor = $attribute->accessor;
    foreach (qw(accessor mutator)) {
        add_method($self->associated_class, $attribute->$_, $attribute->generate($_), $remove_existing_method); 
    }

    my $perl_type = $attribute->perl_type ;
    if ($perl_type eq 'Array') {
        add_method($self->associated_class, "${_}_$accessor", $attribute->generate("$_"), $remove_existing_method)
        for qw(count push pop shift unshift);
    }

    if (my $item_accessor = $attribute->item_accessor) {
        add_method($self->associated_class, $item_accessor, $attribute->generate('item_accessor'), $remove_existing_method);
    }
    
    if (($perl_type eq 'Array' || $perl_type eq 'Hash') && $attribute->associated_class) {
        add_method($self->associated_class, "add_${accessor}", $attribute->generate('add'), $remove_existing_method);
        add_method($self->associated_class, "remove_${accessor}", $attribute->generate('remove'), $remove_existing_method);
    }
    
    if($attribute->associated_class) {
        add_method($self->associated_class, "reset_${accessor}", $attribute->generate('reset'), $remove_existing_method);
        add_method($self->associated_class, "has_${accessor}", $attribute->generate('has'), $remove_existing_method);
    }
}


=item add_method

Adds code reference to the class symbol table.
Takes a class name, method name and CODE reference.