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