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         ($self->is_inline ? 'inline' : ())
  82     );
  83
  84     $self->{'body'} = $self->$method_name();
  85 }
  86
  87 ## generators
  88
  89 sub _generate_accessor_method {
  90     my $self = shift;
  91     my $attr = $self->associated_attribute;
  92
  93     return sub {
  94         if (@_ >= 2) {
  95             $attr->set_value($_[0], $_[1]);
  96         }
  97         $attr->get_value($_[0]);
  98     };
  99 }
 100
 101 sub _generate_accessor_method_inline {
 102     my $self = shift;
 103     my $attr = $self->associated_attribute;
 104
 105     return try {
 106         $self->_compile_code([
 107             'sub {',
 108                 'if (@_ > 1) {',
 109                     $attr->_inline_set_value('$_[0]', '$_[1]'),
 110                 '}',
 111                 $attr->_inline_get_value('$_[0]'),
 112             '}',
 113         ]);
 114     }
 115     catch {
 116         confess "Could not generate inline accessor because : $_";
 117     };
 118 }
 119
 120 sub _generate_reader_method {
 121     my $self = shift;
 122     my $attr = $self->associated_attribute;
 123
 124     return sub {
 125         confess "Cannot assign a value to a read-only accessor"
 126             if @_ > 1;
 127         $attr->get_value($_[0]);
 128     };
 129 }
 130
 131 sub _generate_reader_method_inline {
 132     my $self = shift;
 133     my $attr = $self->associated_attribute;
 134
 135     return try {
 136         $self->_compile_code([
 137             'sub {',
 138                 'if (@_ > 1) {',
 139                     # XXX: this is a hack, but our error stuff is terrible
 140                     $self->_inline_throw_error(
 141                         '"Cannot assign a value to a read-only accessor"',
 142                         'data => \@_'
 143                     ) . ';',
 144                 '}',
 145                 $attr->_inline_get_value('$_[0]'),
 146             '}',
 147         ]);
 148     }
 149     catch {
 150         confess "Could not generate inline reader because : $_";
 151     };
 152 }
 153
 154 sub _inline_throw_error {
 155     my $self = shift;
 156     return 'confess ' . $_[0];
 157 }
 158
 159 sub _generate_writer_method {
 160     my $self = shift;
 161     my $attr = $self->associated_attribute;
 162
 163     return sub {
 164         $attr->set_value($_[0], $_[1]);
 165     };
 166 }
 167
 168 sub _generate_writer_method_inline {
 169     my $self = shift;
 170     my $attr = $self->associated_attribute;
 171
 172     return try {
 173         $self->_compile_code([
 174             'sub {',
 175                 $attr->_inline_set_value('$_[0]', '$_[1]'),
 176             '}',
 177         ]);
 178     }
 179     catch {
 180         confess "Could not generate inline writer because : $_";
 181     };
 182 }
 183
 184 sub _generate_predicate_method {
 185     my $self = shift;
 186     my $attr = $self->associated_attribute;
 187
 188     return sub {
 189         $attr->has_value($_[0])
 190     };
 191 }
 192
 193 sub _generate_predicate_method_inline {
 194     my $self = shift;
 195     my $attr = $self->associated_attribute;
 196
 197     return try {
 198         $self->_compile_code([
 199             'sub {',
 200                 $attr->_inline_has_value('$_[0]'),
 201             '}',
 202         ]);
 203     }
 204     catch {
 205         confess "Could not generate inline predicate because : $_";
 206     };
 207 }
 208
 209 sub _generate_clearer_method {
 210     my $self = shift;
 211     my $attr = $self->associated_attribute;
 212
 213     return sub {
 214         $attr->clear_value($_[0])
 215     };
 216 }
 217
 218 sub _generate_clearer_method_inline {
 219     my $self = shift;
 220     my $attr = $self->associated_attribute;
 221
 222     return try {
 223         $self->_compile_code([
 224             'sub {',
 225                 $attr->_inline_clear_value('$_[0]'),
 226             '}',
 227         ]);
 228     }
 229     catch {
 230         confess "Could not generate inline clearer because : $_";
 231     };
 232 }
 233
 234 1;
 235
 236 # ABSTRACT: Method Meta Object for accessors
 237
 238 __END__
 239
 240 =pod
 241
 242 =head1 SYNOPSIS
 243
 244     use Class::MOP::Method::Accessor;
 245
 246     my $reader = Class::MOP::Method::Accessor->new(
 247         attribute     => $attribute,
 248         is_inline     => 1,
 249         accessor_type => 'reader',
 250     );
 251
 252     $reader->body->execute($instance); # call the reader method
 253
 254 =head1 DESCRIPTION
 255
 256 This is a subclass of C<Class::MOP::Method> which is used by
 257 C<Class::MOP::Attribute> to generate accessor code. It handles
 258 generation of readers, writers, predicates and clearers. For each type
 259 of method, it can either create a subroutine reference, or actually
 260 inline code by generating a string and C<eval>'ing it.
 261
 262 =head1 METHODS
 263
 264 =over 4
 265
 266 =item B<< Class::MOP::Method::Accessor->new(%options) >>
 267
 268 This returns a new C<Class::MOP::Method::Accessor> based on the
 269 C<%options> provided.
 270
 271 =over 4
 272
 273 =item * attribute
 274
 275 This is the C<Class::MOP::Attribute> for which accessors are being
 276 generated. This option is required.
 277
 278 =item * accessor_type
 279
 280 This is a string which should be one of "reader", "writer",
 281 "accessor", "predicate", or "clearer". This is the type of method
 282 being generated. This option is required.
 283
 284 =item * is_inline
 285
 286 This indicates whether or not the accessor should be inlined. This
 287 defaults to false.
 288
 289 =item * name
 290
 291 The method name (without a package name). This is required.
 292
 293 =item * package_name
 294
 295 The package name for the method. This is required.
 296
 297 =back
 298
 299 =item B<< $metamethod->accessor_type >>
 300
 301 Returns the accessor type which was passed to C<new>.
 302
 303 =item B<< $metamethod->is_inline >>
 304
 305 Returns a boolean indicating whether or not the accessor is inlined.
 306
 307 =item B<< $metamethod->associated_attribute >>
 308
 309 This returns the L<Class::MOP::Attribute> object which was passed to
 310 C<new>.
 311
 312 =item B<< $metamethod->body >>
 313
 314 The method itself is I<generated> when the accessor object is
 315 constructed.
 316
 317 =back
 318
 319 =cut
 320