X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FRole.pm;h=9671f3a2701e95195c5b28de001a1c5777879591;hb=536f0b1739154330082a42ba0c096d9d43cdc134;hp=ecc016fa596818fd2adddfcf78f5bf99e5513f54;hpb=e46edf94befc235dbaac9636cb98bfa0d817751f;p=gitmo%2FMoose.git diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index ecc016f..9671f3a 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -8,88 +8,138 @@ use Scalar::Util (); use Carp 'confess'; use Sub::Name 'subname'; -our $VERSION = '0.02'; +use Sub::Exporter; -use Moose::Meta::Role; +our $VERSION = '0.03'; -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->alias_method('extends' => subname 'Moose::Role::extends' => sub { - confess "Moose::Role does not currently support 'extends'" - }); - - # handle roles - $meta->alias_method('with' => subname 'Moose::with' => sub { - my ($role) = @_; - Moose::_load_all_classes($role); - $role->meta->apply($meta); - }); - - # required methods - $meta->alias_method('requires' => subname 'Moose::requires' => sub { - $meta->add_required_methods(@_); - }); - - # handle attributes - $meta->alias_method('has' => subname 'Moose::Role::has' => sub { - my ($name, %options) = @_; - $meta->add_attribute($name, %options) - }); - - # handle method modifers - $meta->alias_method('before' => subname 'Moose::Role::before' => sub { - my $code = pop @_; - $meta->add_before_method_modifier($_, $code) for @_; - }); - $meta->alias_method('after' => subname 'Moose::Role::after' => sub { - my $code = pop @_; - $meta->add_after_method_modifier($_, $code) for @_; - }); - $meta->alias_method('around' => subname 'Moose::Role::around' => sub { - my $code = pop @_; - $meta->add_around_method_modifier($_, $code) for @_; - }); - - $meta->alias_method('super' => subname 'Moose::Role::super' => sub {}); - $meta->alias_method('override' => subname 'Moose::Role::override' => sub { - my ($name, $code) = @_; - $meta->add_override_method_modifier($name, $code); - }); +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; + } + - $meta->alias_method('inner' => subname 'Moose::Role::inner' => sub { - confess "Moose::Role does not currently support 'inner'"; - }); - $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->alias_method('confess' => \&Carp::confess); - $meta->alias_method('blessed' => \&Scalar::Util::blessed); + 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 ($role) = @_; + Moose::_load_all_classes($role); + $role->meta->apply($meta); + }; + }, + requires => sub { + my $meta = _find_meta(); + return subname 'Moose::Role::requires' => sub { + $meta->add_required_methods(@_); + }; + }, + 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(); + + # we should never export to main + return if $CALLER eq 'main'; + + goto $exporter; + }; + } 1; @@ -133,28 +183,28 @@ Moose::Role - The Moose Role =head1 DESCRIPTION This is currently a very early release of Perl 6 style Roles for -Moose, it should be considered experimental and incomplete. - -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. - -If you are interested in helping, please come to #moose on irc.perl.org -and we can talk. +Moose, it is still incomplete, but getting much closer. If you are +interested in helping move this feature along, please come to +#moose on irc.perl.org and we can talk. =head1 CAVEATS -Currently, the role support has a number of caveats. They are as follows: +Currently, the role support has a few of caveats. They are as follows: =over 4 =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. +At this time classes I correctly consume more than one role. The +role composition process, and it's conflict detection has not been added +yet. While this should be considered a major feature, it can easily be +worked around, and in many cases, is not needed at all. + +A class can actually consume multiple roles, they are just 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. This actually tends to be quite sufficient for basic roles. =item * @@ -165,8 +215,6 @@ so that they can be applied to the consuming class. =back -Basically thats all I can think of for now, I am sure there are more though. - =head1 BUGS All complex software has bugs lurking in it, and this module is no