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