lib/Moose/Role.pm

   1
   2 package Moose::Role;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util ();
   8 use Carp         'confess';
   9 use Sub::Name    'subname';
  10
  11 use Sub::Exporter;
  12
  13 our $VERSION = '0.04';
  14
  15 use Moose::Meta::Role;
  16 use Moose::Util::TypeConstraints;
  17
  18 {
  19     my ( $CALLER, %METAS );
  20
  21     sub _find_meta {
  22         my $role = $CALLER;
  23
  24         return $METAS{$role} if exists $METAS{$role};
  25
  26         # make a subtype for each Moose class
  27         subtype $role
  28             => as 'Role'
  29             => where { $_->does($role) }
  30         unless find_type_constraint($role);
  31
  32         my $meta;
  33         if ($role->can('meta')) {
  34                 $meta = $role->meta();
  35                 (blessed($meta) && $meta->isa('Moose::Meta::Role'))
  36                         || confess "Whoops, not møøsey enough";
  37         }
  38         else {
  39                 $meta = Moose::Meta::Role->new(role_name => $role);
  40                 $meta->_role_meta->add_method('meta' => sub { $meta })
  41         }
  42
  43         return $METAS{$role} = $meta;
  44     }
  45
  46
  47     my %exports = (
  48         extends => sub {
  49             my $meta = _find_meta();
  50             return subname 'Moose::Role::extends' => sub {
  51                 confess "Moose::Role does not currently support 'extends'"
  52                 };
  53             },
  54             with => sub {
  55                 my $meta = _find_meta();
  56                 return subname 'Moose::Role::with' => sub ($;@) {
  57                 my (@roles) = @_;
  58                 Moose::_load_all_classes(@roles);
  59                 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
  60                     || confess "You can only consume roles, $_ is not a Moose role"
  61                         foreach @roles;
  62                 if (scalar @roles == 1) {
  63                     $roles[0]->meta->apply($meta);
  64                 }
  65                 else {
  66                     Moose::Meta::Role->combine(
  67                         map { $_->meta } @roles
  68                     )->apply($meta);
  69                 }
  70             };
  71             },
  72         requires => sub {
  73             my $meta = _find_meta();
  74             return subname 'Moose::Role::requires' => sub ($;@) {
  75                 $meta->add_required_methods(@_);
  76                 };
  77             },
  78         excludes => sub {
  79             my $meta = _find_meta();
  80             return subname 'Moose::Role::excludes' => sub ($;@) {
  81                 $meta->add_excluded_roles(@_);
  82                 };
  83             },
  84         has => sub {
  85             my $meta = _find_meta();
  86             return subname 'Moose::Role::has' => sub ($;%) {
  87                         my ($name, %options) = @_;
  88                         $meta->add_attribute($name, %options)
  89                 };
  90             },
  91         before => sub {
  92             my $meta = _find_meta();
  93             return subname 'Moose::Role::before' => sub (@&) {
  94                         my $code = pop @_;
  95                         $meta->add_before_method_modifier($_, $code) for @_;
  96                 };
  97             },
  98         after => sub {
  99             my $meta = _find_meta();
 100             return subname 'Moose::Role::after' => sub (@&) {
 101                         my $code = pop @_;
 102                         $meta->add_after_method_modifier($_, $code) for @_;
 103                 };
 104             },
 105         around => sub {
 106             my $meta = _find_meta();
 107             return subname 'Moose::Role::around' => sub (@&) {
 108                         my $code = pop @_;
 109                         $meta->add_around_method_modifier($_, $code) for @_;
 110                 };
 111             },
 112             super => sub {
 113             my $meta = _find_meta();
 114             return subname 'Moose::Role::super' => sub {};
 115         },
 116         override => sub {
 117             my $meta = _find_meta();
 118             return subname 'Moose::Role::override' => sub ($&) {
 119                 my ($name, $code) = @_;
 120                         $meta->add_override_method_modifier($name, $code);
 121                 };
 122             },
 123         inner => sub {
 124             my $meta = _find_meta();
 125             return subname 'Moose::Role::inner' => sub {
 126                 confess "Moose::Role does not currently support 'inner'";
 127                 };
 128             },
 129         augment => sub {
 130             my $meta = _find_meta();
 131             return subname 'Moose::Role::augment' => sub {
 132                 confess "Moose::Role does not currently support 'augment'";
 133                 };
 134             },
 135         confess => sub {
 136             return \&Carp::confess;
 137         },
 138         blessed => sub {
 139             return \&Scalar::Util::blessed;
 140         }
 141         );
 142
 143     my $exporter = Sub::Exporter::build_exporter({
 144         exports => \%exports,
 145         groups  => {
 146             default => [':all']
 147         }
 148     });
 149
 150     sub import {
 151         $CALLER = caller();
 152
 153         # we should never export to main
 154         return if $CALLER eq 'main';
 155
 156         goto $exporter;
 157     };
 158
 159 }
 160
 161 1;
 162
 163 __END__
 164
 165 =pod
 166
 167 =head1 NAME
 168
 169 Moose::Role - The Moose Role
 170
 171 =head1 SYNOPSIS
 172
 173   package Eq;
 174   use strict;
 175   use warnings;
 176   use Moose::Role;
 177
 178   requires 'equal';
 179
 180   sub no_equal {
 181       my ($self, $other) = @_;
 182       !$self->equal($other);
 183   }
 184
 185   # ... then in your classes
 186
 187   package Currency;
 188   use strict;
 189   use warnings;
 190   use Moose;
 191
 192   with 'Eq';
 193
 194   sub equal {
 195       my ($self, $other) = @_;
 196       $self->as_float == $other->as_float;
 197   }
 198
 199 =head1 DESCRIPTION
 200
 201 Role support in Moose is coming along quite well. It's best documentation
 202 is still the the test suite, but it is fairly safe to assume Perl 6 style
 203 behavior, and then either refer to the test suite, or ask questions on
 204 #moose if something doesn't quite do what you expect. More complete
 205 documentation is planned and will be included with the next official
 206 (non-developer) release.
 207
 208 =head1 EXPORTED FUNCTIONS
 209
 210 Currently Moose::Role supports all of the functions that L<Moose> exports,
 211 but differs slightly in how some items are handled (see L<CAVEATS> below
 212 for details).
 213
 214 Moose::Role also offers two role specific keyword exports:
 215
 216 =over 4
 217
 218 =item B<requires (@method_names)>
 219
 220 =item B<excludes (@role_names)>
 221
 222 =back
 223
 224 =head1 CAVEATS
 225
 226 The role support now has only a few caveats. They are as follows:
 227
 228 =over 4
 229
 230 =item *
 231
 232 Roles cannot use the C<extends> keyword, it will throw an exception for now.
 233 The same is true of the C<augment> and C<inner> keywords (not sure those
 234 really make sense for roles). All other Moose keywords will be I<deferred>
 235 so that they can be applied to the consuming class.
 236
 237 =item *
 238
 239 Role composition does it's best to B<not> be order sensitive when it comes
 240 to conflict resolution and requirements detection. However, it is order
 241 sensitive when it comes to method modifiers. All before/around/after modifiers
 242 are included whenever a role is composed into a class, and then are applied
 243 in the order the roles are used. This too means that there is no conflict for
 244 before/around/after modifiers as well.
 245
 246 In most cases, this will be a non issue, however it is something to keep in
 247 mind when using method modifiers in a role. You should never assume any
 248 ordering.
 249
 250 =item *
 251
 252 The C<requires> keyword currently only works with actual methods. A method
 253 modifier (before/around/after and override) will not count as a fufillment
 254 of the requirement, and neither will an autogenerated accessor for an attribute.
 255
 256 It is likely that the attribute accessors will eventually be allowed to fufill
 257 those requirements, either that or we will introduce a C<requires_attr> keyword
 258 of some kind instead. This descision has not yet been finalized.
 259
 260 =back
 261
 262 =head1 BUGS
 263
 264 All complex software has bugs lurking in it, and this module is no
 265 exception. If you find a bug please either email me, or add the bug
 266 to cpan-RT.
 267
 268 =head1 AUTHOR
 269
 270 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 271
 272 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 273
 274 =head1 COPYRIGHT AND LICENSE
 275
 276 Copyright 2006 by Infinity Interactive, Inc.
 277
 278 L<http://www.iinteractive.com>
 279
 280 This library is free software; you can redistribute it and/or modify
 281 it under the same terms as Perl itself.
 282
 283 =cut