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