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.25';
  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     exists $options{curried_arguments}
  21         || ( $options{curried_arguments} = [] );
  22
  23     ( $options{curried_arguments}
  24             && ( 'ARRAY' eq ref $options{curried_arguments} ) )
  25         || confess
  26         'You must supply a curried_arguments which is an ARRAY reference';
  27
  28     $options{definition_context} = $options{attribute}->definition_context;
  29
  30     $options{accessor_type} = 'native';
  31
  32     return $class->$orig(%options);
  33 };
  34
  35 around _new => sub {
  36     shift;
  37     my $class = shift;
  38     my $options = @_ == 1 ? $_[0] : {@_};
  39
  40     return bless $options, $class;
  41 };
  42
  43 sub root_types { (shift)->{'root_types'} }
  44
  45 sub _initialize_body {
  46     my $self = shift;
  47
  48     $self->{'body'} = $self->_eval_code( $self->_generate_method );
  49
  50     return;
  51 }
  52
  53 sub _inline_curried_arguments {
  54     my $self = shift;
  55
  56     return q{} unless @{ $self->curried_arguments };
  57
  58     return 'unshift @_, @curried;'
  59 }
  60
  61 sub _inline_check_argument_count {
  62     my $self = shift;
  63
  64     my $code = q{};
  65
  66     if ( my $min = $self->_minimum_arguments ) {
  67         my $err_msg = sprintf(
  68             q{"Cannot call %s without at least %s argument%s"},
  69             $self->delegate_to_method,
  70             $min,
  71             ( $min == 1 ? q{} : 's' )
  72         );
  73
  74         $code
  75             .= "\n"
  76             . $self->_inline_throw_error($err_msg)
  77             . " unless \@_ >= $min;";
  78     }
  79
  80     if ( defined( my $max = $self->_maximum_arguments ) ) {
  81         my $err_msg = sprintf(
  82             q{"Cannot call %s with %s argument%s"},
  83             $self->delegate_to_method,
  84             ( $max ? "more than $max" : 'any' ),
  85             ( $max == 1 ? q{} : 's' )
  86         );
  87
  88         $code
  89             .= "\n"
  90             . $self->_inline_throw_error($err_msg)
  91             . " if \@_ > $max;";
  92     }
  93
  94     return $code;
  95 }
  96
  97 sub _minimum_arguments { 0 }
  98 sub _maximum_arguments { undef }
  99
 100 override _inline_get => sub {
 101     my ( $self, $instance ) = @_;
 102
 103     return $self->_slot_access_can_be_inlined
 104         ? super()
 105         : "${instance}->\$reader";
 106 };
 107
 108 override _inline_store => sub {
 109     my ( $self, $instance, $value ) = @_;
 110
 111     return $self->_slot_access_can_be_inlined
 112         ? super()
 113         : "${instance}->\$writer($value)";
 114 };
 115
 116 override _eval_environment => sub {
 117     my $self = shift;
 118
 119     my $env = super();
 120
 121     $env->{'@curried'} = $self->curried_arguments;
 122
 123     return $env if $self->_slot_access_can_be_inlined;
 124
 125     my $reader = $self->associated_attribute->get_read_method_ref;
 126     $reader = $reader->body if blessed $reader;
 127
 128     $env->{'$reader'} = \$reader;
 129
 130     my $writer = $self->associated_attribute->get_write_method_ref;
 131     $writer = $writer->body if blessed $writer;
 132
 133     $env->{'$writer'} = \$writer;
 134
 135     return $env;
 136 };
 137
 138 sub _slot_access_can_be_inlined {
 139     my $self = shift;
 140
 141     return $self->is_inline && $self->_instance_is_inlinable;
 142 }
 143
 144 no Moose::Role;
 145
 146 1;