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


package Moose::Meta::Role;

use strict;
use warnings;
use metaclass;

use Sub::Name    'subname';
use Carp         'confess';
use Scalar::Util 'blessed', 'reftype';

our $VERSION   = '0.12';
our $AUTHORITY = 'cpan:STEVAN';

use Moose::Meta::Class;
use Moose::Meta::Role::Method;
use Moose::Meta::Role::Method::Required;

use base 'Class::MOP::Module';

## ------------------------------------------------------------------
## NOTE:
## I normally don't do this, but I am doing
## a whole bunch of meta-programmin in this
## module, so it just makes sense. For a clearer
## picture of what is going on in the next 
## several lines of code, look at the really 
## big comment at the end of this file (right
## before the POD).
## - SL
## ------------------------------------------------------------------

my $META = __PACKAGE__->meta;

## ------------------------------------------------------------------
## attributes ...

# NOTE:
# since roles are lazy, we hold all the attributes
# of the individual role in 'statis' until which
# time when it is applied to a class. This means
# keeping a lot of things in hash maps, so we are
# using a little of that meta-programmin' magic
# here an saving lots of extra typin. And since 
# many of these attributes above require similar
# functionality to support them, so we again use
# the wonders of meta-programmin' to deliver a
# very compact solution to this normally verbose
# problem.
# - SL

foreach my $action (
    {
        name        => 'excluded_roles_map',
        attr_reader => 'get_excluded_roles_map' ,
        methods     => {
            add       => 'add_excluded_roles',
            get_list  => 'get_excluded_roles_list',
            existence => 'excludes_role',
        }
    },
    {
        name        => 'required_methods',
        attr_reader => 'get_required_methods_map',
        methods     => {
            add       => 'add_required_methods',
            remove    => 'remove_required_methods',
            get_list  => 'get_required_method_list',
            existence => 'requires_method',
        }
    },
    {
        name        => 'attribute_map',
        attr_reader => 'get_attribute_map',
        methods     => {
            get       => 'get_attribute',
            get_list  => 'get_attribute_list',
            existence => 'has_attribute',
            remove    => 'remove_attribute',
        }
    }
) {

    my $attr_reader = $action->{attr_reader};
    my $methods     = $action->{methods};

    # create the attribute
    $META->add_attribute($action->{name} => (
        reader  => $attr_reader,
        default => sub { {} }
    ));

    # create some helper methods
    $META->add_method($methods->{add} => sub {
        my ($self, @values) = @_;
        $self->$attr_reader->{$_} = undef foreach @values;
    }) if exists $methods->{add};

    $META->add_method($methods->{get_list} => sub {
        my ($self) = @_;
        keys %{$self->$attr_reader};
    }) if exists $methods->{get_list};

    $META->add_method($methods->{get} => sub {
        my ($self, $name) = @_;
        $self->$attr_reader->{$name}
    }) if exists $methods->{get};

    $META->add_method($methods->{existence} => sub {
        my ($self, $name) = @_;
        exists $self->$attr_reader->{$name} ? 1 : 0;
    }) if exists $methods->{existence};

    $META->add_method($methods->{remove} => sub {
        my ($self, @values) = @_;
        delete $self->$attr_reader->{$_} foreach @values;
    }) if exists $methods->{remove};
}

## some things don't always fit, so they go here ...

sub add_attribute {
    my $self = shift;
    my $name = shift;
    my $attr_desc;
    if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
        $attr_desc = $_[0];
    }
    else {
        $attr_desc = { @_ };
    }
    $self->get_attribute_map->{$name} = $attr_desc;
}

# DEPRECATED 
# sub _clean_up_required_methods {
#     my $self = shift;
#     foreach my $method ($self->get_required_method_list) {
#         $self->remove_required_methods($method)
#             if $self->has_method($method);
#     }
# }

## ------------------------------------------------------------------
## method modifiers

# NOTE:
# the before/around/after method modifiers are
# stored by name, but there can be many methods
# then associated with that name. So again we have
# lots of similar functionality, so we can do some
# meta-programmin' and save some time.
# - SL

foreach my $modifier_type (qw[ before around after ]) {

    my $attr_reader = "get_${modifier_type}_method_modifiers_map";
    
    # create the attribute ...
    $META->add_attribute("${modifier_type}_method_modifiers" => (
        reader  => $attr_reader,
        default => sub { {} }
    ));  

    # and some helper methods ...
    $META->add_method("get_${modifier_type}_method_modifiers" => sub {
        my ($self, $method_name) = @_;
        #return () unless exists $self->$attr_reader->{$method_name};
        @{$self->$attr_reader->{$method_name}};
    });

    $META->add_method("has_${modifier_type}_method_modifiers" => sub {
        my ($self, $method_name) = @_;
        # NOTE:
        # for now we assume that if it exists,..
        # it has at least one modifier in it
        (exists $self->$attr_reader->{$method_name}) ? 1 : 0;
    });

    $META->add_method("add_${modifier_type}_method_modifier" => sub {
        my ($self, $method_name, $method) = @_;

        $self->$attr_reader->{$method_name} = []
            unless exists $self->$attr_reader->{$method_name};

        my $modifiers = $self->$attr_reader->{$method_name};

        # NOTE:
        # check to see that we aren't adding the
        # same code twice. We err in favor of the
        # first on here, this may not be as expected
        foreach my $modifier (@{$modifiers}) {
            return if $modifier == $method;
        }

        push @{$modifiers} => $method;
    });

}

## ------------------------------------------------------------------
## override method mofidiers

$META->add_attribute('override_method_modifiers' => (
    reader  => 'get_override_method_modifiers_map',
    default => sub { {} }
));

# NOTE:
# these are a little different because there
# can only be one per name, whereas the other
# method modifiers can have multiples.
# - SL

sub add_override_method_modifier {
    my ($self, $method_name, $method) = @_;
    (!$self->has_method($method_name))
        || confess "Cannot add an override of method '$method_name' " .
                   "because there is a local version of '$method_name'";
    $self->get_override_method_modifiers_map->{$method_name} = $method;
}

sub has_override_method_modifier {
    my ($self, $method_name) = @_;
    # NOTE:
    # for now we assume that if it exists,..
    # it has at least one modifier in it
    (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0;
}

sub get_override_method_modifier {
    my ($self, $method_name) = @_;
    $self->get_override_method_modifiers_map->{$method_name};
}

## general list accessor ...

sub get_method_modifier_list {
    my ($self, $modifier_type) = @_;
    my $accessor = "get_${modifier_type}_method_modifiers_map";
    keys %{$self->$accessor};
}

## ------------------------------------------------------------------
## subroles

__PACKAGE__->meta->add_attribute('roles' => (
    reader  => 'get_roles',
    default => sub { [] }
));

sub add_role {
    my ($self, $role) = @_;
    (blessed($role) && $role->isa('Moose::Meta::Role'))
        || confess "Roles must be instances of Moose::Meta::Role";
    push @{$self->get_roles} => $role;
}

sub calculate_all_roles {
    my $self = shift;
    my %seen;
    grep {
        !$seen{$_->name}++
    } ($self, map {
                  $_->calculate_all_roles
              } @{ $self->get_roles });
}

sub does_role {
    my ($self, $role_name) = @_;
    (defined $role_name)
        || confess "You must supply a role name to look for";
    # if we are it,.. then return true
    return 1 if $role_name eq $self->name;
    # otherwise.. check our children
    foreach my $role (@{$self->get_roles}) {
        return 1 if $role->does_role($role_name);
    }
    return 0;
}

## ------------------------------------------------------------------
## methods

sub method_metaclass { 'Moose::Meta::Role::Method' }

sub get_method_map {
    my $self = shift;
    my $map  = {};

    my $role_name        = $self->name;
    my $method_metaclass = $self->method_metaclass;

    foreach my $symbol ($self->list_all_package_symbols('CODE')) {

        my $code = $self->get_package_symbol('&' . $symbol);

        my ($pkg, $name) = Class::MOP::get_code_info($code);

        if ($pkg->can('meta')
            # NOTE:
            # we don't know what ->meta we are calling
            # here, so we need to be careful cause it
            # just might blow up at us, or just complain
            # loudly (in the case of Curses.pm) so we
            # just be a little overly cautious here.
            # - SL
            && eval { no warnings; blessed($pkg->meta) }
            && $pkg->meta->isa('Moose::Meta::Role')) {
            my $role = $pkg->meta->name;
            next unless $self->does_role($role);
        }
        else {
            next if ($pkg  || '') ne $role_name &&
                    ($name || '') ne '__ANON__';
        }

        $map->{$symbol} = $method_metaclass->wrap($code);
    }

    return $map;    
}

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

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

sub find_method_by_name { (shift)->get_method(@_) }

sub get_method_list {
    my $self = shift;
    grep { !/^meta$/ } keys %{$self->get_method_map};
}

sub alias_method {
    my ($self, $method_name, $method) = @_;
    (defined $method_name && $method_name)
        || confess "You must define a method name";

    my $body = (blessed($method) ? $method->body : $method);
    ('CODE' eq (reftype($body) || ''))
        || confess "Your code block must be a CODE reference";

    $self->add_package_symbol("&${method_name}" => $body);
}

#sub reset_package_cache_flag  { () }
#sub update_package_cache_flag { () }

## ------------------------------------------------------------------
## role construction
## ------------------------------------------------------------------

sub apply {
    my ($self, $other, @args) = @_;

    (blessed($other))
        || confess "You must pass in an blessed instance";
        
    if ($other->isa('Moose::Meta::Role')) {
        require Moose::Meta::Role::Application::ToRole;
        return Moose::Meta::Role::Application::ToRole->new->apply($self, $other, @args);
    }
    elsif ($other->isa('Moose::Meta::Class')) {
        require Moose::Meta::Role::Application::ToClass;
        return Moose::Meta::Role::Application::ToClass->new->apply($self, $other, @args);
    }  
    else {
        require Moose::Meta::Role::Application::ToInstance;
        return Moose::Meta::Role::Application::ToInstance->new->apply($self, $other, @args);        
    }  
}

sub combine {
    my ($class, @roles) = @_;
    
    require Moose::Meta::Role::Application::RoleSummation;
    require Moose::Meta::Role::Composite;    
    
    my $c = Moose::Meta::Role::Composite->new(roles => \@roles);
    Moose::Meta::Role::Application::RoleSummation->new->apply($c);
    return $c;
}

#####################################################################
## NOTE:
## This is Moose::Meta::Role as defined by Moose (plus the use of 
## MooseX::AttributeHelpers module). It is here as a reference to 
## make it easier to see what is happening above with all the meta
## programming. - SL
#####################################################################
#
# has 'roles' => (
#     metaclass => 'Collection::Array',
#     reader    => 'get_roles',
#     isa       => 'ArrayRef[Moose::Meta::Roles]',
#     default   => sub { [] },
#     provides  => {
#         'push' => 'add_role',
#     }
# );
# 
# has 'excluded_roles_map' => (
#     metaclass => 'Collection::Hash',
#     reader    => 'get_excluded_roles_map',
#     isa       => 'HashRef[Str]',
#     provides  => {
#         # Not exactly set, cause it sets multiple
#         'set'    => 'add_excluded_roles',
#         'keys'   => 'get_excluded_roles_list',
#         'exists' => 'excludes_role',
#     }
# );
# 
# has 'attribute_map' => (
#     metaclass => 'Collection::Hash',
#     reader    => 'get_attribute_map',
#     isa       => 'HashRef[Str]',    
#     provides => {
#         # 'set'  => 'add_attribute' # has some special crap in it
#         'get'    => 'get_attribute',
#         'keys'   => 'get_attribute_list',
#         'exists' => 'has_attribute',
#         # Not exactly delete, cause it sets multiple
#         'delete' => 'remove_attribute',    
#     }
# );
# 
# has 'required_methods' => (
#     metaclass => 'Collection::Hash',
#     reader    => 'get_required_methods_map',
#     isa       => 'HashRef[Str]',
#     provides  => {    
#         # not exactly set, or delete since it works for multiple 
#         'set'    => 'add_required_methods',
#         'delete' => 'remove_required_methods',
#         'keys'   => 'get_required_method_list',
#         'exists' => 'requires_method',    
#     }
# );
# 
# # the before, around and after modifiers are 
# # HASH keyed by method-name, with ARRAY of 
# # CODE refs to apply in that order
# 
# has 'before_method_modifiers' => (
#     metaclass => 'Collection::Hash',    
#     reader    => 'get_before_method_modifiers_map',
#     isa       => 'HashRef[ArrayRef[CodeRef]]',
#     provides  => {
#         'keys'   => 'get_before_method_modifiers',
#         'exists' => 'has_before_method_modifiers',   
#         # This actually makes sure there is an 
#         # ARRAY at the given key, and pushed onto
#         # it. It also checks for duplicates as well
#         # 'add'  => 'add_before_method_modifier'     
#     }    
# );
# 
# has 'after_method_modifiers' => (
#     metaclass => 'Collection::Hash',    
#     reader    =>'get_after_method_modifiers_map',
#     isa       => 'HashRef[ArrayRef[CodeRef]]',
#     provides  => {
#         'keys'   => 'get_after_method_modifiers',
#         'exists' => 'has_after_method_modifiers', 
#         # This actually makes sure there is an 
#         # ARRAY at the given key, and pushed onto
#         # it. It also checks for duplicates as well          
#         # 'add'  => 'add_after_method_modifier'     
#     }    
# );
#     
# has 'around_method_modifiers' => (
#     metaclass => 'Collection::Hash',    
#     reader    =>'get_around_method_modifiers_map',
#     isa       => 'HashRef[ArrayRef[CodeRef]]',
#     provides  => {
#         'keys'   => 'get_around_method_modifiers',
#         'exists' => 'has_around_method_modifiers',   
#         # This actually makes sure there is an 
#         # ARRAY at the given key, and pushed onto
#         # it. It also checks for duplicates as well        
#         # 'add'  => 'add_around_method_modifier'     
#     }    
# );
# 
# # override is similar to the other modifiers
# # except that it is not an ARRAY of code refs
# # but instead just a single name->code mapping
#     
# has 'override_method_modifiers' => (
#     metaclass => 'Collection::Hash',    
#     reader    =>'get_override_method_modifiers_map',
#     isa       => 'HashRef[CodeRef]',   
#     provides  => {
#         'keys'   => 'get_override_method_modifier',
#         'exists' => 'has_override_method_modifier',   
#         'add'    => 'add_override_method_modifier', # checks for local method ..     
#     }
# );
#     
#####################################################################


1;

__END__

=pod

=head1 NAME

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

=head1 DESCRIPTION

Please see L<Moose::Role> for more information about roles.
For the most part, this has no user-serviceable parts inside
this module. It's API is still subject to some change (although
probably not that much really).

=head1 METHODS

=over 4

=item B<meta>

=item B<new>

=item B<apply>

=item B<combine>

=back

=over 4

=item B<name>

=item B<version>

=item B<role_meta>

=back

=over 4

=item B<get_roles>

=item B<add_role>

=item B<does_role>

=back

=over 4

=item B<add_excluded_roles>

=item B<excludes_role>

=item B<get_excluded_roles_list>

=item B<get_excluded_roles_map>

=item B<calculate_all_roles>

=back

=over 4

=item B<method_metaclass>

=item B<find_method_by_name>

=item B<get_method>

=item B<has_method>

=item B<alias_method>

=item B<get_method_list>

=item B<get_method_map>

=item B<update_package_cache_flag>

=item B<reset_package_cache_flag>

=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_required_methods>

=item B<remove_required_methods>

=item B<get_required_method_list>

=item B<get_required_methods_map>

=item B<requires_method>

=back

=over 4

=item B<add_after_method_modifier>

=item B<add_around_method_modifier>

=item B<add_before_method_modifier>

=item B<add_override_method_modifier>

=over 4

=back

=item B<has_after_method_modifiers>

=item B<has_around_method_modifiers>

=item B<has_before_method_modifiers>

=item B<has_override_method_modifier>

=over 4

=back

