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         'croak';
   9
  10 use Data::OptList;
  11 use Sub::Exporter;
  12
  13 our $VERSION   = '0.65';
  14 $VERSION = eval $VERSION;
  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 sub extends {
  24     croak "Roles do not currently support 'extends'";
  25 }
  26
  27 sub with {
  28     Moose::Util::apply_all_roles( Moose::Meta::Role->initialize(shift), @_ );
  29 }
  30
  31 sub requires {
  32     my $meta = Moose::Meta::Role->initialize(shift);
  33     croak "Must specify at least one method" unless @_;
  34     $meta->add_required_methods(@_);
  35 }
  36
  37 sub excludes {
  38     my $meta = Moose::Meta::Role->initialize(shift);
  39     croak "Must specify at least one role" unless @_;
  40     $meta->add_excluded_roles(@_);
  41 }
  42
  43 sub has {
  44     my $meta = Moose::Meta::Role->initialize(shift);
  45     my $name = shift;
  46     croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
  47     my %options = @_;
  48     my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
  49     $meta->add_attribute( $_, %options ) for @$attrs;
  50 }
  51
  52 sub before {
  53     my $meta = Moose::Meta::Role->initialize(shift);
  54     my $code = pop @_;
  55
  56     for (@_) {
  57         croak "Roles do not currently support "
  58             . ref($_)
  59             . " references for before method modifiers"
  60             if ref $_;
  61         $meta->add_before_method_modifier( $_, $code );
  62     }
  63 }
  64
  65 sub after {
  66     my $meta = Moose::Meta::Role->initialize(shift);
  67
  68     my $code = pop @_;
  69     for (@_) {
  70         croak "Roles do not currently support "
  71             . ref($_)
  72             . " references for after method modifiers"
  73             if ref $_;
  74         $meta->add_after_method_modifier( $_, $code );
  75     }
  76 }
  77
  78 sub around {
  79     my $meta = Moose::Meta::Role->initialize(shift);
  80     my $code = pop @_;
  81     for (@_) {
  82         croak "Roles do not currently support "
  83             . ref($_)
  84             . " references for around method modifiers"
  85             if ref $_;
  86         $meta->add_around_method_modifier( $_, $code );
  87     }
  88 }
  89
  90 # see Moose.pm for discussion
  91 sub super {
  92     return unless $Moose::SUPER_BODY;
  93     $Moose::SUPER_BODY->(@Moose::SUPER_ARGS);
  94 }
  95
  96 sub override {
  97     my $meta = Moose::Meta::Role->initialize(shift);
  98     my ( $name, $code ) = @_;
  99     $meta->add_override_method_modifier( $name, $code );
 100 }
 101
 102 sub inner {
 103     croak "Roles cannot support 'inner'";
 104 }
 105
 106 sub augment {
 107     croak "Roles cannot support 'augment'";
 108 }
 109
 110 my $exporter = Moose::Exporter->setup_import_methods(
 111     with_caller => [
 112         qw( with requires excludes has before after around override make_immutable )
 113     ],
 114     as_is => [
 115         qw( extends super inner augment ),
 116         \&Carp::confess,
 117         \&Scalar::Util::blessed,
 118     ],
 119 );
 120
 121 sub init_meta {
 122     shift;
 123     my %args = @_;
 124
 125     my $role = $args{for_class}
 126         or Moose->throw_error("Cannot call init_meta without specifying a for_class");
 127
 128     my $metaclass = $args{metaclass} || "Moose::Meta::Role";
 129
 130     # make a subtype for each Moose class
 131     role_type $role unless find_type_constraint($role);
 132
 133     # FIXME copy from Moose.pm
 134     my $meta;
 135     if ($role->can('meta')) {
 136         $meta = $role->meta();
 137         (blessed($meta) && $meta->isa('Moose::Meta::Role'))
 138             || Moose->throw_error("You already have a &meta function, but it does not return a Moose::Meta::Role");
 139     }
 140     else {
 141         $meta = $metaclass->initialize($role);
 142
 143         $meta->add_method(
 144             'meta' => sub {
 145                 # re-initialize so it inherits properly
 146                 $metaclass->initialize( ref($_[0]) || $_[0] );
 147             }
 148         );
 149     }
 150
 151     return $meta;
 152 }
 153
 154 1;
 155
 156 __END__
 157
 158 =pod
 159
 160 =head1 NAME
 161
 162 Moose::Role - The Moose Role
 163
 164 =head1 SYNOPSIS
 165
 166   package Eq;
 167   use Moose::Role; # automatically turns on strict and warnings
 168
 169   requires 'equal';
 170
 171   sub no_equal {
 172       my ($self, $other) = @_;
 173       !$self->equal($other);
 174   }
 175
 176   # ... then in your classes
 177
 178   package Currency;
 179   use Moose; # automatically turns on strict and warnings
 180
 181   with 'Eq';
 182
 183   sub equal {
 184       my ($self, $other) = @_;
 185       $self->as_float == $other->as_float;
 186   }
 187
 188 =head1 DESCRIPTION
 189
 190 Role support in Moose is pretty solid at this point. However, the best
 191 documentation is still the the test suite. It is fairly safe to assume Perl 6
 192 style behavior and then either refer to the test suite, or ask questions on
 193 #moose if something doesn't quite do what you expect.
 194
 195 We are planning writing some more documentation in the near future, but nothing
 196 is ready yet, sorry.
 197
 198 =head1 EXPORTED FUNCTIONS
 199
 200 Moose::Role currently supports all of the functions that L<Moose> exports, but
 201 differs slightly in how some items are handled (see L<CAVEATS> below for
 202 details).
 203
 204 Moose::Role also offers two role-specific keyword exports:
 205
 206 =over 4
 207
 208 =item B<requires (@method_names)>
 209
 210 Roles can require that certain methods are implemented by any class which
 211 C<does> the role.
 212
 213 =item B<excludes (@role_names)>
 214
 215 Roles can C<exclude> other roles, in effect saying "I can never be combined
 216 with these C<@role_names>". This is a feature which should not be used
 217 lightly.
 218
 219 =back
 220
 221 =head2 B<unimport>
 222
 223 Moose::Role offers a way to remove the keywords it exports, through the
 224 C<unimport> method. You simply have to say C<no Moose::Role> at the bottom of
 225 your code for this to work.
 226
 227 =head2 B<< Moose::Role->init_meta(for_class => $role, metaclass => $metaclass) >>
 228
 229 The C<init_meta> method sets up the metaclass object for the role
 230 specified by C<for_class>. It also injects a a C<meta> accessor into
 231 the role so you can get at this object.
 232
 233 The default metaclass is L<Moose::Meta::Role>. You can specify an
 234 alternate metaclass with the C<metaclass> parameter.
 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