X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FRole.pm;h=2225690d0a38e1f2db9833bb0d2a5a1b2da96215;hb=1344fd47a7ef94f27fb6535ce07a5c910716e326;hp=0fd67a130a03614a4a5968c8ba5ea7f8c8c27025;hpb=76d37e5a93324c12abfa3c9c6c51dbc3bf31baa5;p=gitmo%2FMoose.git diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 0fd67a1..2225690 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -4,80 +4,204 @@ package Moose::Role; use strict; use warnings; -use Scalar::Util (); -use Carp 'confess'; -use Sub::Name 'subname'; +use Scalar::Util 'blessed'; +use Carp 'confess', 'croak'; -our $VERSION = '0.01'; +use Data::OptList; +use Sub::Exporter; -use Moose::Meta::Role; +our $VERSION = '0.52'; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose (); +use Moose::Util (); -sub import { - shift; - my $pkg = caller(); - - # we should never export to main - return if $pkg eq 'main'; - - Moose::Util::TypeConstraints->import($pkg); - - my $meta; - if ($pkg->can('meta')) { - $meta = $pkg->meta(); - (blessed($meta) && $meta->isa('Moose::Meta::Role')) - || confess "Whoops, not møøsey enough"; - } - else { - $meta = Moose::Meta::Role->new(role_name => $pkg); - $meta->role_meta->add_method('meta' => sub { $meta }) - } - - # NOTE: - # &alias_method will install the method, but it - # will not name it with - - # handle superclasses - $meta->role_meta->alias_method('extends' => subname 'Moose::Role::extends' => sub { - confess "Moose::Role does not currently support 'extends'" - }); - - # handle attributes - $meta->role_meta->alias_method('has' => subname 'Moose::Role::has' => sub { - my ($name, %options) = @_; - $meta->add_attribute($name, %options) - }); - - # handle method modifers - $meta->role_meta->alias_method('before' => subname 'Moose::Role::before' => sub { - my $code = pop @_; - $meta->add_method_modifier('before' => $_, $code) for @_; - }); - $meta->role_meta->alias_method('after' => subname 'Moose::Role::after' => sub { - my $code = pop @_; - $meta->add_method_modifier('after' => $_, $code) for @_; - }); - $meta->role_meta->alias_method('around' => subname 'Moose::Role::around' => sub { - my $code = pop @_; - $meta->add_method_modifier('around' => $_, $code) for @_; - }); - - $meta->role_meta->alias_method('super' => subname 'Moose::Role::super' => sub {}); - $meta->role_meta->alias_method('override' => subname 'Moose::Role::override' => sub { - my ($name, $code) = @_; - $meta->add_method_modifier('override' => $name, $code); - }); - - $meta->role_meta->alias_method('inner' => subname 'Moose::Role::inner' => sub { - confess "Moose::Role does not currently support 'inner'"; - }); - $meta->role_meta->alias_method('augment' => subname 'Moose::Role::augment' => sub { - confess "Moose::Role does not currently support 'augment'"; - }); - - # we recommend using these things - # so export them for them - $meta->role_meta->alias_method('confess' => \&Carp::confess); - $meta->role_meta->alias_method('blessed' => \&Scalar::Util::blessed); +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 + role_type $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->alias_method('meta' => sub { $meta }); + } + + return $METAS{$role} = $meta; + } + + + my %exports = ( + extends => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::extends' => sub { + croak "Roles do not currently support 'extends'" + }); + }, + with => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::with' => sub (@) { + Moose::Util::apply_all_roles($meta, @_) + }); + }, + requires => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::requires' => sub (@) { + croak "Must specify at least one method" unless @_; + $meta->add_required_methods(@_); + }); + }, + excludes => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::excludes' => sub (@) { + croak "Must specify at least one role" unless @_; + $meta->add_excluded_roles(@_); + }); + }, + has => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::has' => sub ($;%) { + 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; + }); + }, + before => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::before' => sub (@&) { + my $code = pop @_; + do { + croak "Moose::Role do not currently support " + . ref($_) + . " references for before method modifiers" + if ref $_; + $meta->add_before_method_modifier($_, $code) + } for @_; + }); + }, + after => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::after' => sub (@&) { + my $code = pop @_; + do { + croak "Moose::Role do not currently support " + . ref($_) + . " references for after method modifiers" + if ref $_; + $meta->add_after_method_modifier($_, $code) + } for @_; + }); + }, + around => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::around' => sub (@&) { + my $code = pop @_; + do { + croak "Moose::Role do not currently support " + . ref($_) + . " references for around method modifiers" + if ref $_; + $meta->add_around_method_modifier($_, $code) + } for @_; + }); + }, + # see Moose.pm for discussion + super => sub { + return Class::MOP::subname('Moose::Role::super' => sub { + return unless $Moose::SUPER_BODY; $Moose::SUPER_BODY->(@Moose::SUPER_ARGS) + }); + }, + override => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::override' => sub ($&) { + my ($name, $code) = @_; + $meta->add_override_method_modifier($name, $code); + }); + }, + inner => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::inner' => sub { + croak "Moose::Role cannot support 'inner'"; + }); + }, + augment => sub { + my $meta = _find_meta(); + return Class::MOP::subname('Moose::Role::augment' => sub { + croak "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 = + ref $_[1] && defined $_[1]->{into} ? $_[1]->{into} + : ref $_[1] + && defined $_[1]->{into_level} ? caller( $_[1]->{into_level} ) + : caller(); + + # this works because both pragmas set $^H (see perldoc perlvar) + # which affects the current compilation - i.e. the file who use'd + # us - which is why we don't need to do anything special to make + # it affect that file rather than this one (which is already compiled) + + strict->import; + warnings->import; + + # we should never export to main + return if $CALLER eq 'main'; + + goto $exporter; + }; + + sub unimport { + no strict 'refs'; + my $class = Moose::_get_caller(@_); + + # loop through the exports ... + foreach my $name ( keys %exports ) { + + # if we find one ... + if ( defined &{ $class . '::' . $name } ) { + my $keyword = \&{ $class . '::' . $name }; + + # make sure it is from Moose::Role + my ($pkg_name) = Class::MOP::get_code_info($keyword); + next if $pkg_name ne 'Moose::Role'; + + # and if it is from Moose::Role then undef the slot + delete ${ $class . '::' }{$name}; + } + } + } } 1; @@ -93,83 +217,107 @@ Moose::Role - The Moose Role =head1 SYNOPSIS package Eq; - use strict; - use warnings; - use Moose::Role; - - sub equal { confess "equal must be implemented" } - - sub no_equal { + use Moose::Role; # automatically turns on strict and warnings + + requires '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) = @_; - $other->as_float == $other->as_float; + $self->as_float == $other->as_float; } =head1 DESCRIPTION -This is currently a very early release of Perl 6 style Roles for -Moose, it should be considered experimental and incomplete. +Role support in Moose is pretty solid at this point. However, the best +documentation is still the the test suite. 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. + +We are planning writing some more documentation in the near future, but nothing +is ready yet, sorry. -This feature is being actively developed, but $work is currently -preventing me from paying as much attention to it as I would like. -So I am releasing it in hopes people will help me on this I. +=head1 EXPORTED FUNCTIONS -If you are interested in helping, please come to #moose on irc.perl.org -and we can talk. +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: + +=over 4 + +=item B + +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 +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. =head1 CAVEATS -Currently, the role support has a number of caveats. They are as follows: +Role support has only a few caveats: =over 4 =item * -There is no support for Roles consuming other Roles. The details of this -are not totally worked out yet, but it will mostly follow what is set out -in the Perl 6 Synopsis 12. +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 * -At this time classes I consume more than one Role, but they are simply -applied one after another in the order you ask for them. This is incorrect -behavior, the roles should be merged first, and conflicts determined, etc. -However, if your roles do not have any conflicts, then things will work just -fine. - -=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 +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. -I want to have B methods, which is unlike Perl 6 roles, and more -like the original Traits on which roles are based. This would be similar -in behavior to L. These are not yet implemented or course. +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. =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 -so that they can be applied to the consuming class. +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. -=back +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. -Basically thats all I can think of for now, I am sure there are more though. +=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. @@ -177,13 +325,15 @@ to cpan-RT. Stevan Little Estevan@iinteractive.comE +Christian Hansen Echansen@cpan.orgE + =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006-2008 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 \ No newline at end of file +=cut