=item B<get_after_method_modifiers>

=item B<get_around_method_modifiers>

=item B<get_before_method_modifiers>

=item B<get_method_modifier_list>

=over 4

=back

=item B<get_override_method_modifier>

=item B<get_after_method_modifiers_map>

=item B<get_around_method_modifiers_map>

=item B<get_before_method_modifiers_map>

=item B<get_override_method_modifiers_map>

=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, 2007 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
Commit	Line	Data
e185c027	1
	2	package Moose::Meta::Role;
	3
	4	use strict;
	5	use warnings;
	6	use metaclass;
	7
fb1e11d5	8	use Sub::Name 'subname';
bdabd620	9	use Carp 'confess';
fb1e11d5	10	use Scalar::Util 'blessed', 'reftype';
bdabd620	11
fb1e11d5	12	our $VERSION = '0.12';
d44714be	13	our $AUTHORITY = 'cpan:STEVAN';
e185c027	14
8ee73eeb	15	use Moose::Meta::Class;
39b3bc94	16	use Moose::Meta::Role::Method;
d67145ed	17	use Moose::Meta::Role::Method::Required;
8ee73eeb	18
68efb014	19	use base 'Class::MOP::Module';
80572233	20
fb1e11d5	21	## ------------------------------------------------------------------
	22	## NOTE:
	23	## I normally don't do this, but I am doing
	24	## a whole bunch of meta-programmin in this
	25	## module, so it just makes sense. For a clearer
	26	## picture of what is going on in the next
	27	## several lines of code, look at the really
	28	## big comment at the end of this file (right
	29	## before the POD).
	30	## - SL
	31	## ------------------------------------------------------------------
80572233	32
21716c07	33	my $META = __PACKAGE__->meta;
	34
	35	## ------------------------------------------------------------------
	36	## attributes ...
e185c027	37
21716c07	38	# NOTE:
21716c07	39	# since roles are lazy, we hold all the attributes
fb1e11d5	40	# of the individual role in 'statis' until which
	41	# time when it is applied to a class. This means
	42	# keeping a lot of things in hash maps, so we are
21716c07	43	# using a little of that meta-programmin' magic
fb1e11d5	44	# here an saving lots of extra typin. And since
	45	# many of these attributes above require similar
	46	# functionality to support them, so we again use
	47	# the wonders of meta-programmin' to deliver a
21716c07	48	# very compact solution to this normally verbose
	49	# problem.
	50	# - SL
	51
	52	foreach my $action (
fb1e11d5	53	{
	54	name => 'excluded_roles_map',
	55	attr_reader => 'get_excluded_roles_map' ,
21716c07	56	methods => {
fb1e11d5	57	add => 'add_excluded_roles',
	58	get_list => 'get_excluded_roles_list',
	59	existence => 'excludes_role',
21716c07	60	}
21716c07	61	},
fb1e11d5	62	{
fb1e11d5	63	name => 'required_methods',
21716c07	64	attr_reader => 'get_required_methods_map',
21716c07	65	methods => {
fb1e11d5	66	add => 'add_required_methods',
21716c07	67	remove => 'remove_required_methods',
	68	get_list => 'get_required_method_list',
	69	existence => 'requires_method',
	70	}
	71	},
	72	{
fb1e11d5	73	name => 'attribute_map',
21716c07	74	attr_reader => 'get_attribute_map',
	75	methods => {
	76	get => 'get_attribute',
	77	get_list => 'get_attribute_list',
	78	existence => 'has_attribute',
	79	remove => 'remove_attribute',
	80	}
	81	}
	82	) {
fb1e11d5	83
21716c07	84	my $attr_reader = $action->{attr_reader};
21716c07	85	my $methods = $action->{methods};
fb1e11d5	86
	87	# create the attribute
	88	$META->add_attribute($action->{name} => (
	89	reader => $attr_reader,
	90	default => sub { {} }
	91	));
	92
	93	# create some helper methods
21716c07	94	$META->add_method($methods->{add} => sub {
21716c07	95	my ($self, @values) = @_;
fb1e11d5	96	$self->$attr_reader->{$_} = undef foreach @values;
21716c07	97	}) if exists $methods->{add};
fb1e11d5	98
21716c07	99	$META->add_method($methods->{get_list} => sub {
21716c07	100	my ($self) = @_;
fb1e11d5	101	keys %{$self->$attr_reader};
	102	}) if exists $methods->{get_list};
	103
21716c07	104	$META->add_method($methods->{get} => sub {
21716c07	105	my ($self, $name) = @_;
fb1e11d5	106	$self->$attr_reader->{$name}
	107	}) if exists $methods->{get};
	108
21716c07	109	$META->add_method($methods->{existence} => sub {
21716c07	110	my ($self, $name) = @_;
fb1e11d5	111	exists $self->$attr_reader->{$name} ? 1 : 0;
	112	}) if exists $methods->{existence};
	113
21716c07	114	$META->add_method($methods->{remove} => sub {
	115	my ($self, @values) = @_;
	116	delete $self->$attr_reader->{$_} foreach @values;
fb1e11d5	117	}) if exists $methods->{remove};
21716c07	118	}
d79e62fd	119
21716c07	120	## some things don't always fit, so they go here ...
80572233	121
21716c07	122	sub add_attribute {
	123	my $self = shift;
	124	my $name = shift;
	125	my $attr_desc;
	126	if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
	127	$attr_desc = $_[0];
	128	}
	129	else {
	130	$attr_desc = { @_ };
	131	}
	132	$self->get_attribute_map->{$name} = $attr_desc;
	133	}
