X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FRole.pm;h=e25117e0fe1c274968aafd737530089a3fc50ee2;hb=fc63d650f898bb025aa03d9b4aee10bb58beb081;hp=2e6b187e8197239f6adfde11d3ee0ce151f5649e;hpb=8542461239be5e9c44b6133c892da86b0108b9d1;p=gitmo%2FMoose.git diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 2e6b187..e25117e 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -5,171 +5,151 @@ use strict; use warnings; use Scalar::Util 'blessed'; -use Carp 'confess'; -use Sub::Name 'subname'; +use Carp 'croak'; +use Data::OptList; use Sub::Exporter; -our $VERSION = '0.07'; +our $VERSION = '0.70'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use Moose (); +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) } - => optimize_as { blessed($_[0]) && $_[0]->can('does') && $_[0]->does($role) } - unless find_type_constraint($role); - - my $meta; - if ($role->can('meta')) { - $meta = $role->meta(); - (blessed($meta) && $meta->isa('Moose::Meta::Role')) - || confess "You already have a &meta function, but it does not return a Moose::Meta::Role"; - } - else { - $meta = Moose::Meta::Role->initialize($role); - $meta->Moose::Meta::Class::add_method('meta' => sub { $meta }) - } - - return $METAS{$role} = $meta; +sub extends { + croak "Roles do not currently support 'extends'"; +} + +sub with { + Moose::Util::apply_all_roles( Moose::Meta::Role->initialize(shift), @_ ); +} + +sub requires { + my $meta = Moose::Meta::Role->initialize(shift); + croak "Must specify at least one method" unless @_; + $meta->add_required_methods(@_); +} + +sub excludes { + my $meta = Moose::Meta::Role->initialize(shift); + croak "Must specify at least one role" unless @_; + $meta->add_excluded_roles(@_); +} + +sub has { + my $meta = Moose::Meta::Role->initialize(shift); + my $name = shift; + croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1; + my %options = @_; + my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ]; + $meta->add_attribute( $_, %options ) for @$attrs; +} + +sub before { + my $meta = Moose::Meta::Role->initialize(shift); + my $code = pop @_; + + for (@_) { + croak "Roles do not currently support " + . ref($_) + . " references for before method modifiers" + if ref $_; + $meta->add_before_method_modifier( $_, $code ); + } +} + +sub after { + my $meta = Moose::Meta::Role->initialize(shift); + + my $code = pop @_; + for (@_) { + croak "Roles do not currently support " + . ref($_) + . " references for after method modifiers" + if ref $_; + $meta->add_after_method_modifier( $_, $code ); + } +} + +sub around { + my $meta = Moose::Meta::Role->initialize(shift); + my $code = pop @_; + for (@_) { + croak "Roles do not currently support " + . ref($_) + . " references for around method modifiers" + if ref $_; + $meta->add_around_method_modifier( $_, $code ); + } +} + +# see Moose.pm for discussion +sub super { + return unless $Moose::SUPER_BODY; + $Moose::SUPER_BODY->(@Moose::SUPER_ARGS); +} + +sub override { + my $meta = Moose::Meta::Role->initialize(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_caller => [ + qw( with requires excludes has before after around override make_immutable ) + ], + as_is => [ + qw( extends super inner augment ), + \&Carp::confess, + \&Scalar::Util::blessed, + ], +); + +sub init_meta { + shift; + my %args = @_; + + my $role = $args{for_class} + or Moose->throw_error("Cannot call init_meta without specifying a for_class"); + + my $metaclass = $args{metaclass} || "Moose::Meta::Role"; + + # make a subtype for each Moose class + role_type $role unless find_type_constraint($role); + + # FIXME copy from Moose.pm + my $meta; + if ($role->can('meta')) { + $meta = $role->meta(); + (blessed($meta) && $meta->isa('Moose::Meta::Role')) + || Moose->throw_error("You already have a &meta function, but it does not return a Moose::Meta::Role"); } - - - 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; - Class::MOP::load_class($_) for @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 { - { - no strict 'refs'; - $Moose::SUPER_SLOT{$CALLER} = \*{"${CALLER}::super"}; + else { + $meta = $metaclass->initialize($role); + + $meta->add_method( + 'meta' => sub { + # re-initialize so it inherits properly + $metaclass->initialize( ref($_[0]) || $_[0] ); } - 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 cannot support 'inner'"; - }; - }, - augment => sub { - my $meta = _find_meta(); - return subname 'Moose::Role::augment' => sub { - confess "Moose::Role cannot 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'; - - goto $exporter; - }; + ); + } + return $meta; } 1; @@ -186,21 +166,21 @@ Moose::Role - The Moose Role package Eq; 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 Moose; # automatically turns on strict and warnings - + with 'Eq'; - + sub equal { my ($self, $other) = @_; $self->as_float == $other->as_float; @@ -228,17 +208,32 @@ Moose::Role also offers two role-specific keyword exports: =item B -Roles can require that certain methods are implemented by any class which +Roles can require that certain methods are implemented by any class which C the 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 +with these C<@role_names>". This is a feature which should not be used lightly. =back +=head2 B + +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. + +=head2 B<< Moose::Role->init_meta(for_class => $role, metaclass => $metaclass) >> + +The C method sets up the metaclass object for the role +specified by C. It also injects a a C accessor into +the role so you can get at this object. + +The default metaclass is L. You can specify an +alternate metaclass with the C parameter. + =head1 CAVEATS Role support has only a few caveats: @@ -247,12 +242,12 @@ Role support has only a few caveats: =item * -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 +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. -=item * +=item * Role composition does its best to B be order-sensitive when it comes to conflict resolution and requirements detection. However, it is order-sensitive @@ -267,19 +262,15 @@ ordering. =item * -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. - -It is likely that attribute accessors will eventually be allowed to fufill those -requirements, or we will introduce a C keyword of some kind -instead. This decision has not yet been finalized. +The C keyword currently only works with actual methods. A +method modifier (before/around/after and override) will not count as a +fulfillment of the requirement. =back =head1 BUGS -All complex software has bugs lurking in it, and this module is no +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. @@ -291,11 +282,11 @@ Christian Hansen Echansen@cpan.orgE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2006-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut