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             augment  => {},
  30         };
  31     }
  32 ));
  33
  34 sub new {
  35     my $class   = shift;
  36     my %options = @_;
  37     $options{role_meta} = Class::MOP::Class->initialize($options{role_name});
  38     my $self = $class->meta->new_object(%options);
  39     return $self;
  40 }
  41
  42 # NOTE:
  43 # we delegate to some role_meta methods for convience here
  44 # the Moose::Meta::Role is meant to be a read-only interface
  45 # to the underlying role package, if you want to manipulate
  46 # that, just use ->role_meta
  47
  48 sub name    { (shift)->role_meta->name    }
  49 sub version { (shift)->role_meta->version }
  50
  51 sub get_method      { (shift)->role_meta->get_method(@_)  }
  52 sub has_method      { (shift)->role_meta->has_method(@_)  }
  53 sub get_method_list {
  54     my ($self) = @_;
  55     # meta is not applicable in this context,
  56     # if you want to see it use the ->role_meta
  57     grep { !/^meta$/ } $self->role_meta->get_method_list;
  58 }
  59
  60 # ... however the items in statis (attributes & method modifiers)
  61 # can be removed and added to through this API
  62
  63 # attributes
  64
  65 sub add_attribute {
  66     my ($self, $name, %attr_desc) = @_;
  67     $self->get_attribute_map->{$name} = \%attr_desc;
  68 }
  69
  70 sub has_attribute {
  71     my ($self, $name) = @_;
  72     exists $self->get_attribute_map->{$name} ? 1 : 0;
  73 }
  74
  75 sub get_attribute {
  76     my ($self, $name) = @_;
  77     $self->get_attribute_map->{$name}
  78 }
  79
  80 sub remove_attribute {
  81     my ($self, $name) = @_;
  82     delete $self->get_attribute_map->{$name}
  83 }
  84
  85 sub get_attribute_list {
  86     my ($self) = @_;
  87     keys %{$self->get_attribute_map};
  88 }
  89
  90 # method modifiers
  91
  92 sub add_method_modifier {
  93     my ($self, $modifier_type, $method_name, $method) = @_;
  94     $self->get_method_modifier_map->{$modifier_type}->{$method_name} = $method;
  95 }
  96
  97 sub has_method_modifier {
  98     my ($self, $modifier_type, $method_name) = @_;
  99     exists $self->get_method_modifier_map->{$modifier_type}->{$method_name} ? 1 : 0
 100 }
 101
 102 sub get_method_modifier {
 103     my ($self, $modifier_type, $method_name) = @_;
 104     $self->get_method_modifier_map->{$modifier_type}->{$method_name};
 105 }
 106
 107 sub remove_method_modifier {
 108     my ($self, $modifier_type, $method_name) = @_;
 109     delete $self->get_method_modifier_map->{$modifier_type}->{$method_name};
 110 }
 111
 112 sub get_method_modifier_list {
 113     my ($self, $modifier_type) = @_;
 114     keys %{$self->get_method_modifier_map->{$modifier_type}};
 115 }
 116
 117
 118 1;
 119
 120 __END__
 121
 122 =pod
 123
 124 =head1 NAME
 125
 126 Moose::Meta::Role - The Moose Role metaclass
 127
 128 =head1 DESCRIPTION
 129
 130 =head1 METHODS
 131
 132 =over 4
 133
 134 =item B<meta>
 135
 136 =item B<new>
 137
 138 =back
 139
 140 =over 4
 141
 142 =item B<name>
 143
 144 =item B<version>
 145
 146 =item B<role_meta>
 147
 148 =back
 149
 150 =over 4
 151
 152 =item B<get_method>
 153
 154 =item B<has_method>
 155
 156 =item B<get_method_list>
 157
 158 =back
 159
 160 =over 4
 161
 162 =item B<add_attribute>
 163
 164 =item B<has_attribute>
 165
 166 =item B<get_attribute>
 167
 168 =item B<get_attribute_list>
 169
 170 =item B<get_attribute_map>
 171
 172 =item B<remove_attribute>
 173
 174 =back
 175
 176 =over 4
 177
 178 =item B<add_method_modifier>
 179
 180 =item B<get_method_modifier>
 181
 182 =item B<has_method_modifier>
 183
 184 =item B<get_method_modifier_list>
 185
 186 =item B<get_method_modifier_map>
 187
 188 =item B<remove_method_modifier>
 189
 190 =back
 191
 192 =head1 BUGS
 193
 194 All complex software has bugs lurking in it, and this module is no
 195 exception. If you find a bug please either email me, or add the bug
 196 to cpan-RT.
 197
 198 =head1 AUTHOR
 199
 200 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 201
 202 =head1 COPYRIGHT AND LICENSE
 203
 204 Copyright 2006 by Infinity Interactive, Inc.
 205
 206 L<http://www.iinteractive.com>
 207
 208 This library is free software; you can redistribute it and/or modify
 209 it under the same terms as Perl itself.
 210
 211 =cut