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