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 use Try::Tiny;
  10
  11 use base 'Class::MOP::Method::Generated';
  12
  13 sub new {
  14     my $class   = shift;
  15     my %options = @_;
  16
  17     (exists $options{attribute})
  18         || confess "You must supply an attribute to construct with";
  19
  20     (exists $options{accessor_type})
  21         || confess "You must supply an accessor_type to construct with";
  22
  23     (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
  24         || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
  25
  26     ($options{package_name} && $options{name})
  27         || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  28
  29     my $self = $class->_new(\%options);
  30
  31     # we don't want this creating
  32     # a cycle in the code, if not
  33     # needed
  34     weaken($self->{'attribute'});
  35
  36     $self->_initialize_body;
  37
  38     return $self;
  39 }
  40
  41 sub _new {
  42     my $class = shift;
  43
  44     return Class::MOP::Class->initialize($class)->new_object(@_)
  45         if $class ne __PACKAGE__;
  46
  47     my $params = @_ == 1 ? $_[0] : {@_};
  48
  49     return bless {
  50         # inherited from Class::MOP::Method
  51         body                 => $params->{body},
  52         associated_metaclass => $params->{associated_metaclass},
  53         package_name         => $params->{package_name},
  54         name                 => $params->{name},
  55         original_method      => $params->{original_method},
  56
  57         # inherit from Class::MOP::Generated
  58         is_inline            => $params->{is_inline} || 0,
  59         definition_context   => $params->{definition_context},
  60
  61         # defined in this class
  62         attribute            => $params->{attribute},
  63         accessor_type        => $params->{accessor_type},
  64     } => $class;
  65 }
  66
  67 ## accessors
  68
  69 sub associated_attribute { (shift)->{'attribute'}     }
  70 sub accessor_type        { (shift)->{'accessor_type'} }
  71
  72 ## factory
  73
  74 sub _initialize_body {
  75     my $self = shift;
  76
  77     my $method_name = join "_" => (
  78         '_generate',
  79         $self->accessor_type,
  80         'method'
  81     );
  82
  83     $self->{'body'} = $self->$method_name();
  84 }
  85
  86 sub _error_thrower {
  87     my $self = shift;
  88
  89     return $self->associated_attribute
  90         if ref $self
  91             && $self->associated_attribute
  92             && $self->associated_attribute->can('throw_error');
  93
  94     return $self->SUPER::_error_thrower;
  95 }
  96
  97 sub _compile_code {
  98     my $self = shift;
  99     my @args = @_;
 100     try {
 101         $self->SUPER::_compile_code(@args);
 102     }
 103     catch {
 104         $self->throw_error(
 105             'Could not create writer for '
 106           . "'" . $self->associated_attribute->name . "' "
 107           . 'because ' . $_,
 108             error => $_,
 109         );
 110     };
 111 }
 112
 113 sub _eval_environment {
 114     my $self = shift;
 115     return $self->associated_attribute->_eval_environment
 116         if $self->associated_attribute->can('_eval_environment');
 117 }
 118
 119 sub _instance_is_inlinable {
 120     my $self = shift;
 121     return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
 122 }
 123
 124 sub _generate_reader_method {
 125     my $self = shift;
 126     $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
 127                                   : $self->_generate_reader_method_non_inline(@_);
 128 }
 129
 130 sub _generate_writer_method {
 131     my $self = shift;
 132     $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
 133                                   : $self->_generate_writer_method_non_inline(@_);
 134 }
 135
 136 sub _generate_accessor_method {
 137     my $self = shift;
 138     $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
 139                                   : $self->_generate_accessor_method_non_inline(@_);
 140 }
 141
 142 sub _generate_predicate_method {
 143     my $self = shift;
 144     $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
 145                                   : $self->_generate_predicate_method_non_inline(@_);
 146 }
 147
 148 sub _generate_clearer_method {
 149     my $self = shift;
 150     $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
 151                                   : $self->_generate_clearer_method_non_inline(@_);
 152 }
 153
 154 sub _generate_accessor_method_non_inline {
 155     my $self = shift;
 156     my $attr = $self->associated_attribute;
 157
 158     return sub {
 159         if (@_ >= 2) {
 160             $attr->set_value($_[0], $_[1]);
 161         }
 162         $attr->get_value($_[0]);
 163     };
 164 }
 165
 166 sub _generate_accessor_method_inline {
 167     my $self = shift;
 168     my $attr = $self->associated_attribute;
 169
 170     return try {
 171         $self->_compile_code([
 172             'sub {',
 173                 'if (@_ > 1) {',
 174                     $attr->_inline_set_value('$_[0]', '$_[1]'),
 175                 '}',
 176                 $attr->_inline_get_value('$_[0]'),
 177             '}',
 178         ]);
 179     }
 180     catch {
 181         confess "Could not generate inline accessor because : $_";
 182     };
 183 }
 184
 185 sub _generate_reader_method_non_inline {
 186     my $self = shift;
 187     my $attr = $self->associated_attribute;
 188
 189     return sub {
 190         confess "Cannot assign a value to a read-only accessor"
 191             if @_ > 1;
 192         $attr->get_value($_[0]);
 193     };
 194 }
 195
 196 sub _generate_reader_method_inline {
 197     my $self = shift;
 198     my $attr = $self->associated_attribute;
 199
 200     return try {
 201         $self->_compile_code([
 202             'sub {',
 203                 'if (@_ > 1) {',
 204                     # XXX: this is a hack, but our error stuff is terrible
 205                     $self->_inline_throw_error(
 206                         '"Cannot assign a value to a read-only accessor"',
 207                         'data => \@_'
 208                     ) . ';',
 209                 '}',
 210                 $attr->_inline_get_value('$_[0]'),
 211             '}',
 212         ]);
 213     }
 214     catch {
 215         confess "Could not generate inline reader because : $_";
 216     };
 217 }
 218
 219 sub _generate_writer_method_non_inline {
 220     my $self = shift;
 221     my $attr = $self->associated_attribute;
 222
 223     return sub {
 224         $attr->set_value($_[0], $_[1]);
 225     };
 226 }
 227
 228 sub _generate_writer_method_inline {
 229     my $self = shift;
 230     my $attr = $self->associated_attribute;
 231
 232     return try {
 233         $self->_compile_code([
 234             'sub {',
 235                 $attr->_inline_set_value('$_[0]', '$_[1]'),
 236             '}',
 237         ]);
 238     }
 239     catch {
 240         confess "Could not generate inline writer because : $_";
 241     };
 242 }
 243
 244 sub _generate_predicate_method_non_inline {
 245     my $self = shift;
 246     my $attr = $self->associated_attribute;
 247
 248     return sub {
 249         $attr->has_value($_[0])
 250     };
 251 }
 252
 253 sub _generate_predicate_method_inline {
 254     my $self = shift;
 255     my $attr = $self->associated_attribute;
 256
 257     return try {
 258         $self->_compile_code([
 259             'sub {',
 260                 $attr->_inline_has_value('$_[0]'),
 261             '}',
 262         ]);
 263     }
 264     catch {
 265         confess "Could not generate inline predicate because : $_";
 266     };
 267 }
 268
 269 sub _generate_clearer_method_non_inline {
 270     my $self = shift;
 271     my $attr = $self->associated_attribute;
 272
 273     return sub {
 274         $attr->clear_value($_[0])
 275     };
 276 }
 277
 278 sub _generate_clearer_method_inline {
 279     my $self = shift;
 280     my $attr = $self->associated_attribute;
 281
 282     return try {
 283         $self->_compile_code([
 284             'sub {',
 285                 $attr->_inline_clear_value('$_[0]'),
 286             '}',
 287         ]);
 288     }
 289     catch {
 290         confess "Could not generate inline clearer because : $_";
 291     };
 292 }
 293
 294 sub _writer_value_needs_copy {
 295     shift->associated_attribute->_writer_value_needs_copy(@_);
 296 }
 297
 298 sub _inline_tc_code {
 299     shift->associated_attribute->_inline_tc_code(@_);
 300 }
 301
 302 sub _inline_check_coercion {
 303     shift->associated_attribute->_inline_check_coercion(@_);
 304 }
 305
 306 sub _inline_check_constraint {
 307     shift->associated_attribute->_inline_check_constraint(@_);
 308 }
 309
 310 sub _inline_check_lazy {
 311     shift->associated_attribute->_inline_check_lazy(@_);
 312 }
 313
 314 sub _inline_store_value {
 315     shift->associated_attribute->_inline_instance_set(@_) . ';';
 316 }
 317
 318 sub _inline_get_old_value_for_trigger {
 319     shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
 320 }
 321
 322 sub _inline_trigger {
 323     shift->associated_attribute->_inline_trigger(@_);
 324 }
 325
 326 sub _get_value {
 327     shift->associated_attribute->_inline_instance_get(@_);
 328 }
 329
 330 sub _has_value {
 331     shift->associated_attribute->_inline_instance_has(@_);
 332 }
 333
 334 1;
 335
 336 # ABSTRACT: Method Meta Object for accessors
 337
 338 __END__
 339
 340 =pod
 341
 342 =head1 SYNOPSIS
 343
 344     use Class::MOP::Method::Accessor;
 345
 346     my $reader = Class::MOP::Method::Accessor->new(
 347         attribute     => $attribute,
 348         is_inline     => 1,
 349         accessor_type => 'reader',
 350     );
 351
 352     $reader->body->execute($instance); # call the reader method
 353
 354 =head1 DESCRIPTION
 355
 356 This is a subclass of C<Class::MOP::Method> which is used by
 357 C<Class::MOP::Attribute> to generate accessor code. It handles
 358 generation of readers, writers, predicates and clearers. For each type
 359 of method, it can either create a subroutine reference, or actually
 360 inline code by generating a string and C<eval>'ing it.
 361
 362 =head1 METHODS
 363
 364 =over 4
 365
 366 =item B<< Class::MOP::Method::Accessor->new(%options) >>
 367
 368 This returns a new C<Class::MOP::Method::Accessor> based on the
 369 C<%options> provided.
 370
 371 =over 4
 372
 373 =item * attribute
 374
 375 This is the C<Class::MOP::Attribute> for which accessors are being
 376 generated. This option is required.
 377
 378 =item * accessor_type
 379
 380 This is a string which should be one of "reader", "writer",
 381 "accessor", "predicate", or "clearer". This is the type of method
 382 being generated. This option is required.
 383
 384 =item * is_inline
 385
 386 This indicates whether or not the accessor should be inlined. This
 387 defaults to false.
 388
 389 =item * name
 390
 391 The method name (without a package name). This is required.
 392
 393 =item * package_name
 394
 395 The package name for the method. This is required.
 396
 397 =back
 398
 399 =item B<< $metamethod->accessor_type >>
 400
 401 Returns the accessor type which was passed to C<new>.
 402
 403 =item B<< $metamethod->is_inline >>
 404
 405 Returns a boolean indicating whether or not the accessor is inlined.
 406
 407 =item B<< $metamethod->associated_attribute >>
 408
 409 This returns the L<Class::MOP::Attribute> object which was passed to
 410 C<new>.
 411
 412 =item B<< $metamethod->body >>
 413
 414 The method itself is I<generated> when the accessor object is
 415 constructed.
 416
 417 =back
 418
 419 =cut
 420