lib/Moose/Role.pm

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