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