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