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                 };
 101             },
 102         after => sub {
 103             my $meta = _find_meta();
 104             return subname 'Moose::Role::after' => sub (@&) {
 105                 confess "Moose::Role does not currently support 'after'";
 106                 };
 107             },
 108         around => sub {
 109             my $meta = _find_meta();
 110             return subname 'Moose::Role::around' => sub (@&) {
 111                 confess "Moose::Role does not currently support 'around'";
 112                 };
 113             },
 114             super => sub {
 115             my $meta = _find_meta();
 116             return subname 'Moose::Role::super' => sub {
 117                 confess "Moose::Role cannot support 'super'";
 118             };
 119         },
 120         override => sub {
 121             my $meta = _find_meta();
 122             return subname 'Moose::Role::override' => sub ($&) {
 123                 confess "Moose::Role cannot support 'override'";
 124                 };
 125             },
 126         inner => sub {
 127             my $meta = _find_meta();
 128             return subname 'Moose::Role::inner' => sub {
 129                 confess "Moose::Role cannot support 'inner'";
 130                 };
 131             },
 132         augment => sub {
 133             my $meta = _find_meta();
 134             return subname 'Moose::Role::augment' => sub {
 135                 confess "Moose::Role cannot support 'augment'";
 136                 };
 137             },
 138         confess => sub {
 139             return \&Carp::confess;
 140         },
 141         blessed => sub {
 142             return \&Scalar::Util::blessed;
 143         }
 144         );
 145
 146     my $exporter = Sub::Exporter::build_exporter({
 147         exports => \%exports,
 148         groups  => {
 149             default => [':all']
 150         }
 151     });
 152
 153     sub import {
 154         $CALLER = caller();
 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 strict;
 181   use warnings;
 182   use Moose::Role;
 183
 184   requires 'equal';
 185
 186   sub no_equal {
 187       my ($self, $other) = @_;
 188       !$self->equal($other);
 189   }
 190
 191   # ... then in your classes
 192
 193   package Currency;
 194   use strict;
 195   use warnings;
 196   use Moose;
 197
 198   with 'Eq';
 199
 200   sub equal {
 201       my ($self, $other) = @_;
 202       $self->as_float == $other->as_float;
 203   }
 204
 205 =head1 DESCRIPTION
 206
 207 Role support in Moose is coming along quite well. It's best documentation
 208 is still the the test suite, but it is fairly safe to assume Perl 6 style
 209 behavior, and then either refer to the test suite, or ask questions on
 210 #moose if something doesn't quite do what you expect. More complete
 211 documentation is planned and will be included with the next official
 212 (non-developer) release.
 213
 214 =head1 EXPORTED FUNCTIONS
 215
 216 Currently Moose::Role supports all of the functions that L<Moose> exports,
 217 but differs slightly in how some items are handled (see L<CAVEATS> below
 218 for details).
 219
 220 Moose::Role also offers two role specific keyword exports:
 221
 222 =over 4
 223
 224 =item B<requires (@method_names)>
 225
 226 Roles can require that certain methods are implemented by any class which
 227 C<does> the role.
 228
 229 =item B<excludes (@role_names)>
 230
 231 Roles can C<exclude> other roles, in effect saying "I can never be combined
 232 with these C<@role_names>". This is a feature which should not be used
 233 lightly.
 234
 235 =back
 236
 237 =head1 CAVEATS
 238
 239 The role support now has only a few caveats. They are as follows:
 240
 241 =over 4
 242
 243 =item *
 244
 245 Roles cannot use the C<extends> keyword, it will throw an exception for now.
 246 The same is true of the C<augment> and C<inner> keywords (not sure those
 247 really make sense for roles). All other Moose keywords will be I<deferred>
 248 so that they can be applied to the consuming class.
 249
 250 =item *
 251
 252 Role composition does it's best to B<not> be order sensitive when it comes
 253 to conflict resolution and requirements detection. However, it is order
 254 sensitive when it comes to method modifiers. All before/around/after modifiers
 255 are included whenever a role is composed into a class, and then are applied
 256 in the order the roles are used. This too means that there is no conflict for
 257 before/around/after modifiers as well.
 258
 259 In most cases, this will be a non issue, however it is something to keep in
 260 mind when using method modifiers in a role. You should never assume any
 261 ordering.
 262
 263 =item *
 264
 265 The C<requires> keyword currently only works with actual methods. A method
 266 modifier (before/around/after and override) will not count as a fufillment
 267 of the requirement, and neither will an autogenerated accessor for an attribute.
 268
 269 It is likely that the attribute accessors will eventually be allowed to fufill
 270 those requirements, either that or we will introduce a C<requires_attr> keyword
 271 of some kind instead. This descision has not yet been finalized.
 272
 273 =back
 274
 275 =head1 BUGS
 276
 277 All complex software has bugs lurking in it, and this module is no
 278 exception. If you find a bug please either email me, or add the bug
 279 to cpan-RT.
 280
 281 =head1 AUTHOR
 282
 283 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 284
 285 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 286
 287 =head1 COPYRIGHT AND LICENSE
 288
 289 Copyright 2006 by Infinity Interactive, Inc.
 290
 291 L<http://www.iinteractive.com>
 292
 293 This library is free software; you can redistribute it and/or modify
 294 it under the same terms as Perl itself.
 295
 296 =cut