e185c027	134
bca01282	135	# DEPRECATED
	136	# sub _clean_up_required_methods {
	137	# my $self = shift;
	138	# foreach my $method ($self->get_required_method_list) {
	139	# $self->remove_required_methods($method)
	140	# if $self->has_method($method);
	141	# }
	142	# }
1331430a	143
21716c07	144	## ------------------------------------------------------------------
	145	## method modifiers
	146
21716c07	147	# NOTE:
fb1e11d5	148	# the before/around/after method modifiers are
21716c07	149	# stored by name, but there can be many methods
	150	# then associated with that name. So again we have
	151	# lots of similar functionality, so we can do some
	152	# meta-programmin' and save some time.
	153	# - SL
	154
	155	foreach my $modifier_type (qw[ before around after ]) {
fb1e11d5	156
fb1e11d5	157	my $attr_reader = "get_${modifier_type}_method_modifiers_map";
21716c07	158
fb1e11d5	159	# create the attribute ...
	160	$META->add_attribute("${modifier_type}_method_modifiers" => (
	161	reader => $attr_reader,
	162	default => sub { {} }
	163	));
	164
	165	# and some helper methods ...
21716c07	166	$META->add_method("get_${modifier_type}_method_modifiers" => sub {
21716c07	167	my ($self, $method_name) = @_;
fb1e11d5	168	#return () unless exists $self->$attr_reader->{$method_name};
21716c07	169	@{$self->$attr_reader->{$method_name}};
21716c07	170	});
fb1e11d5	171
21716c07	172	$META->add_method("has_${modifier_type}_method_modifiers" => sub {
	173	my ($self, $method_name) = @_;
	174	# NOTE:
fb1e11d5	175	# for now we assume that if it exists,..
21716c07	176	# it has at least one modifier in it
21716c07	177	(exists $self->$attr_reader->{$method_name}) ? 1 : 0;
fb1e11d5	178	});
fb1e11d5	179
21716c07	180	$META->add_method("add_${modifier_type}_method_modifier" => sub {
21716c07	181	my ($self, $method_name, $method) = @_;
fb1e11d5	182
fb1e11d5	183	$self->$attr_reader->{$method_name} = []
21716c07	184	unless exists $self->$attr_reader->{$method_name};
fb1e11d5	185
21716c07	186	my $modifiers = $self->$attr_reader->{$method_name};
fb1e11d5	187
21716c07	188	# NOTE:
fb1e11d5	189	# check to see that we aren't adding the
fb1e11d5	190	# same code twice. We err in favor of the
21716c07	191	# first on here, this may not be as expected
	192	foreach my $modifier (@{$modifiers}) {
	193	return if $modifier == $method;
	194	}
fb1e11d5	195
21716c07	196	push @{$modifiers} => $method;
21716c07	197	});
fb1e11d5	198
21716c07	199	}
1331430a	200
21716c07	201	## ------------------------------------------------------------------
21716c07	202	## override method mofidiers
0558683c	203
fb1e11d5	204	$META->add_attribute('override_method_modifiers' => (
	205	reader => 'get_override_method_modifiers_map',
	206	default => sub { {} }
	207	));
	208
21716c07	209	# NOTE:
fb1e11d5	210	# these are a little different because there
21716c07	211	# can only be one per name, whereas the other
	212	# method modifiers can have multiples.
	213	# - SL
