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