lib/Moose/Role.pm

   1
   2 package Moose::Role;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util ();
   8 use Carp         'confess';
   9 use Sub::Name    'subname';
  10
  11 use Sub::Exporter;
  12
  13 our $VERSION = '0.04';
  14
  15 use Moose::Meta::Role;
  16 use Moose::Util::TypeConstraints;
  17
  18 {
  19     my ( $CALLER, %METAS );
  20
  21     sub _find_meta {
  22         my $role = $CALLER;
  23
  24         return $METAS{$role} if exists $METAS{$role};
  25
  26         # make a subtype for each Moose class
  27         subtype $role
  28             => as 'Role'
  29             => where { $_->does($role) }
  30         unless find_type_constraint($role);
  31
  32         my $meta;
  33         if ($role->can('meta')) {
  34                 $meta = $role->meta();
  35                 (blessed($meta) && $meta->isa('Moose::Meta::Role'))
  36                         || confess "Whoops, not møøsey enough";
  37         }
  38         else {
  39                 $meta = Moose::Meta::Role->new(role_name => $role);
  40                 $meta->_role_meta->add_method('meta' => sub { $meta })
  41         }
  42
  43         return $METAS{$role} = $meta;
  44     }
  45
  46
  47     my %exports = (
  48         extends => sub {
  49             my $meta = _find_meta();
  50             return subname 'Moose::Role::extends' => sub {
  51                 confess "Moose::Role does not currently support 'extends'"
  52                 };
  53             },
  54             with => sub {
  55                 my $meta = _find_meta();
  56                 return subname 'Moose::Role::with' => sub ($;@) {
  57                 my (@roles) = @_;
  58                 Moose::_load_all_classes(@roles);
  59                 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
  60                     || confess "You can only consume roles, $_ is not a Moose role"
  61                         foreach @roles;
  62                 if (scalar @roles == 1) {
  63                     $roles[0]->meta->apply($meta);
  64                 }
  65                 else {
  66                     Moose::Meta::Role->combine(
  67                         map { $_->meta } @roles
  68                     )->apply($meta);
  69                 }
  70             };
  71             },
  72         requires => sub {
  73             my $meta = _find_meta();
  74             return subname 'Moose::Role::requires' => sub ($;@) {
  75                 $meta->add_required_methods(@_);
  76                 };
  77             },
  78         excludes => sub {
  79             my $meta = _find_meta();
  80             return subname 'Moose::Role::excludes' => sub ($;@) {
  81                 $meta->add_excluded_roles(@_);
  82                 };
  83             },
  84         has => sub {
  85             my $meta = _find_meta();
  86             return subname 'Moose::Role::has' => sub ($;%) {
  87                         my ($name, %options) = @_;
  88                         $meta->add_attribute($name, %options)
  89                 };
  90             },
  91         before => sub {
  92             my $meta = _find_meta();
  93             return subname 'Moose::Role::before' => sub (@&) {
  94                         my $code = pop @_;
  95                         $meta->add_before_method_modifier($_, $code) for @_;
  96                 };
  97             },
  98         after => sub {
  99             my $meta = _find_meta();
 100             return subname 'Moose::Role::after' => sub (@&) {
 101                         my $code = pop @_;
 102                         $meta->add_after_method_modifier($_, $code) for @_;
 103                 };
 104             },
 105         around => sub {
 106             my $meta = _find_meta();
 107             return subname 'Moose::Role::around' => sub (@&) {
 108                         my $code = pop @_;
 109                         $meta->add_around_method_modifier($_, $code) for @_;
 110                 };
 111             },
 112             super => sub {
 113             my $meta = _find_meta();
 114             return subname 'Moose::Role::super' => sub {};
 115         },
 116         override => sub {
 117             my $meta = _find_meta();
 118             return subname 'Moose::Role::override' => sub ($&) {
 119                 my ($name, $code) = @_;
 120                         $meta->add_override_method_modifier($name, $code);
 121                 };
 122             },
 123         inner => sub {
 124             my $meta = _find_meta();
 125             return subname 'Moose::Role::inner' => sub {
 126                 confess "Moose::Role does not currently support 'inner'";
 127                 };
 128             },
 129         augment => sub {
 130             my $meta = _find_meta();
 131             return subname 'Moose::Role::augment' => sub {
 132                 confess "Moose::Role does not currently support 'augment'";
 133                 };
 134             },
 135         confess => sub {
 136             return \&Carp::confess;
 137         },
 138         blessed => sub {
 139             return \&Scalar::Util::blessed;
 140         }
 141         );
 142
 143     my $exporter = Sub::Exporter::build_exporter({
 144         exports => \%exports,
 145         groups  => {
 146             default => [':all']
 147         }
 148     });
 149
 150     sub import {
 151         $CALLER = caller();
 152
 153         strict->import;
 154         warnings->import;
 155
 156         # we should never export to main
 157         return if $CALLER eq 'main';
 158
 159         goto $exporter;
 160     };
 161
 162 }
 163
 164 1;
 165
 166 __END__
 167
 168 =pod
 169
 170 =head1 NAME
 171
 172 Moose::Role - The Moose Role
 173
 174 =head1 SYNOPSIS
 175
 176   package Eq;
 177   use strict;
 178   use warnings;
 179   use Moose::Role;
 180
 181   requires 'equal';
 182
 183   sub no_equal {
 184       my ($self, $other) = @_;
 185       !$self->equal($other);
 186   }
 187
 188   # ... then in your classes
 189
 190   package Currency;
 191   use strict;
 192   use warnings;
 193   use Moose;
 194
 195   with 'Eq';
 196
 197   sub equal {
 198       my ($self, $other) = @_;
 199       $self->as_float == $other->as_float;
 200   }
 201
 202 =head1 DESCRIPTION
 203
 204 Role support in Moose is coming along quite well. It's best documentation
 205 is still the the test suite, but it is fairly safe to assume Perl 6 style
 206 behavior, and then either refer to the test suite, or ask questions on
 207 #moose if something doesn't quite do what you expect. More complete
 208 documentation is planned and will be included with the next official
 209 (non-developer) release.
 210
 211 =head1 EXPORTED FUNCTIONS
 212
 213 Currently Moose::Role supports all of the functions that L<Moose> exports,
 214 but differs slightly in how some items are handled (see L<CAVEATS> below
 215 for details).
 216
 217 Moose::Role also offers two role specific keyword exports:
 218
 219 =over 4
 220
 221 =item B<requires (@method_names)>
 222
 223 Roles can require that certain methods are implemented by any class which
 224 C<does> the role.
 225
 226 =item B<excludes (@role_names)>
 227
 228 Roles can C<exclude> other roles, in effect saying "I can never be combined
 229 with these C<@role_names>". This is a feature which should not be used
 230 lightly.
 231
 232 =back
 233
 234 =head1 CAVEATS
 235
 236 The role support now has only a few caveats. They are as follows:
 237
 238 =over 4
 239
 240 =item *
 241
 242 Roles cannot use the C<extends> keyword, it will throw an exception for now.
 243 The same is true of the C<augment> and C<inner> keywords (not sure those
 244 really make sense for roles). All other Moose keywords will be I<deferred>
 245 so that they can be applied to the consuming class.
 246
 247 =item *
 248
 249 Role composition does it's best to B<not> be order sensitive when it comes
 250 to conflict resolution and requirements detection. However, it is order
 251 sensitive when it comes to method modifiers. All before/around/after modifiers
 252 are included whenever a role is composed into a class, and then are applied
 253 in the order the roles are used. This too means that there is no conflict for
 254 before/around/after modifiers as well.
 255
 256 In most cases, this will be a non issue, however it is something to keep in
 257 mind when using method modifiers in a role. You should never assume any
 258 ordering.
 259
 260 =item *
 261
 262 The C<requires> keyword currently only works with actual methods. A method
 263 modifier (before/around/after and override) will not count as a fufillment
 264 of the requirement, and neither will an autogenerated accessor for an attribute.
 265
 266 It is likely that the attribute accessors will eventually be allowed to fufill
 267 those requirements, either that or we will introduce a C<requires_attr> keyword
 268 of some kind instead. This descision has not yet been finalized.
 269
 270 =back
 271
 272 =head1 BUGS
 273
 274 All complex software has bugs lurking in it, and this module is no
 275 exception. If you find a bug please either email me, or add the bug
 276 to cpan-RT.
 277
 278 =head1 AUTHOR
 279
 280 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 281
 282 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 283
 284 =head1 COPYRIGHT AND LICENSE
 285
 286 Copyright 2006 by Infinity Interactive, Inc.
 287
 288 L<http://www.iinteractive.com>
 289
 290 This library is free software; you can redistribute it and/or modify
 291 it under the same terms as Perl itself.
 292
 293 =cut