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.94';
  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     return $self;
  40 }
  41
  42 sub _new {
  43     my $class = shift;
  44
  45     return Class::MOP::Class->initialize($class)->new_object(@_)
  46         if $class ne __PACKAGE__;
  47
  48     my $params = @_ == 1 ? $_[0] : {@_};
  49
  50     return bless {
  51         # inherited from Class::MOP::Method
  52         body                 => $params->{body},
  53         associated_metaclass => $params->{associated_metaclass},
  54         package_name         => $params->{package_name},
  55         name                 => $params->{name},
  56         original_method      => $params->{original_method},
  57
  58         # inherit from Class::MOP::Generated
  59         is_inline            => $params->{is_inline} || 0,
  60         definition_context   => $params->{definition_context},
  61
  62         # defined in this class
  63         attribute            => $params->{attribute},
  64         accessor_type        => $params->{accessor_type},
  65     } => $class;
  66 }
  67
  68 ## accessors
  69
  70 sub associated_attribute { (shift)->{'attribute'}     }
  71 sub accessor_type        { (shift)->{'accessor_type'} }
  72
  73 ## factory
  74
  75 sub _initialize_body {
  76     my $self = shift;
  77
  78     my $method_name = join "_" => (
  79         '_generate',
  80         $self->accessor_type,
  81         'method',
  82         ($self->is_inline ? 'inline' : ())
  83     );
  84
  85     $self->{'body'} = $self->$method_name();
  86 }
  87
  88 ## generators
  89
  90 sub _generate_accessor_method {
  91     my $attr = (shift)->associated_attribute;
  92     return sub {
  93         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
  94         $attr->get_value($_[0]);
  95     };
  96 }
  97
  98 sub _generate_reader_method {
  99     my $attr = (shift)->associated_attribute;
 100     return sub {
 101         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
 102         $attr->get_value($_[0]);
 103     };
 104 }
 105
 106
 107 sub _generate_writer_method {
 108     my $attr = (shift)->associated_attribute;
 109     return sub {
 110         $attr->set_value($_[0], $_[1]);
 111     };
 112 }
 113
 114 sub _generate_predicate_method {
 115     my $attr = (shift)->associated_attribute;
 116     return sub {
 117         $attr->has_value($_[0])
 118     };
 119 }
 120
 121 sub _generate_clearer_method {
 122     my $attr = (shift)->associated_attribute;
 123     return sub {
 124         $attr->clear_value($_[0])
 125     };
 126 }
 127
 128 ## Inline methods
 129
 130 sub _generate_accessor_method_inline {
 131     my $self          = shift;
 132     my $attr          = $self->associated_attribute;
 133     my $attr_name     = $attr->name;
 134     my $meta_instance = $attr->associated_class->instance_metaclass;
 135
 136     my ( $code, $e ) = $self->_eval_closure(
 137         {},
 138         'sub {'
 139         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 140         . ' if scalar(@_) == 2; '
 141         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 142         . '}'
 143     );
 144     confess "Could not generate inline accessor because : $e" if $e;
 145
 146     return $code;
 147 }
 148
 149 sub _generate_reader_method_inline {
 150     my $self          = shift;
 151     my $attr          = $self->associated_attribute;
 152     my $attr_name     = $attr->name;
 153     my $meta_instance = $attr->associated_class->instance_metaclass;
 154
 155      my ( $code, $e ) = $self->_eval_closure(
 156          {},
 157         'sub {'
 158         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 159         . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
 160         . '}'
 161     );
 162     confess "Could not generate inline reader because : $e" if $e;
 163
 164     return $code;
 165 }
 166
 167 sub _generate_writer_method_inline {
 168     my $self          = shift;
 169     my $attr          = $self->associated_attribute;
 170     my $attr_name     = $attr->name;
 171     my $meta_instance = $attr->associated_class->instance_metaclass;
 172
 173     my ( $code, $e ) = $self->_eval_closure(
 174         {},
 175         'sub {'
 176         . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
 177         . '}'
 178     );
 179     confess "Could not generate inline writer because : $e" if $e;
 180
 181     return $code;
 182 }
 183
 184 sub _generate_predicate_method_inline {
 185     my $self          = shift;
 186     my $attr          = $self->associated_attribute;
 187     my $attr_name     = $attr->name;
 188     my $meta_instance = $attr->associated_class->instance_metaclass;
 189
 190     my ( $code, $e ) = $self->_eval_closure(
 191         {},
 192        'sub {'
 193        . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name)
 194        . '}'
 195     );
 196     confess "Could not generate inline predicate because : $e" if $e;
 197
 198     return $code;
 199 }
 200
 201 sub _generate_clearer_method_inline {
 202     my $self          = shift;
 203     my $attr          = $self->associated_attribute;
 204     my $attr_name     = $attr->name;
 205     my $meta_instance = $attr->associated_class->instance_metaclass;
 206
 207     my ( $code, $e ) = $self->_eval_closure(
 208         {},
 209         'sub {'
 210         . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name)
 211         . '}'
 212     );
 213     confess "Could not generate inline clearer because : $e" if $e;
 214
 215     return $code;
 216 }
 217
 218 1;
 219
 220 __END__
 221
 222 =pod
 223
 224 =head1 NAME
 225
 226 Class::MOP::Method::Accessor - Method Meta Object for accessors
 227
 228 =head1 SYNOPSIS
 229
 230     use Class::MOP::Method::Accessor;
 231
 232     my $reader = Class::MOP::Method::Accessor->new(
 233         attribute     => $attribute,
 234         is_inline     => 1,
 235         accessor_type => 'reader',
 236     );
 237
 238     $reader->body->execute($instance); # call the reader method
 239
 240 =head1 DESCRIPTION
 241
 242 This is a subclass of <Class::MOP::Method> which is used by
 243 C<Class::MOP::Attribute> to generate accessor code. It handles
 244 generation of readers, writers, predicates and clearers. For each type
 245 of method, it can either create a subroutine reference, or actually
 246 inline code by generating a string and C<eval>'ing it.
 247
 248 =head1 METHODS
 249
 250 =over 4
 251
 252 =item B<< Class::MOP::Method::Accessor->new(%options) >>
 253
 254 This returns a new C<Class::MOP::Method::Accessor> based on the
 255 C<%options> provided.
 256
 257 =over 4
 258
 259 =item * attribute
 260
 261 This is the C<Class::MOP::Attribute> for which accessors are being
 262 generated. This option is required.
 263
 264 =item * accessor_type
 265
 266 This is a string which should be one of "reader", "writer",
 267 "accessor", "predicate", or "clearer". This is the type of method
 268 being generated. This option is required.
 269
 270 =item * is_inline
 271
 272 This indicates whether or not the accessor should be inlined. This
 273 defaults to false.
 274
 275 =item * name
 276
 277 The method name (without a package name). This is required.
 278
 279 =item * package_name
 280
 281 The package name for the method. This is required.
 282
 283 =back
 284
 285 =item B<< $metamethod->accessor_type >>
 286
 287 Returns the accessor type which was passed to C<new>.
 288
 289 =item B<< $metamethod->is_inline >>
 290
 291 Returns a boolean indicating whether or not the accessor is inlined.
 292
 293 =item B<< $metamethod->associated_attribute >>
 294
 295 This returns the L<Class::MOP::Attribute> object which was passed to
 296 C<new>.
 297
 298 =item B<< $metamethod->body >>
 299
 300 The method itself is I<generated> when the accessor object is
 301 constructed.
 302
 303 =back
 304
 305 =head1 AUTHORS
 306
 307 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 308
 309 =head1 COPYRIGHT AND LICENSE
 310
 311 Copyright 2006-2009 by Infinity Interactive, Inc.
 312
 313 L<http://www.iinteractive.com>
 314
 315 This library is free software; you can redistribute it and/or modify
 316 it under the same terms as Perl itself.
 317
 318 =cut
 319