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