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