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.03';
  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 This is currently a very early release of Perl 6 style Roles for
 202 Moose, it is still incomplete, but getting much closer. If you are
 203 interested in helping move this feature along, please come to
 204 #moose on irc.perl.org and we can talk.
 205
 206 =head1 CAVEATS
 207
 208 Currently, the role support has a few of caveats. They are as follows:
 209
 210 =over 4
 211
 212 =item *
 213
 214 At this time classes I<cannot> correctly consume more than one role. The
 215 role composition process, and it's conflict detection has not been added
 216 yet. While this should be considered a major feature, it can easily be
 217 worked around, and in many cases, is not needed at all.
 218
 219 A class can actually consume multiple roles, they are just applied one
 220 after another in the order you ask for them. This is incorrect behavior,
 221 the roles should be merged first, and conflicts determined, etc. However,
 222 if your roles do not have any conflicts, then things will work just
 223 fine. This actually tends to be quite sufficient for basic roles.
 224
 225 =item *
 226
 227 Roles cannot use the C<extends> keyword, it will throw an exception for now.
 228 The same is true of the C<augment> and C<inner> keywords (not sure those
 229 really make sense for roles). All other Moose keywords will be I<deferred>
 230 so that they can be applied to the consuming class.
 231
 232 =back
 233
 234 =head1 BUGS
 235
 236 All complex software has bugs lurking in it, and this module is no
 237 exception. If you find a bug please either email me, or add the bug
 238 to cpan-RT.
 239
 240 =head1 AUTHOR
 241
 242 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 243
 244 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 245
 246 =head1 COPYRIGHT AND LICENSE
 247
 248 Copyright 2006 by Infinity Interactive, Inc.
 249
 250 L<http://www.iinteractive.com>
 251
 252 This library is free software; you can redistribute it and/or modify
 253 it under the same terms as Perl itself.
 254
 255 =cut