lib/Moose/Meta/Role.pm

   1
   2 package Moose::Meta::Role;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Carp 'confess';
   9
  10 our $VERSION = '0.01';
  11
  12 __PACKAGE__->meta->add_attribute('role_meta' => (
  13     reader => 'role_meta'
  14 ));
  15
  16 __PACKAGE__->meta->add_attribute('attribute_map' => (
  17     reader   => 'get_attribute_map',
  18     default  => sub { {} }
  19 ));
  20
  21 __PACKAGE__->meta->add_attribute('method_modifier_map' => (
  22     reader  => 'get_method_modifier_map',
  23     default => sub {
  24         return {
  25             before   => {},
  26             after    => {},
  27             around   => {},
  28             override => {}
  29         };
  30     }
  31 ));
  32
  33 sub new {
  34     my $class   = shift;
  35     my %options = @_;
  36     $options{role_meta} = Class::MOP::Class->initialize(
  37         $options{role_name},
  38         ':method_metaclass' => 'Moose::Meta::Role::Method'
  39     );
  40     my $self = $class->meta->new_object(%options);
  41     return $self;
  42 }
  43
  44 sub apply {
  45     my ($self, $other) = @_;
  46
  47     foreach my $attribute_name ($self->get_attribute_list) {
  48         # skip it if it has one already
  49         next if $other->has_attribute($attribute_name);
  50         # add it, although it could be overriden
  51         $other->add_attribute(
  52             $attribute_name,
  53             %{$self->get_attribute($attribute_name)}
  54         );
  55     }
  56
  57     foreach my $method_name ($self->get_method_list) {
  58         # skip it if it has one already
  59         next if $other->has_method($method_name);
  60         # add it, although it could be overriden
  61         $other->alias_method(
  62             $method_name,
  63             $self->get_method($method_name)
  64         );
  65     }
  66
  67     foreach my $method_name ($self->get_method_modifier_list('override')) {
  68         # skip it if it has one already
  69         next if $other->has_method($method_name);
  70         # add it, although it could be overriden
  71         $other->add_override_method_modifier(
  72             $method_name,
  73             $self->get_method_modifier('override' => $method_name),
  74             $self->name
  75         );
  76     }
  77
  78     foreach my $method_name ($self->get_method_modifier_list('before')) {
  79         $other->add_before_method_modifier(
  80             $method_name,
  81             $self->get_method_modifier('before' => $method_name)
  82         );
  83     }
  84
  85     foreach my $method_name ($self->get_method_modifier_list('after')) {
  86         $other->add_after_method_modifier(
  87             $method_name,
  88             $self->get_method_modifier('after' => $method_name)
  89         );
  90     }
  91
  92     foreach my $method_name ($self->get_method_modifier_list('around')) {
  93         $other->add_around_method_modifier(
  94             $method_name,
  95             $self->get_method_modifier('around' => $method_name)
  96         );
  97     }
  98
  99 }
 100
 101 # NOTE:
 102 # we delegate to some role_meta methods for convience here
 103 # the Moose::Meta::Role is meant to be a read-only interface
 104 # to the underlying role package, if you want to manipulate
 105 # that, just use ->role_meta
 106
 107 sub name    { (shift)->role_meta->name    }
 108 sub version { (shift)->role_meta->version }
 109
 110 sub get_method      { (shift)->role_meta->get_method(@_)  }
 111 sub has_method      { (shift)->role_meta->has_method(@_)  }
 112 sub get_method_list {
 113     my ($self) = @_;
 114     # meta is not applicable in this context,
 115     # if you want to see it use the ->role_meta
 116     grep { !/^meta$/ } $self->role_meta->get_method_list;
 117 }
 118
 119 # ... however the items in statis (attributes & method modifiers)
 120 # can be removed and added to through this API
 121
 122 # attributes
 123
 124 sub add_attribute {
 125     my ($self, $name, %attr_desc) = @_;
 126     $self->get_attribute_map->{$name} = \%attr_desc;
 127 }
 128
 129 sub has_attribute {
 130     my ($self, $name) = @_;
 131     exists $self->get_attribute_map->{$name} ? 1 : 0;
 132 }
 133
 134 sub get_attribute {
 135     my ($self, $name) = @_;
 136     $self->get_attribute_map->{$name}
 137 }
 138
 139 sub remove_attribute {
 140     my ($self, $name) = @_;
 141     delete $self->get_attribute_map->{$name}
 142 }
 143
 144 sub get_attribute_list {
 145     my ($self) = @_;
 146     keys %{$self->get_attribute_map};
 147 }
 148
 149 # method modifiers
 150
 151 sub add_method_modifier {
 152     my ($self, $modifier_type, $method_name, $method) = @_;
 153     $self->get_method_modifier_map->{$modifier_type}->{$method_name} = $method;
 154 }
 155
 156 sub has_method_modifier {
 157     my ($self, $modifier_type, $method_name) = @_;
 158     exists $self->get_method_modifier_map->{$modifier_type}->{$method_name} ? 1 : 0
 159 }
 160
 161 sub get_method_modifier {
 162     my ($self, $modifier_type, $method_name) = @_;
 163     $self->get_method_modifier_map->{$modifier_type}->{$method_name};
 164 }
 165
 166 sub remove_method_modifier {
 167     my ($self, $modifier_type, $method_name) = @_;
 168     delete $self->get_method_modifier_map->{$modifier_type}->{$method_name};
 169 }
 170
 171 sub get_method_modifier_list {
 172     my ($self, $modifier_type) = @_;
 173     keys %{$self->get_method_modifier_map->{$modifier_type}};
 174 }
 175
 176 package Moose::Meta::Role::Method;
 177
 178 use strict;
 179 use warnings;
 180
 181 our $VERSION = '0.01';
 182
 183 use base 'Class::MOP::Method';
 184
 185 1;
 186
 187 __END__
 188
 189 =pod
 190
 191 =head1 NAME
 192
 193 Moose::Meta::Role - The Moose Role metaclass
 194
 195 =head1 DESCRIPTION
 196
 197 =head1 METHODS
 198
 199 =over 4
 200
 201 =item B<meta>
 202
 203 =item B<new>
 204
 205 =item B<apply>
 206
 207 =back
 208
 209 =over 4
 210
 211 =item B<name>
 212
 213 =item B<version>
 214
 215 =item B<role_meta>
 216
 217 =back
 218
 219 =over 4
 220
 221 =item B<get_method>
 222
 223 =item B<has_method>
 224
 225 =item B<get_method_list>
 226
 227 =back
 228
 229 =over 4
 230
 231 =item B<add_attribute>
 232
 233 =item B<has_attribute>
 234
 235 =item B<get_attribute>
 236
 237 =item B<get_attribute_list>
 238
 239 =item B<get_attribute_map>
 240
 241 =item B<remove_attribute>
 242
 243 =back
 244
 245 =over 4
 246
 247 =item B<add_method_modifier>
 248
 249 =item B<get_method_modifier>
 250
 251 =item B<has_method_modifier>
 252
 253 =item B<get_method_modifier_list>
 254
 255 =item B<get_method_modifier_map>
 256
 257 =item B<remove_method_modifier>
 258
 259 =back
 260
 261 =head1 BUGS
 262
 263 All complex software has bugs lurking in it, and this module is no
 264 exception. If you find a bug please either email me, or add the bug
 265 to cpan-RT.
 266
 267 =head1 AUTHOR
 268
 269 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 270
 271 =head1 COPYRIGHT AND LICENSE
 272
 273 Copyright 2006 by Infinity Interactive, Inc.
 274
 275 L<http://www.iinteractive.com>
 276
 277 This library is free software; you can redistribute it and/or modify
 278 it under the same terms as Perl itself.
 279
 280 =cut