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         role_type $role 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->alias_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                 Moose::Util::apply_all_roles($meta, @_)
  60             };
  61         },
  62         requires => sub {
  63             my $meta = _find_meta();
  64             return subname 'Moose::Role::requires' => sub (@) {
  65                 confess "Must specify at least one method" unless @_;
  66                 $meta->add_required_methods(@_);
  67             };
  68         },
  69         excludes => sub {
  70             my $meta = _find_meta();
  71             return subname 'Moose::Role::excludes' => sub (@) {
  72                 confess "Must specify at least one role" unless @_;
  73                 $meta->add_excluded_roles(@_);
  74             };
  75         },
  76         has => sub {
  77             my $meta = _find_meta();
  78             return subname 'Moose::Role::has' => sub ($;%) {
  79                 my ($name, %options) = @_;
  80                 $meta->add_attribute($name, %options)
  81             };
  82         },
  83         before => sub {
  84             my $meta = _find_meta();
  85             return subname 'Moose::Role::before' => sub (@&) {
  86                 my $code = pop @_;
  87                 $meta->add_before_method_modifier($_, $code) for @_;
  88             };
  89         },
  90         after => sub {
  91             my $meta = _find_meta();
  92             return subname 'Moose::Role::after' => sub (@&) {
  93                 my $code = pop @_;
  94                 $meta->add_after_method_modifier($_, $code) for @_;
  95             };
  96         },
  97         around => sub {
  98             my $meta = _find_meta();
  99             return subname 'Moose::Role::around' => sub (@&) {
 100                 my $code = pop @_;
 101                 $meta->add_around_method_modifier($_, $code) for @_;
 102             };
 103         },
 104         super => sub {
 105             {
 106               no strict 'refs';
 107               $Moose::SUPER_SLOT{$CALLER} = \*{"${CALLER}::super"};
 108             }
 109             my $meta = _find_meta();
 110             return subname 'Moose::Role::super' => sub {};
 111         },
 112         override => sub {
 113             my $meta = _find_meta();
 114             return subname 'Moose::Role::override' => sub ($&) {
 115                 my ($name, $code) = @_;
 116                 $meta->add_override_method_modifier($name, $code);
 117             };
 118         },
 119         inner => sub {
 120             my $meta = _find_meta();
 121             return subname 'Moose::Role::inner' => sub {
 122                 confess "Moose::Role cannot support 'inner'";
 123             };
 124         },
 125         augment => sub {
 126             my $meta = _find_meta();
 127             return subname 'Moose::Role::augment' => sub {
 128                 confess "Moose::Role cannot support 'augment'";
 129             };
 130         },
 131         confess => sub {
 132             return \&Carp::confess;
 133         },
 134         blessed => sub {
 135             return \&Scalar::Util::blessed;
 136         }
 137     );
 138
 139     my $exporter = Sub::Exporter::build_exporter({
 140         exports => \%exports,
 141         groups  => {
 142             default => [':all']
 143         }
 144     });
 145
 146     sub import {
 147         $CALLER =
 148             ref $_[1] && defined $_[1]->{into} ? $_[1]->{into}
 149           : ref $_[1]
 150           && defined $_[1]->{into_level} ? caller( $_[1]->{into_level} )
 151           :                                caller();
 152
 153         # this works because both pragmas set $^H (see perldoc perlvar)
 154         # which affects the current compilation - i.e. the file who use'd
 155         # us - which is why we don't need to do anything special to make
 156         # it affect that file rather than this one (which is already compiled)
 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 Moose::Role; # automatically turns on strict and warnings
 183
 184   requires 'equal';
 185
 186   sub no_equal {
 187       my ($self, $other) = @_;
 188       !$self->equal($other);
 189   }
 190
 191   # ... then in your classes
 192
 193   package Currency;
 194   use Moose; # automatically turns on strict and warnings
 195
 196   with 'Eq';
 197
 198   sub equal {
 199       my ($self, $other) = @_;
 200       $self->as_float == $other->as_float;
 201   }
 202
 203 =head1 DESCRIPTION
 204
 205 Role support in Moose is pretty solid at this point. However, the best
 206 documentation is still the the test suite. It is fairly safe to assume Perl 6
 207 style behavior and then either refer to the test suite, or ask questions on
 208 #moose if something doesn't quite do what you expect.
 209
 210 We are planning writing some more documentation in the near future, but nothing
 211 is ready yet, sorry.
 212
 213 =head1 EXPORTED FUNCTIONS
 214
 215 Moose::Role currently supports all of the functions that L<Moose> exports, but
 216 differs slightly in how some items are handled (see L<CAVEATS> below for
 217 details).
 218
 219 Moose::Role also offers two role-specific keyword exports:
 220
 221 =over 4
 222
 223 =item B<requires (@method_names)>
 224
 225 Roles can require that certain methods are implemented by any class which
 226 C<does> the role.
 227
 228 =item B<excludes (@role_names)>
 229
 230 Roles can C<exclude> other roles, in effect saying "I can never be combined
 231 with these C<@role_names>". This is a feature which should not be used
 232 lightly.
 233
 234 =back
 235
 236 =head1 CAVEATS
 237
 238 Role support has only a few caveats:
 239
 240 =over 4
 241
 242 =item *
 243
 244 Roles cannot use the C<extends> keyword; it will throw an exception for now.
 245 The same is true of the C<augment> and C<inner> keywords (not sure those
 246 really make sense for roles). All other Moose keywords will be I<deferred>
 247 so that they can be applied to the consuming class.
 248
 249 =item *
 250
 251 Role composition does its best to B<not> be order-sensitive when it comes to
 252 conflict resolution and requirements detection. However, it is order-sensitive
 253 when it comes to method modifiers. All before/around/after modifiers are
 254 included whenever a role is composed into a class, and then applied in the order
 255 in which the roles are used. This also means that there is no conflict for
 256 before/around/after modifiers.
 257
 258 In most cases, this will be a non-issue; however, it is something to keep in
 259 mind when using method modifiers in a role. You should never assume any
 260 ordering.
 261
 262 =item *
 263
 264 The C<requires> keyword currently only works with actual methods. A method
 265 modifier (before/around/after and override) will not count as a fufillment
 266 of the requirement, and neither will an autogenerated accessor for an attribute.
 267
 268 It is likely that attribute accessors will eventually be allowed to fufill those
 269 requirements, or we will introduce a C<requires_attr> keyword of some kind
 270 instead. This decision has not yet been finalized.
 271
 272 =back
 273
 274 =head1 BUGS
 275
 276 All complex software has bugs lurking in it, and this module is no
 277 exception. If you find a bug please either email me, or add the bug
 278 to cpan-RT.
 279
 280 =head1 AUTHOR
 281
 282 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 283
 284 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 285
 286 =head1 COPYRIGHT AND LICENSE
 287
 288 Copyright 2006-2008 by Infinity Interactive, Inc.
 289
 290 L<http://www.iinteractive.com>
 291
 292 This library is free software; you can redistribute it and/or modify
 293 it under the same terms as Perl itself.
 294
 295 =cut