adding-basic-role-support

[gitmo/Moose.git] / lib / Moose / Meta / Role.pm

package Moose::Meta::Role;

use strict;
use warnings;
use metaclass;

use Carp 'confess';

our $VERSION = '0.01';

__PACKAGE__->meta->add_attribute('role_meta' => (
    reader => 'role_meta'
));

__PACKAGE__->meta->add_attribute('attribute_map' => (
    reader   => 'get_attribute_map',
    default  => sub { {} }
));

__PACKAGE__->meta->add_attribute('method_modifier_map' => (
    reader  => 'get_method_modifier_map',
    default => sub { 
        return {
            before   => {},
            after    => {},
            around   => {},
            override => {},                            
            augment  => {},                                        
        };
    }
));

sub new {
    my $class   = shift;
    my %options = @_;
    $options{role_meta} = Class::MOP::Class->initialize($options{role_name});
    my $self = $class->meta->new_object(%options);
    return $self;
}

# NOTE:
# we delegate to some role_meta methods for convience here
# the Moose::Meta::Role is meant to be a read-only interface
# to the underlying role package, if you want to manipulate 
# that, just use ->role_meta

sub name    { (shift)->role_meta->name    }
sub version { (shift)->role_meta->version }

sub get_method      { (shift)->role_meta->get_method(@_)  }
sub has_method      { (shift)->role_meta->has_method(@_)  }
sub get_method_list { 
    my ($self) = @_;
    # meta is not applicable in this context, 
    # if you want to see it use the ->role_meta
    grep { !/^meta$/ } $self->role_meta->get_method_list;
}

# ... however the items in statis (attributes & method modifiers)
# can be removed and added to through this API

# attributes

sub add_attribute {
    my ($self, $name, %attr_desc) = @_;
    $self->get_attribute_map->{$name} = \%attr_desc;
}

sub has_attribute {
    my ($self, $name) = @_;
    exists $self->get_attribute_map->{$name} ? 1 : 0;
}

sub get_attribute {
    my ($self, $name) = @_;
    $self->get_attribute_map->{$name}
}

sub remove_attribute {
    my ($self, $name) = @_;
    delete $self->get_attribute_map->{$name}
}

sub get_attribute_list {
    my ($self) = @_;
    keys %{$self->get_attribute_map};
}

# method modifiers

sub add_method_modifier {
    my ($self, $modifier_type, $method_name, $method) = @_;
    $self->get_method_modifier_map->{$modifier_type}->{$method_name} = $method;
}

sub has_method_modifier {
    my ($self, $modifier_type, $method_name) = @_;
    exists $self->get_method_modifier_map->{$modifier_type}->{$method_name} ? 1 : 0
}

sub get_method_modifier {
    my ($self, $modifier_type, $method_name) = @_;
    $self->get_method_modifier_map->{$modifier_type}->{$method_name};
}

sub remove_method_modifier {
    my ($self, $modifier_type, $method_name) = @_;
    delete $self->get_method_modifier_map->{$modifier_type}->{$method_name};
}

sub get_method_modifier_list {
    my ($self, $modifier_type) = @_;
    keys %{$self->get_method_modifier_map->{$modifier_type}};
}


1;

__END__

=pod

=head1 NAME

Moose::Meta::Role - The Moose Role metaclass

=head1 DESCRIPTION

=head1 METHODS

=over 4

=item B<meta>

=item B<new>

=back

=over 4

=item B<name>

=item B<version>

=item B<role_meta>

=back

=over 4

=item B<get_method>

=item B<has_method>

=item B<get_method_list>

=back

=over 4

=item B<add_attribute>

=item B<has_attribute>

=item B<get_attribute>

=item B<get_attribute_list>

=item B<get_attribute_map>

=item B<remove_attribute>

=back

=over 4

=item B<add_method_modifier>

=item B<get_method_modifier>

=item B<has_method_modifier>

=item B<get_method_modifier_list>

=item B<get_method_modifier_map>

=item B<remove_method_modifier>

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no 
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 AUTHOR

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut