lib/Class/MOP/Method/Accessor.pm

   1
   2 package Class::MOP::Method::Accessor;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'weaken';
   9
  10 our $VERSION   = '0.78';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Method::Generated';
  15
  16 sub new {
  17     my $class   = shift;
  18     my %options = @_;
  19
  20     (exists $options{attribute})
  21         || confess "You must supply an attribute to construct with";
  22
  23     (exists $options{accessor_type})
  24         || confess "You must supply an accessor_type to construct with";
  25
  26     (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
  27         || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
  28
  29     ($options{package_name} && $options{name})
  30         || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  31
  32     my $self = $class->_new(\%options);
  33
  34     # we don't want this creating
  35     # a cycle in the code, if not
  36     # needed
  37     weaken($self->{'attribute'});
  38
  39     $self->_initialize_body;
  40
  41     return $self;
  42 }
  43
  44 sub _new {
  45     my $class = shift;
  46     my $options = @_ == 1 ? $_[0] : {@_};
  47
  48     $options->{is_inline} ||= 0;
  49
  50     return bless $options, $class;
  51 }
  52
  53 ## accessors
  54
  55 sub associated_attribute { (shift)->{'attribute'}     }
  56 sub accessor_type        { (shift)->{'accessor_type'} }
  57
  58 ## factory
  59
  60 sub initialize_body {
  61     warn 'The initialize_body method has been made private.'
  62         . " The public version is deprecated and will be removed in a future release.\n";
  63     goto &_initialize_body;
  64 }
  65
  66 sub _initialize_body {
  67     my $self = shift;
  68
  69     my $method_name = join "_" => (
  70         'generate',
  71         $self->accessor_type,
  72         'method',
  73         ($self->is_inline ? 'inline' : ())
  74     );
  75
  76     eval { $self->{'body'} = $self->$method_name() };
  77     die $@ if $@;
  78 }
  79
  80 ## generators
  81
  82 sub generate_accessor_method {
  83     my $attr = (shift)->associated_attribute;
  84     return sub {
  85         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
  86         $attr->get_value($_[0]);
  87     };
  88 }
  89
  90 sub generate_reader_method {
  91     my $attr = (shift)->associated_attribute;
  92     return sub {
  93         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  94         $attr->get_value($_[0]);
  95     };
  96 }
  97
  98 sub generate_writer_method {
  99     my $attr = (shift)->associated_attribute;
 100     return sub {
 101         $attr->set_value($_[0], $_[1]);
 102     };
 103 }
 104
 105 sub generate_predicate_method {
 106     my $attr = (shift)->associated_attribute;
 107     return sub {
 108         $attr->has_value($_[0])
 109     };
 110 }
 111
 112 sub generate_clearer_method {
 113     my $attr = (shift)->associated_attribute;
 114     return sub {
 115         $attr->clear_value($_[0])
 116     };
 117 }
 118
 119 ## Inline methods
 120
 121
 122 sub generate_accessor_method_inline {
 123     my $self          = shift;
 124     my $attr          = $self->associated_attribute;
 125     my $attr_name     = $attr->name;
 126     my $meta_instance = $attr->associated_class->instance_metaclass;
 127
 128     my $code = $self->_eval_closure(
 129         {},
 130         'sub {'
 131         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 132         . ' if scalar(@_) == 2; '
 133         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 134         . '}'
 135     );
 136     confess "Could not generate inline accessor because : $@" if $@;
 137
 138     return $code;
 139 }
 140
 141 sub generate_reader_method_inline {
 142     my $self          = shift;
 143     my $attr          = $self->associated_attribute;
 144     my $attr_name     = $attr->name;
 145     my $meta_instance = $attr->associated_class->instance_metaclass;
 146
 147      my $code = $self->_eval_closure(
 148          {},
 149         'sub {'
 150         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 151         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 152         . '}'
 153     );
 154     confess "Could not generate inline reader because : $@" if $@;
 155
 156     return $code;
 157 }
 158
 159 sub generate_writer_method_inline {
 160     my $self          = shift;
 161     my $attr          = $self->associated_attribute;
 162     my $attr_name     = $attr->name;
 163     my $meta_instance = $attr->associated_class->instance_metaclass;
 164
 165     my $code = $self->_eval_closure(
 166         {},
 167         'sub {'
 168         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 169         . '}'
 170     );
 171     confess "Could not generate inline writer because : $@" if $@;
 172
 173     return $code;
 174 }
 175
 176
 177 sub generate_predicate_method_inline {
 178     my $self          = shift;
 179     my $attr          = $self->associated_attribute;
 180     my $attr_name     = $attr->name;
 181     my $meta_instance = $attr->associated_class->instance_metaclass;
 182
 183     my $code = $self->_eval_closure(
 184         {},
 185        'sub {'
 186        . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name)
 187        . '}'
 188     );
 189     confess "Could not generate inline predicate because : $@" if $@;
 190
 191     return $code;
 192 }
 193
 194 sub generate_clearer_method_inline {
 195     my $self          = shift;
 196     my $attr          = $self->associated_attribute;
 197     my $attr_name     = $attr->name;
 198     my $meta_instance = $attr->associated_class->instance_metaclass;
 199
 200     my $code = $self->_eval_closure(
 201         {},
 202         'sub {'
 203         . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name)
 204         . '}'
 205     );
 206     confess "Could not generate inline clearer because : $@" if $@;
 207
 208     return $code;
 209 }
 210
 211 1;
 212
 213 __END__
 214
 215 =pod
 216
 217 =head1 NAME
 218
 219 Class::MOP::Method::Accessor - Method Meta Object for accessors
 220
 221 =head1 SYNOPSIS
 222
 223     use Class::MOP::Method::Accessor;
 224
 225     my $reader = Class::MOP::Method::Accessor->new(
 226         attribute     => $attribute,
 227         is_inline     => 1,
 228         accessor_type => 'reader',
 229     );
 230
 231     $reader->body->execute($instance); # call the reader method
 232
 233 =head1 DESCRIPTION
 234
 235 This is a subclass of <Class::MOP::Method> which is used by
 236 C<Class::MOP::Attribute> to generate accessor code. It handles
 237 generation of readers, writers, predicates and clearers. For each type
 238 of method, it can either create a subroutine reference, or actually
 239 inline code by generating a string and C<eval>'ing it.
 240
 241 =head1 METHODS
 242
 243 =over 4
 244
 245 =item B<< Class::MOP::Method::Accessor->new(%options) >>
 246
 247 This returns a new C<Class::MOP::Method::Accessor> based on the
 248 C<%options> provided.
 249
 250 =over 4
 251
 252 =item * attribute
 253
 254 This is the C<Class::MOP::Attribute> for which accessors are being
 255 generated. This option is required.
 256
 257 =item * accessor_type
 258
 259 This is a string which should be one of "reader", "writer",
 260 "accessor", "predicate", or "clearer". This is the type of method
 261 being generated. This option is required.
 262
 263 =item * is_inline
 264
 265 This indicates whether or not the accessor should be inlined. This
 266 defaults to false.
 267
 268 =item * name
 269
 270 The method name (without a package name). This is required.
 271
 272 =item * package_name
 273
 274 The package name for the method. This is required.
 275
 276 =back
 277
 278 =item B<< $metamethod->accessor_type >>
 279
 280 Returns the accessor type which was passed to C<new>.
 281
 282 =item B<< $metamethod->is_inline >>
 283
 284 Returns a boolean indicating whether or not the accessor is inlined.
 285
 286 =item B<< $metamethod->associated_attribute >>
 287
 288 This returns the L<Class::MOP::Attribute> object which was passed to
 289 C<new>.
 290
 291 =item B<< $metamethod->body >>
 292
 293 The method itself is I<generated> when the accessor object is
 294 constructed.
 295
 296 =back
 297
 298 =head1 AUTHORS
 299
 300 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 301
 302 =head1 COPYRIGHT AND LICENSE
 303
 304 Copyright 2006-2009 by Infinity Interactive, Inc.
 305
 306 L<http://www.iinteractive.com>
 307
 308 This library is free software; you can redistribute it and/or modify
 309 it under the same terms as Perl itself.
 310
 311 =cut
 312