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


package Moose::Meta::Role;

use strict;
use warnings;
use metaclass;

use Carp         'confess';
use Scalar::Util 'blessed';

our $VERSION   = '0.15';
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;

    my %all_code = $self->get_all_package_symbols('CODE');

    foreach my $symbol (keys %all_code) {
        my $code = $all_code{$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 {
            # NOTE:
            # in 5.10 constant.pm the constants show up 
            # as being in the right package, but in pre-5.10
            # they show up as constant::__ANON__ so we 
            # make an exception here to be sure that things
            # work as expected in both.
            # - SL
            unless ($pkg eq 'constant' && $name eq '__ANON__') {
                next if ($pkg  || '') ne $role_name ||
                        (($name || '') ne '__ANON__' && ($pkg  || '') ne $role_name);
            }            
        }
        
        $map->{$symbol} = $method_metaclass->wrap(
            $code,
            package_name => $role_name,
            name         => $name            
        );
    }

    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 ref($body))
        || confess "Your code block must be a CODE reference";

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

## ------------------------------------------------------------------
## 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(@args)->apply($self, $other);
    }
    elsif ($other->isa('Moose::Meta::Class')) {
        require Moose::Meta::Role::Application::ToClass;
        return Moose::Meta::Role::Application::ToClass->new(@args)->apply($self, $other);
    }  
    else {
        require Moose::Meta::Role::Application::ToInstance;
        return Moose::Meta::Role::Application::ToInstance->new(@args)->apply($self, $other);        
    }  
}

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