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