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