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         # we should never export to main
 154         return if $CALLER eq 'main';
 155
 156         goto $exporter;
 157     };
 158
 159 }
 160
 161 1;
 162
 163 __END__
 164
 165 =pod
 166
 167 =head1 NAME
 168
 169 Moose::Role - The Moose Role
 170
 171 =head1 SYNOPSIS
 172
 173   package Eq;
 174   use strict;
 175   use warnings;
 176   use Moose::Role;
 177
 178   requires 'equal';
 179
 180   sub no_equal {
 181       my ($self, $other) = @_;
 182       !$self->equal($other);
 183   }
 184
 185   # ... then in your classes
 186
 187   package Currency;
 188   use strict;
 189   use warnings;
 190   use Moose;
 191
 192   with 'Eq';
 193
 194   sub equal {
 195       my ($self, $other) = @_;
 196       $self->as_float == $other->as_float;
 197   }
 198
 199 =head1 DESCRIPTION
 200
 201 Role support in Moose is coming along quite well. It's best documentation
 202 is still the the test suite, but it is fairly safe to assume Perl 6 style
 203 behavior, and then either refer to the test suite, or ask questions on
 204 #moose if something doesn't quite do what you expect. More complete
 205 documentation is planned and will be included with the next official
 206 (non-developer) release.
 207
 208 =head1 EXPORTED FUNCTIONS
 209
 210 Currently Moose::Role supports all of the functions that L<Moose> exports,
 211 but differs slightly in how some items are handled (see L<CAVEATS> below
 212 for details).
 213
 214 Moose::Role also offers two role specific keyword exports:
 215
 216 =over 4
 217
 218 =item B<requires (@method_names)>
 219
 220 Roles can require that certain methods are implemented by any class which
 221 C<does> the role.
 222
 223 =item B<excludes (@role_names)>
 224
 225 Roles can C<exclude> other roles, in effect saying "I can never be combined
 226 with these C<@role_names>". This is a feature which should not be used
 227 lightly.
 228
 229 =back
 230
 231 =head1 CAVEATS
 232
 233 The role support now has only a few caveats. They are as follows:
 234
 235 =over 4
 236
 237 =item *
 238
 239 Roles cannot use the C<extends> keyword, it will throw an exception for now.
 240 The same is true of the C<augment> and C<inner> keywords (not sure those
 241 really make sense for roles). All other Moose keywords will be I<deferred>
 242 so that they can be applied to the consuming class.
 243
 244 =item *
 245
 246 Role composition does it's best to B<not> be order sensitive when it comes
 247 to conflict resolution and requirements detection. However, it is order
 248 sensitive when it comes to method modifiers. All before/around/after modifiers
 249 are included whenever a role is composed into a class, and then are applied
 250 in the order the roles are used. This too means that there is no conflict for
 251 before/around/after modifiers as well.
 252
 253 In most cases, this will be a non issue, however it is something to keep in
 254 mind when using method modifiers in a role. You should never assume any
 255 ordering.
 256
 257 =item *
 258
 259 The C<requires> keyword currently only works with actual methods. A method
 260 modifier (before/around/after and override) will not count as a fufillment
 261 of the requirement, and neither will an autogenerated accessor for an attribute.
 262
 263 It is likely that the attribute accessors will eventually be allowed to fufill
 264 those requirements, either that or we will introduce a C<requires_attr> keyword
 265 of some kind instead. This descision has not yet been finalized.
 266
 267 =back
 268
 269 =head1 BUGS
 270
 271 All complex software has bugs lurking in it, and this module is no
 272 exception. If you find a bug please either email me, or add the bug
 273 to cpan-RT.
 274
 275 =head1 AUTHOR
 276
 277 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 278
 279 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 280
 281 =head1 COPYRIGHT AND LICENSE
 282
 283 Copyright 2006 by Infinity Interactive, Inc.
 284
 285 L<http://www.iinteractive.com>
 286
 287 This library is free software; you can redistribute it and/or modify
 288 it under the same terms as Perl itself.
 289
 290 =cut