0558683c	214
21716c07	215	sub add_override_method_modifier {
	216	my ($self, $method_name, $method) = @_;
	217	(!$self->has_method($method_name))
fb1e11d5	218	\|\| confess "Cannot add an override of method '$method_name' " .
21716c07	219	"because there is a local version of '$method_name'";
fb1e11d5	220	$self->get_override_method_modifiers_map->{$method_name} = $method;
21716c07	221	}
0558683c	222
21716c07	223	sub has_override_method_modifier {
	224	my ($self, $method_name) = @_;
	225	# NOTE:
fb1e11d5	226	# for now we assume that if it exists,..
21716c07	227	# it has at least one modifier in it
fb1e11d5	228	(exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0;
21716c07	229	}
0558683c	230
21716c07	231	sub get_override_method_modifier {
21716c07	232	my ($self, $method_name) = @_;
fb1e11d5	233	$self->get_override_method_modifiers_map->{$method_name};
21716c07	234	}
0558683c	235
21716c07	236	## general list accessor ...
80572233	237
21716c07	238	sub get_method_modifier_list {
21716c07	239	my ($self, $modifier_type) = @_;
fb1e11d5	240	my $accessor = "get_${modifier_type}_method_modifiers_map";
21716c07	241	keys %{$self->$accessor};
21716c07	242	}
e185c027	243
21716c07	244	## ------------------------------------------------------------------
80572233	245	## subroles
80572233	246
21716c07	247	__PACKAGE__->meta->add_attribute('roles' => (
	248	reader => 'get_roles',
	249	default => sub { [] }
	250	));
	251
80572233	252	sub add_role {
	253	my ($self, $role) = @_;
	254	(blessed($role) && $role->isa('Moose::Meta::Role'))
	255	\|\| confess "Roles must be instances of Moose::Meta::Role";
	256	push @{$self->get_roles} => $role;
	257	}
	258
b8aeb4dc	259	sub calculate_all_roles {
	260	my $self = shift;
	261	my %seen;
fb1e11d5	262	grep {
	263	!$seen{$_->name}++
	264	} ($self, map {
	265	$_->calculate_all_roles
	266	} @{ $self->get_roles });
b8aeb4dc	267	}
b8aeb4dc	268
80572233	269	sub does_role {
	270	my ($self, $role_name) = @_;
	271	(defined $role_name)
	272	\|\| confess "You must supply a role name to look for";
bdabd620	273	# if we are it,.. then return true
	274	return 1 if $role_name eq $self->name;
	275	# otherwise.. check our children
80572233	276	foreach my $role (@{$self->get_roles}) {
bdabd620	277	return 1 if $role->does_role($role_name);
80572233	278	}
	279	return 0;
	280	}
	281
21716c07	282	## ------------------------------------------------------------------
fb1e11d5	283	## methods
1331430a	284
21716c07	285	sub method_metaclass { 'Moose::Meta::Role::Method' }
80572233	286
fb1e11d5	287	sub get_method_map {
093b12c2	288	my $self = shift;
fb1e11d5	289	my $map = {};
	290
	291	my $role_name = $self->name;
	292	my $method_metaclass = $self->method_metaclass;
	293
	294	foreach my $symbol ($self->list_all_package_symbols('CODE')) {
	295
	296	my $code = $self->get_package_symbol('&' . $symbol);
	297
	298	my ($pkg, $name) = Class::MOP::get_code_info($code);
	299
	300	if ($pkg->can('meta')
	301	# NOTE:
	302	# we don't know what ->meta we are calling
	303	# here, so we need to be careful cause it
	304	# just might blow up at us, or just complain
	305	# loudly (in the case of Curses.pm) so we
	306	# just be a little overly cautious here.
	307	# - SL
	308	&& eval { no warnings; blessed($pkg->meta) }
	309	&& $pkg->meta->isa('Moose::Meta::Role')) {
	310	my $role = $pkg->meta->name;
	311	next unless $self->does_role($role);
	312	}
	313	else {
	314	next if ($pkg \|\| '') ne $role_name &&
	315	($name \|\| '') ne '__ANON__';
	316	}
	317
	318	$map->{$symbol} = $method_metaclass->wrap($code);
	319	}
	320
	321	return $map;
093b12c2	322	}
093b12c2	323
fb1e11d5	324	sub get_method {
	325	my ($self, $name) = @_;
	326	$self->get_method_map->{$name}
	327	}
40e89659	328
fb1e11d5	329	sub has_method {
	330	my ($self, $name) = @_;
	331	exists $self->get_method_map->{$name} ? 1 : 0
e185c027	332	}
e185c027	333
1db8ecc7	334	sub find_method_by_name { (shift)->get_method(@_) }
093b12c2	335
fb1e11d5	336	sub get_method_list {
	337	my $self = shift;
	338	grep { !/^meta$/ } keys %{$self->get_method_map};
	339	}
	340
	341	sub alias_method {
	342	my ($self, $method_name, $method) = @_;
	343	(defined $method_name && $method_name)
	344	\|\| confess "You must define a method name";
	345
	346	my $body = (blessed($method) ? $method->body : $method);
	347	('CODE' eq (reftype($body) \|\| ''))
	348	\|\| confess "Your code block must be a CODE reference";
	349
	350	$self->add_package_symbol("&${method_name}" => $body);
	351	}
	352
1c9db35c	353	#sub reset_package_cache_flag { () }
1c9db35c	354	#sub update_package_cache_flag { () }
fb1e11d5	355
21716c07	356	## ------------------------------------------------------------------
fb1e11d5	357	## role construction
21716c07	358	## ------------------------------------------------------------------
e185c027	359
21716c07	360	sub apply {
bca01282	361	my ($self, $other, @args) = @_;
	362
	363	(blessed($other))
	364	\|\| confess "You must pass in an blessed instance";
	365
1c9db35c	366	if ($other->isa('Moose::Meta::Role')) {
1c9db35c	367	require Moose::Meta::Role::Application::ToRole;
bca01282	368	return Moose::Meta::Role::Application::ToRole->new->apply($self, $other, @args);
1c9db35c	369	}
	370	elsif ($other->isa('Moose::Meta::Class')) {
	371	require Moose::Meta::Role::Application::ToClass;
bca01282	372	return Moose::Meta::Role::Application::ToClass->new->apply($self, $other, @args);
1c9db35c	373	}
	374	else {
	375	require Moose::Meta::Role::Application::ToInstance;
bca01282	376	return Moose::Meta::Role::Application::ToInstance->new->apply($self, $other, @args);
1c9db35c	377	}
0558683c	378	}
0558683c	379
21716c07	380	sub combine {
	381	my ($class, @roles) = @_;
	382
fb1e11d5	383	require Moose::Meta::Role::Application::RoleSummation;
fb1e11d5	384	require Moose::Meta::Role::Composite;
21716c07	385
fb1e11d5	386	my $c = Moose::Meta::Role::Composite->new(roles => \@roles);
	387	Moose::Meta::Role::Application::RoleSummation->new->apply($c);
	388	return $c;
0558683c	389	}
0558683c	390
fb1e11d5	391	#####################################################################
	392	## NOTE:
	393	## This is Moose::Meta::Role as defined by Moose (plus the use of
	394	## MooseX::AttributeHelpers module). It is here as a reference to
	395	## make it easier to see what is happening above with all the meta
	396	## programming. - SL
	397	#####################################################################
	398	#
	399	# has 'roles' => (
	400	# metaclass => 'Collection::Array',
	401	# reader => 'get_roles',
	402	# isa => 'ArrayRef[Moose::Meta::Roles]',
	403	# default => sub { [] },
	404	# provides => {
	405	# 'push' => 'add_role',
	406	# }
	407	# );
	408	#
	409	# has 'excluded_roles_map' => (
	410	# metaclass => 'Collection::Hash',
	411	# reader => 'get_excluded_roles_map',
	412	# isa => 'HashRef[Str]',
	413	# provides => {
	414	# # Not exactly set, cause it sets multiple
	415	# 'set' => 'add_excluded_roles',
	416	# 'keys' => 'get_excluded_roles_list',
	417	# 'exists' => 'excludes_role',
	418	# }
	419	# );
	420	#
	421	# has 'attribute_map' => (
	422	# metaclass => 'Collection::Hash',
	423	# reader => 'get_attribute_map',
	424	# isa => 'HashRef[Str]',
	425	# provides => {
	426	# # 'set' => 'add_attribute' # has some special crap in it
	427	# 'get' => 'get_attribute',
	428	# 'keys' => 'get_attribute_list',
	429	# 'exists' => 'has_attribute',
	430	# # Not exactly delete, cause it sets multiple
	431	# 'delete' => 'remove_attribute',
	432	# }
	433	# );
	434	#
	435	# has 'required_methods' => (
	436	# metaclass => 'Collection::Hash',
	437	# reader => 'get_required_methods_map',
	438	# isa => 'HashRef[Str]',
	439	# provides => {
	440	# # not exactly set, or delete since it works for multiple
	441	# 'set' => 'add_required_methods',
	442	# 'delete' => 'remove_required_methods',
	443	# 'keys' => 'get_required_method_list',
	444	# 'exists' => 'requires_method',
	445	# }
	446	# );
	447	#
	448	# # the before, around and after modifiers are
	449	# # HASH keyed by method-name, with ARRAY of
	450	# # CODE refs to apply in that order
	451	#
	452	# has 'before_method_modifiers' => (
	453	# metaclass => 'Collection::Hash',
	454	# reader => 'get_before_method_modifiers_map',
455	# isa => 'HashRef[ArrayRef[CodeRef]]',
456	# provides => {
457	# 'keys' => 'get_before_method_modifiers',
458	# 'exists' => 'has_before_method_modifiers',
459	# # This actually makes sure there is an
460	# # ARRAY at the given key, and pushed onto
461	# # it. It also checks for duplicates as well
462	# # 'add' => 'add_before_method_modifier'
463	# }
464	# );
465	#
466	# has 'after_method_modifiers' => (
467	# metaclass => 'Collection::Hash',
468	# reader =>'get_after_method_modifiers_map',
469	# isa => 'HashRef[ArrayRef[CodeRef]]',
470	# provides => {
471	# 'keys' => 'get_after_method_modifiers',
472	# 'exists' => 'has_after_method_modifiers',
473	# # This actually makes sure there is an
474	# # ARRAY at the given key, and pushed onto
475	# # it. It also checks for duplicates as well
476	# # 'add' => 'add_after_method_modifier'
477	# }
478	# );
479	#
480	# has 'around_method_modifiers' => (
481	# metaclass => 'Collection::Hash',
482	# reader =>'get_around_method_modifiers_map',
483	# isa => 'HashRef[ArrayRef[CodeRef]]',
484	# provides => {
485	# 'keys' => 'get_around_method_modifiers',
486	# 'exists' => 'has_around_method_modifiers',
487	# # This actually makes sure there is an
488	# # ARRAY at the given key, and pushed onto
489	# # it. It also checks for duplicates as well
490	# # 'add' => 'add_around_method_modifier'
491	# }
492	# );
493	#
494	# # override is similar to the other modifiers
495	# # except that it is not an ARRAY of code refs
496	# # but instead just a single name->code mapping
497	#
498	# has 'override_method_modifiers' => (
499	# metaclass => 'Collection::Hash',
500	# reader =>'get_override_method_modifiers_map',
501	# isa => 'HashRef[CodeRef]',
502	# provides => {
503	# 'keys' => 'get_override_method_modifier',
504	# 'exists' => 'has_override_method_modifier',
505	# 'add' => 'add_override_method_modifier', # checks for local method ..
506	# }
507	# );
508	#
509	#####################################################################
510
511
e185c027	512	1;
	513
	514	__END__
	515
	516	=pod
	517
	518	=head1 NAME
	519
	520	Moose::Meta::Role - The Moose Role metaclass
	521
	522	=head1 DESCRIPTION
	523
fb1e11d5	524	Please see L<Moose::Role> for more information about roles.
d44714be	525	For the most part, this has no user-serviceable parts inside
fb1e11d5	526	this module. It's API is still subject to some change (although
02a0fb52	527	probably not that much really).
79592a54	528
e185c027	529	=head1 METHODS
	530
	531	=over 4
	532
	533	=item B<meta>
	534
	535	=item B<new>
	536
