lib/Moose/Meta/Method/Accessor/Native.pm

   1 package Moose::Meta::Method::Accessor::Native;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw( confess );
   7 use Scalar::Util qw( blessed weaken );
   8
   9 our $VERSION = '1.9900';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use Moose::Role;
  14
  15 around new => sub {
  16     my $orig = shift;
  17     my $class   = shift;
  18     my %options = @_;
  19
  20     $options{curried_arguments} = []
  21         unless exists $options{curried_arguments};
  22
  23     confess 'You must supply a curried_arguments which is an ARRAY reference'
  24         unless $options{curried_arguments}
  25             && ref($options{curried_arguments}) eq 'ARRAY';
  26
  27     $options{definition_context} = $options{attribute}->definition_context;
  28
  29     $options{accessor_type} = 'native';
  30
  31     return $class->$orig(%options);
  32 };
  33
  34 sub _new {
  35     my $class = shift;
  36     my $options = @_ == 1 ? $_[0] : {@_};
  37
  38     return bless $options, $class;
  39 }
  40
  41 sub root_types { (shift)->{'root_types'} }
  42
  43 sub _initialize_body {
  44     my $self = shift;
  45
  46     $self->{'body'} = $self->_compile_code( [$self->_generate_method] );
  47
  48     return;
  49 }
  50
  51 sub _inline_curried_arguments {
  52     my $self = shift;
  53
  54     return unless @{ $self->curried_arguments };
  55
  56     return 'unshift @_, @curried;';
  57 }
  58
  59 sub _inline_check_argument_count {
  60     my $self = shift;
  61
  62     my @code;
  63
  64     if (my $min = $self->_minimum_arguments) {
  65         push @code, (
  66             'if (@_ < ' . $min . ') {',
  67                 $self->_inline_throw_error(
  68                     sprintf(
  69                         '"Cannot call %s without at least %s argument%s"',
  70                         $self->delegate_to_method,
  71                         $min,
  72                         ($min == 1 ? '' : 's'),
  73                     )
  74                 ) . ';',
  75             '}',
  76         );
  77     }
  78
  79     if (defined(my $max = $self->_maximum_arguments)) {
  80         push @code, (
  81             'if (@_ > ' . $max . ') {',
  82                 $self->_inline_throw_error(
  83                     sprintf(
  84                         '"Cannot call %s with %s argument%s"',
  85                         $self->delegate_to_method,
  86                         $max ? "more than $max" : 'any',
  87                         ($max == 1 ? '' : 's'),
  88                     )
  89                 ) . ';',
  90             '}',
  91         );
  92     }
  93
  94     return @code;
  95 }
  96
  97 sub _inline_return_value {
  98     my $self = shift;
  99     my ($slot_access, $for_writer) = @_;
 100
 101     return 'return ' . $self->_return_value($slot_access, $for_writer) . ';';
 102 }
 103
 104 sub _minimum_arguments { 0 }
 105 sub _maximum_arguments { undef }
 106
 107 override _get_value => sub {
 108     my $self = shift;
 109     my ($instance) = @_;
 110
 111     return $self->_slot_access_can_be_inlined
 112         ? super()
 113         : $instance . '->$reader';
 114 };
 115
 116 override _inline_store_value => sub {
 117     my $self = shift;
 118     my ($instance, $value) = @_;
 119
 120     return $self->_slot_access_can_be_inlined
 121         ? super()
 122         : $instance . '->$writer(' . $value . ');';
 123 };
 124
 125 override _eval_environment => sub {
 126     my $self = shift;
 127
 128     my $env = super();
 129
 130     $env->{'@curried'} = $self->curried_arguments;
 131
 132     return $env if $self->_slot_access_can_be_inlined;
 133
 134     my $reader = $self->associated_attribute->get_read_method_ref;
 135     $reader = $reader->body if blessed $reader;
 136
 137     $env->{'$reader'} = \$reader;
 138
 139     my $writer = $self->associated_attribute->get_write_method_ref;
 140     $writer = $writer->body if blessed $writer;
 141
 142     $env->{'$writer'} = \$writer;
 143
 144     return $env;
 145 };
 146
 147 sub _slot_access_can_be_inlined {
 148     my $self = shift;
 149
 150     return $self->is_inline && $self->_instance_is_inlinable;
 151 }
 152
 153 no Moose::Role;
 154
 155 1;