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         has => sub {
  79             my $meta = _find_meta();
  80             return subname 'Moose::Role::has' => sub {
  81                         my ($name, %options) = @_;
  82                         $meta->add_attribute($name, %options)
  83                 };
  84             },
  85         before => sub {
  86             my $meta = _find_meta();
  87             return subname 'Moose::Role::before' => sub {
  88                         my $code = pop @_;
  89                         $meta->add_before_method_modifier($_, $code) for @_;
  90                 };
  91             },
  92         after => sub {
  93             my $meta = _find_meta();
  94             return subname 'Moose::Role::after' => sub {
  95                         my $code = pop @_;
  96                         $meta->add_after_method_modifier($_, $code) for @_;
  97                 };
  98             },
  99         around => sub {
 100             my $meta = _find_meta();
 101             return subname 'Moose::Role::around' => sub {
 102                         my $code = pop @_;
 103                         $meta->add_around_method_modifier($_, $code) for @_;
 104                 };
 105             },
 106             super => sub {
 107             my $meta = _find_meta();
 108             return subname 'Moose::Role::super' => sub {};
 109         },
 110         override => sub {
 111             my $meta = _find_meta();
 112             return subname 'Moose::Role::override' => sub {
 113                 my ($name, $code) = @_;
 114                         $meta->add_override_method_modifier($name, $code);
 115                 };
 116             },
 117         inner => sub {
 118             my $meta = _find_meta();
 119             return subname 'Moose::Role::inner' => sub {
 120                 confess "Moose::Role does not currently support 'inner'";
 121                 };
 122             },
 123         augment => sub {
 124             my $meta = _find_meta();
 125             return subname 'Moose::Role::augment' => sub {
 126                 confess "Moose::Role does not currently support 'augment'";
 127                 };
 128             },
 129         confess => sub {
 130             return \&Carp::confess;
 131         },
 132         blessed => sub {
 133             return \&Scalar::Util::blessed;
 134         }
 135         );
 136
 137     my $exporter = Sub::Exporter::build_exporter({
 138         exports => \%exports,
 139         groups  => {
 140             default => [':all']
 141         }
 142     });
 143
 144     sub import {
 145         $CALLER = caller();
 146
 147         # we should never export to main
 148         return if $CALLER eq 'main';
 149
 150         goto $exporter;
 151     };
 152
 153 }
 154
 155 1;
 156
 157 __END__
 158
 159 =pod
 160
 161 =head1 NAME
 162
 163 Moose::Role - The Moose Role
 164
 165 =head1 SYNOPSIS
 166
 167   package Eq;
 168   use strict;
 169   use warnings;
 170   use Moose::Role;
 171
 172   requires 'equal';
 173
 174   sub no_equal {
 175       my ($self, $other) = @_;
 176       !$self->equal($other);
 177   }
 178
 179   # ... then in your classes
 180
 181   package Currency;
 182   use strict;
 183   use warnings;
 184   use Moose;
 185
 186   with 'Eq';
 187
 188   sub equal {
 189       my ($self, $other) = @_;
 190       $self->as_float == $other->as_float;
 191   }
 192
 193 =head1 DESCRIPTION
 194
 195 This is currently a very early release of Perl 6 style Roles for
 196 Moose, it is still incomplete, but getting much closer. If you are
 197 interested in helping move this feature along, please come to
 198 #moose on irc.perl.org and we can talk.
 199
 200 =head1 CAVEATS
 201
 202 Currently, the role support has a few of caveats. They are as follows:
 203
 204 =over 4
 205
 206 =item *
 207
 208 At this time classes I<cannot> correctly consume more than one role. The
 209 role composition process, and it's conflict detection has not been added
 210 yet. While this should be considered a major feature, it can easily be
 211 worked around, and in many cases, is not needed at all.
 212
 213 A class can actually consume multiple roles, they are just applied one
 214 after another in the order you ask for them. This is incorrect behavior,
 215 the roles should be merged first, and conflicts determined, etc. However,
 216 if your roles do not have any conflicts, then things will work just
 217 fine. This actually tends to be quite sufficient for basic roles.
 218
 219 =item *
 220
 221 Roles cannot use the C<extends> keyword, it will throw an exception for now.
 222 The same is true of the C<augment> and C<inner> keywords (not sure those
 223 really make sense for roles). All other Moose keywords will be I<deferred>
 224 so that they can be applied to the consuming class.
 225
 226 =back
 227
 228 =head1 BUGS
 229
 230 All complex software has bugs lurking in it, and this module is no
 231 exception. If you find a bug please either email me, or add the bug
 232 to cpan-RT.
 233
 234 =head1 AUTHOR
 235
 236 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 237
 238 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 239
 240 =head1 COPYRIGHT AND LICENSE
 241
 242 Copyright 2006 by Infinity Interactive, Inc.
 243
 244 L<http://www.iinteractive.com>
 245
 246 This library is free software; you can redistribute it and/or modify
 247 it under the same terms as Perl itself.
 248
 249 =cut