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