78cd1d3b	537	=item B<apply>
78cd1d3b	538
db1ab48d	539	=item B<combine>
db1ab48d	540
e185c027	541	=back
	542
	543	=over 4
	544
	545	=item B<name>
	546
	547	=item B<version>
	548
	549	=item B<role_meta>
	550
	551	=back
	552
	553	=over 4
	554
80572233	555	=item B<get_roles>
	556
	557	=item B<add_role>
	558
	559	=item B<does_role>
	560
	561	=back
	562
	563	=over 4
	564
d79e62fd	565	=item B<add_excluded_roles>
	566
	567	=item B<excludes_role>
	568
	569	=item B<get_excluded_roles_list>
	570
	571	=item B<get_excluded_roles_map>
	572
2b14ac61	573	=item B<calculate_all_roles>
2b14ac61	574
d79e62fd	575	=back
	576
	577	=over 4
	578
68efb014	579	=item B<method_metaclass>
68efb014	580
be4427d0	581	=item B<find_method_by_name>
be4427d0	582
e185c027	583	=item B<get_method>
	584
	585	=item B<has_method>
	586
bdabd620	587	=item B<alias_method>
bdabd620	588
e185c027	589	=item B<get_method_list>
e185c027	590
093b12c2	591	=item B<get_method_map>
093b12c2	592
638853cb	593	=item B<update_package_cache_flag>
638853cb	594
53dd42d8	595	=item B<reset_package_cache_flag>
53dd42d8	596
e185c027	597	=back
	598
	599	=over 4
	600
	601	=item B<add_attribute>
	602
	603	=item B<has_attribute>
	604
	605	=item B<get_attribute>
	606
	607	=item B<get_attribute_list>
	608
	609	=item B<get_attribute_map>
	610
	611	=item B<remove_attribute>
	612
	613	=back
	614
	615	=over 4
	616
