X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FRole.pm;h=48e40b7be34f3530aa30a82a8be3d27923c8086a;hb=8b3c8a92f073be4d107f7c709bcb36d048eff1d4;hp=9fe4461842ff3e792e6ee477ed518cd95ac9a3de;hpb=68117c4523857f230ceac0f36db4187a951d315c;p=gitmo%2FMoose.git diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 9fe4461..48e40b7 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -1,296 +1,300 @@ - package Moose::Role; - use strict; use warnings; -use Scalar::Util (); -use Carp 'confess'; -use Sub::Name 'subname'; +use Scalar::Util 'blessed'; +use Carp 'croak'; +use Class::Load 'is_class_loaded'; use Sub::Exporter; -our $VERSION = '0.05'; +use Moose (); +use Moose::Util (); +use Moose::Exporter; use Moose::Meta::Role; use Moose::Util::TypeConstraints; -{ - my ( $CALLER, %METAS ); - - sub _find_meta { - my $role = $CALLER; - - return $METAS{$role} if exists $METAS{$role}; - - # make a subtype for each Moose class - subtype $role - => as 'Role' - => where { $_->does($role) } - unless find_type_constraint($role); - - my $meta; - if ($role->can('meta')) { - $meta = $role->meta(); - (blessed($meta) && $meta->isa('Moose::Meta::Role')) - || confess "Whoops, not møøsey enough"; - } - else { - $meta = Moose::Meta::Role->new(role_name => $role); - $meta->_role_meta->add_method('meta' => sub { $meta }) - } - - return $METAS{$role} = $meta; +sub extends { + croak "Roles do not support 'extends' (you can use 'with' to specialize a role)"; +} + +sub with { + Moose::Util::apply_all_roles( shift, @_ ); +} + +sub requires { + my $meta = shift; + croak "Must specify at least one method" unless @_; + $meta->add_required_methods(@_); +} + +sub excludes { + my $meta = shift; + croak "Must specify at least one role" unless @_; + $meta->add_excluded_roles(@_); +} + +sub has { + my $meta = shift; + my $name = shift; + croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1; + my %options = ( definition_context => Moose::Util::_caller_info(), @_ ); + my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ]; + $meta->add_attribute( $_, %options ) for @$attrs; +} + +sub _add_method_modifier { + my $type = shift; + my $meta = shift; + + if ( ref($_[0]) eq 'Regexp' ) { + croak "Roles do not currently support regex " + . " references for $type method modifiers"; } - - - my %exports = ( - extends => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::extends' => sub { - confess "Moose::Role does not currently support 'extends'" - }; - }, - with => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::with' => sub (@) { - my (@roles) = @_; - confess "Must specify at least one role" unless @roles; - Moose::_load_all_classes(@roles); - ($_->can('meta') && $_->meta->isa('Moose::Meta::Role')) - || confess "You can only consume roles, $_ is not a Moose role" - foreach @roles; - if (scalar @roles == 1) { - $roles[0]->meta->apply($meta); - } - else { - Moose::Meta::Role->combine( - map { $_->meta } @roles - )->apply($meta); - } - }; - }, - requires => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::requires' => sub (@) { - confess "Must specify at least one method" unless @_; - $meta->add_required_methods(@_); - }; - }, - excludes => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::excludes' => sub (@) { - confess "Must specify at least one role" unless @_; - $meta->add_excluded_roles(@_); - }; - }, - has => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::has' => sub ($;%) { - my ($name, %options) = @_; - $meta->add_attribute($name, %options) - }; - }, - before => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::before' => sub (@&) { - my $code = pop @_; - $meta->add_before_method_modifier($_, $code) for @_; - }; - }, - after => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::after' => sub (@&) { - my $code = pop @_; - $meta->add_after_method_modifier($_, $code) for @_; - }; - }, - around => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::around' => sub (@&) { - my $code = pop @_; - $meta->add_around_method_modifier($_, $code) for @_; - }; - }, - super => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::super' => sub {}; - }, - override => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::override' => sub ($&) { - my ($name, $code) = @_; - $meta->add_override_method_modifier($name, $code); - }; - }, - inner => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::inner' => sub { - confess "Moose::Role does not currently support 'inner'"; - }; - }, - augment => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::augment' => sub { - confess "Moose::Role does not currently support 'augment'"; - }; - }, - confess => sub { - return \&Carp::confess; - }, - blessed => sub { - return \&Scalar::Util::blessed; - } - ); - - my $exporter = Sub::Exporter::build_exporter({ - exports => \%exports, - groups => { - default => [':all'] - } - }); - - sub import { - $CALLER = caller(); - - strict->import; - warnings->import; - # we should never export to main - return if $CALLER eq 'main'; + Moose::Util::add_method_modifier($meta, $type, \@_); +} + +sub before { _add_method_modifier('before', @_) } + +sub after { _add_method_modifier('after', @_) } + +sub around { _add_method_modifier('around', @_) } + +# see Moose.pm for discussion +sub super { + return unless $Moose::SUPER_BODY; + $Moose::SUPER_BODY->(@Moose::SUPER_ARGS); +} + +sub override { + my $meta = shift; + my ( $name, $code ) = @_; + $meta->add_override_method_modifier( $name, $code ); +} + +sub inner { + croak "Roles cannot support 'inner'"; +} + +sub augment { + croak "Roles cannot support 'augment'"; +} + +Moose::Exporter->setup_import_methods( + with_meta => [ + qw( with requires excludes has before after around override ) + ], + as_is => [ + qw( extends super inner augment ), + \&Carp::confess, + \&Scalar::Util::blessed, + ], +); + +sub init_meta { + shift; + my %args = @_; + + my $role = $args{for_class}; + + unless ($role) { + require Moose; + Moose->throw_error("Cannot call init_meta without specifying a for_class"); + } + + my $metaclass = $args{metaclass} || "Moose::Meta::Role"; + my $meta_name = exists $args{meta_name} ? $args{meta_name} : 'meta'; + + Moose->throw_error("The Metaclass $metaclass must be loaded. (Perhaps you forgot to 'use $metaclass'?)") + unless is_class_loaded($metaclass); + + Moose->throw_error("The Metaclass $metaclass must be a subclass of Moose::Meta::Role.") + unless $metaclass->isa('Moose::Meta::Role'); + + # make a subtype for each Moose role + role_type $role unless find_type_constraint($role); + + my $meta; + if ( $meta = Class::MOP::get_metaclass_by_name($role) ) { + unless ( $meta->isa("Moose::Meta::Role") ) { + my $error_message = "$role already has a metaclass, but it does not inherit $metaclass ($meta)."; + if ( $meta->isa('Moose::Meta::Class') ) { + Moose->throw_error($error_message . ' You cannot make the same thing a role and a class. Remove either Moose or Moose::Role.'); + } else { + Moose->throw_error($error_message); + } + } + } + else { + $meta = $metaclass->initialize($role); + } - goto $exporter; - }; + if (defined $meta_name) { + # also check for inherited non moose 'meta' method? + my $existing = $meta->get_method($meta_name); + if ($existing && !$existing->isa('Class::MOP::Method::Meta')) { + Carp::cluck "Moose::Role is overwriting an existing method named " + . "$meta_name in role $role with a method " + . "which returns the class's metaclass. If this is " + . "actually what you want, you should remove the " + . "existing method, otherwise, you should rename or " + . "disable this generated method using the " + . "'-meta_name' option to 'use Moose::Role'."; + } + $meta->_add_meta_method($meta_name); + } + return $meta; } 1; +# ABSTRACT: The Moose Role + __END__ =pod -=head1 NAME - -Moose::Role - The Moose Role - =head1 SYNOPSIS package Eq; - use strict; - use warnings; - use Moose::Role; - + use Moose::Role; # automatically turns on strict and warnings + requires 'equal'; - - sub no_equal { + + sub no_equal { my ($self, $other) = @_; !$self->equal($other); } - + # ... then in your classes - + package Currency; - use strict; - use warnings; - use Moose; - + use Moose; # automatically turns on strict and warnings + with 'Eq'; - + sub equal { my ($self, $other) = @_; $self->as_float == $other->as_float; } + # ... and also + + package Comparator; + use Moose; + + has compare_to => ( + is => 'ro', + does => 'Eq', + handles => 'Eq', + ); + + # ... which allows + + my $currency1 = Currency->new(...); + my $currency2 = Currency->new(...); + Comparator->new(compare_to => $currency1)->equal($currency2); + =head1 DESCRIPTION -Role support in Moose is coming along quite well. It's best documentation -is still the the test suite, but it is fairly safe to assume Perl 6 style -behavior, and then either refer to the test suite, or ask questions on -#moose if something doesn't quite do what you expect. More complete -documentation is planned and will be included with the next official -(non-developer) release. +The concept of roles is documented in L. This document +serves as API documentation. =head1 EXPORTED FUNCTIONS -Currently Moose::Role supports all of the functions that L exports, -but differs slightly in how some items are handled (see L below -for details). +Moose::Role currently supports all of the functions that L exports, but +differs slightly in how some items are handled (see L below for +details). -Moose::Role also offers two role specific keyword exports: +Moose::Role also offers two role-specific keyword exports: =over 4 =item B -Roles can require that certain methods are implemented by any class which -C the role. +Roles can require that certain methods are implemented by any class which +C the role. + +Note that attribute accessors also count as methods for the purposes +of satisfying the requirements of a role. =item B Roles can C other roles, in effect saying "I can never be combined -with these C<@role_names>". This is a feature which should not be used -lightly. +with these C<@role_names>". This is a feature which should not be used +lightly. =back -=head1 CAVEATS +=head2 B -The role support now has only a few caveats. They are as follows: +Moose::Role offers a way to remove the keywords it exports, through the +C method. You simply have to say C at the bottom of +your code for this to work. -=over 4 +=head1 METACLASS -=item * +When you use Moose::Role, you can specify traits which will be applied to your +role metaclass: -Roles cannot use the C keyword, it will throw an exception for now. -The same is true of the C and C keywords (not sure those -really make sense for roles). All other Moose keywords will be I -so that they can be applied to the consuming class. + use Moose::Role -traits => 'My::Trait'; -=item * +This is very similar to the attribute traits feature. When you do +this, your class's C object will have the specified traits +applied to it. See L for more +details. -Role composition does it's best to B be order sensitive when it comes -to conflict resolution and requirements detection. However, it is order -sensitive when it comes to method modifiers. All before/around/after modifiers -are included whenever a role is composed into a class, and then are applied -in the order the roles are used. This too means that there is no conflict for -before/around/after modifiers as well. +=head1 APPLYING ROLES -In most cases, this will be a non issue, however it is something to keep in -mind when using method modifiers in a role. You should never assume any -ordering. +In addition to being applied to a class using the 'with' syntax (see +L) and using the L 'apply_all_roles' +method, roles may also be applied to an instance of a class using +L 'apply_all_roles' or the role's metaclass: -=item * + MyApp::Test::SomeRole->meta->apply( $instance ); -The C keyword currently only works with actual methods. A method -modifier (before/around/after and override) will not count as a fufillment -of the requirement, and neither will an autogenerated accessor for an attribute. +Doing this creates a new, mutable, anonymous subclass, applies the role to that, +and reblesses. In a debugger, for example, you will see class names of the +form C< Moose::Meta::Class::__ANON__::SERIAL::6 >, which means that doing a +'ref' on your instance may not return what you expect. See L for +'DOES'. -It is likely that the attribute accessors will eventually be allowed to fufill -those requirements, either that or we will introduce a C keyword -of some kind instead. This descision has not yet been finalized. +Additional params may be added to the new instance by providing +'rebless_params'. See L. -=back +=head1 CAVEATS -=head1 BUGS +Role support has only a few caveats: + +=over 4 -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. +=item * -=head1 AUTHOR +Roles cannot use the C keyword; it will throw an exception for now. +The same is true of the C and C keywords (not sure those +really make sense for roles). All other Moose keywords will be I +so that they can be applied to the consuming class. -Stevan Little Estevan@iinteractive.comE +=item * -Christian Hansen Echansen@cpan.orgE +Role composition does its best to B be order-sensitive when it comes to +conflict resolution and requirements detection. However, it is order-sensitive +when it comes to method modifiers. All before/around/after modifiers are +included whenever a role is composed into a class, and then applied in the order +in which the roles are used. This also means that there is no conflict for +before/around/after modifiers. -=head1 COPYRIGHT AND LICENSE +In most cases, this will be a non-issue; however, it is something to keep in +mind when using method modifiers in a role. You should never assume any +ordering. -Copyright 2006 by Infinity Interactive, Inc. +=back -L +=head1 BUGS -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut