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.08';
  15 our $AUTHORITY = 'cpan:STEVAN';
  16
  17 use Moose       ();
  18 use Moose::Util ();
  19
  20 use Moose::Meta::Role;
  21 use Moose::Util::TypeConstraints;
  22
  23 {
  24     my ( $CALLER, %METAS );
  25
  26     sub _find_meta {
  27         my $role = $CALLER;
  28
  29         return $METAS{$role} if exists $METAS{$role};
  30
  31         # make a subtype for each Moose class
  32         subtype $role
  33             => as 'Role'
  34             => where { Moose::Util::does_role($_, $role) }
  35             => optimize_as { blessed($_[0]) && Moose::Util::does_role($_[0], $role) }
  36         unless find_type_constraint($role);
  37
  38         my $meta;
  39         if ($role->can('meta')) {
  40             $meta = $role->meta();
  41             (blessed($meta) && $meta->isa('Moose::Meta::Role'))
  42                 || confess "You already have a &meta function, but it does not return a Moose::Meta::Role";
  43         }
  44         else {
  45             $meta = Moose::Meta::Role->initialize($role);
  46             $meta->alias_method('meta' => sub { $meta });
  47         }
  48
  49         return $METAS{$role} = $meta;
  50     }
  51
  52
  53     my %exports = (
  54         extends => sub {
  55             my $meta = _find_meta();
  56             return subname 'Moose::Role::extends' => sub {
  57                 confess "Moose::Role does not currently support 'extends'"
  58             };
  59         },
  60         with => sub {
  61             my $meta = _find_meta();
  62             return subname 'Moose::Role::with' => sub (@) {
  63                 Moose::Util::apply_all_roles($meta, @_)
  64             };
  65         },
  66         requires => sub {
  67             my $meta = _find_meta();
  68             return subname 'Moose::Role::requires' => sub (@) {
  69                 confess "Must specify at least one method" unless @_;
  70                 $meta->add_required_methods(@_);
  71             };
  72         },
  73         excludes => sub {
  74             my $meta = _find_meta();
  75             return subname 'Moose::Role::excludes' => sub (@) {
  76                 confess "Must specify at least one role" unless @_;
  77                 $meta->add_excluded_roles(@_);
  78             };
  79         },
  80         has => sub {
  81             my $meta = _find_meta();
  82             return subname 'Moose::Role::has' => sub ($;%) {
  83                 my ($name, %options) = @_;
  84                 $meta->add_attribute($name, %options)
  85             };
  86         },
  87         before => sub {
  88             my $meta = _find_meta();
  89             return subname 'Moose::Role::before' => sub (@&) {
  90                 my $code = pop @_;
  91                 $meta->add_before_method_modifier($_, $code) for @_;
  92             };
  93         },
  94         after => sub {
  95             my $meta = _find_meta();
  96             return subname 'Moose::Role::after' => sub (@&) {
  97                 my $code = pop @_;
  98                 $meta->add_after_method_modifier($_, $code) for @_;
  99             };
 100         },
 101         around => sub {
 102             my $meta = _find_meta();
 103             return subname 'Moose::Role::around' => sub (@&) {
 104                 my $code = pop @_;
 105                 $meta->add_around_method_modifier($_, $code) for @_;
 106             };
 107         },
 108         super => sub {
 109             {
 110               no strict 'refs';
 111               $Moose::SUPER_SLOT{$CALLER} = \*{"${CALLER}::super"};
 112             }
 113             my $meta = _find_meta();
 114             return subname 'Moose::Role::super' => sub {};
 115         },
 116         override => sub {
 117             my $meta = _find_meta();
 118             return subname 'Moose::Role::override' => sub ($&) {
 119                 my ($name, $code) = @_;
 120                 $meta->add_override_method_modifier($name, $code);
 121             };
 122         },
 123         inner => sub {
 124             my $meta = _find_meta();
 125             return subname 'Moose::Role::inner' => sub {
 126                 confess "Moose::Role cannot support 'inner'";
 127             };
 128         },
 129         augment => sub {
 130             my $meta = _find_meta();
 131             return subname 'Moose::Role::augment' => sub {
 132                 confess "Moose::Role cannot support 'augment'";
 133             };
 134         },
 135         confess => sub {
 136             return \&Carp::confess;
 137         },
 138         blessed => sub {
 139             return \&Scalar::Util::blessed;
 140         }
 141     );
 142
 143     my $exporter = Sub::Exporter::build_exporter({
 144         exports => \%exports,
 145         groups  => {
 146             default => [':all']
 147         }
 148     });
 149
 150     sub import {
 151         $CALLER =
 152             ref $_[1] && defined $_[1]->{into} ? $_[1]->{into}
 153           : ref $_[1]
 154           && defined $_[1]->{into_level} ? caller( $_[1]->{into_level} )
 155           :                                caller();
 156
 157         # this works because both pragmas set $^H (see perldoc perlvar)
 158         # which affects the current compilation - i.e. the file who use'd
 159         # us - which is why we don't need to do anything special to make
 160         # it affect that file rather than this one (which is already compiled)
 161
 162         strict->import;
 163         warnings->import;
 164
 165         # we should never export to main
 166         return if $CALLER eq 'main';
 167
 168         goto $exporter;
 169     };
 170
 171 }
 172
 173 1;
 174
 175 __END__
 176
 177 =pod
 178
 179 =head1 NAME
 180
 181 Moose::Role - The Moose Role
 182
 183 =head1 SYNOPSIS
 184
 185   package Eq;
 186   use Moose::Role; # automatically turns on strict and warnings
 187
 188   requires 'equal';
 189
 190   sub no_equal {
 191       my ($self, $other) = @_;
 192       !$self->equal($other);
 193   }
 194
 195   # ... then in your classes
 196
 197   package Currency;
 198   use Moose; # automatically turns on strict and warnings
 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 pretty solid at this point. However, the best
 210 documentation is still the the test suite. It is fairly safe to assume Perl 6
 211 style behavior and then either refer to the test suite, or ask questions on
 212 #moose if something doesn't quite do what you expect.
 213
 214 We are planning writing some more documentation in the near future, but nothing
 215 is ready yet, sorry.
 216
 217 =head1 EXPORTED FUNCTIONS
 218
 219 Moose::Role currently supports all of the functions that L<Moose> exports, but
 220 differs slightly in how some items are handled (see L<CAVEATS> below for
 221 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 Role support has only a few caveats:
 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 its best to B<not> be order-sensitive when it comes to
 256 conflict resolution and requirements detection. However, it is order-sensitive
 257 when it comes to method modifiers. All before/around/after modifiers are
 258 included whenever a role is composed into a class, and then applied in the order
 259 in which the roles are used. This also means that there is no conflict for
 260 before/around/after modifiers.
 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 attribute accessors will eventually be allowed to fufill those
 273 requirements, or we will introduce a C<requires_attr> keyword of some kind
 274 instead. This decision 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-2008 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