1331430a	617	=item B<add_required_methods>
1331430a	618
38f1204c	619	=item B<remove_required_methods>
38f1204c	620
1331430a	621	=item B<get_required_method_list>
	622
	623	=item B<get_required_methods_map>
	624
	625	=item B<requires_method>
	626
	627	=back
	628
0558683c	629	=over 4
	630
	631	=item B<add_after_method_modifier>
	632
	633	=item B<add_around_method_modifier>
	634
	635	=item B<add_before_method_modifier>
	636
	637	=item B<add_override_method_modifier>
	638
	639	=over 4
	640
	641	=back
	642
	643	=item B<has_after_method_modifiers>
	644
	645	=item B<has_around_method_modifiers>
	646
	647	=item B<has_before_method_modifiers>
	648
	649	=item B<has_override_method_modifier>
	650
	651	=over 4
	652
	653	=back
	654
	655	=item B<get_after_method_modifiers>
	656
	657	=item B<get_around_method_modifiers>
	658
	659	=item B<get_before_method_modifiers>
	660
	661	=item B<get_method_modifier_list>
	662
	663	=over 4
	664
	665	=back
	666
	667	=item B<get_override_method_modifier>
	668
	669	=item B<get_after_method_modifiers_map>
	670
	671	=item B<get_around_method_modifiers_map>
	672
	673	=item B<get_before_method_modifiers_map>
	674
	675	=item B<get_override_method_modifiers_map>
	676
	677	=back
	678
e185c027	679	=head1 BUGS
e185c027	680
fb1e11d5	681	All complex software has bugs lurking in it, and this module is no
e185c027	682	exception. If you find a bug please either email me, or add the bug
	683	to cpan-RT.
	684
	685	=head1 AUTHOR
	686
	687	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	688
	689	=head1 COPYRIGHT AND LICENSE
	690
b77fdbed	691	Copyright 2006, 2007 by Infinity Interactive, Inc.
e185c027	692
	693	L<http://www.iinteractive.com>
	694
	695	This library is free software; you can redistribute it and/or modify
fb1e11d5	696	it under the same terms as Perl itself.
e185c027	697
b8aeb4dc	698	=cut