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