Commit | Line | Data |
f7fd22b6 |
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.13'; |
10 | $VERSION = eval $VERSION; |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
12 | |
13 | use base 'Moose::Meta::Method::Accessor', 'Moose::Meta::Method::Delegation'; |
14 | |
15 | sub new { |
16 | my $class = shift; |
17 | my %options = @_; |
18 | |
19 | die "Cannot instantiate a $class object directly" |
20 | if $class eq __PACKAGE__; |
21 | |
22 | ( exists $options{attribute} ) |
23 | || confess "You must supply an attribute to construct with"; |
24 | |
25 | ( blessed( $options{attribute} ) |
26 | && $options{attribute}->isa('Class::MOP::Attribute') ) |
27 | || confess |
28 | "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; |
29 | |
30 | ( $options{package_name} && $options{name} ) |
31 | || confess "You must supply the package_name and name parameters"; |
32 | |
33 | exists $options{curried_arguments} |
34 | || ( $options{curried_arguments} = [] ); |
35 | |
36 | ( $options{curried_arguments} |
37 | && ( 'ARRAY' eq ref $options{curried_arguments} ) ) |
38 | || confess |
39 | 'You must supply a curried_arguments which is an ARRAY reference'; |
40 | |
41 | $options{delegate_to_method} = lc( ( split /::/, $class)[-1] ); |
42 | |
f5f08b5f |
43 | $options{definition_context} = $options{attribute}->definition_context; |
44 | |
f7fd22b6 |
45 | my $self = $class->_new( \%options ); |
46 | |
47 | weaken( $self->{'attribute'} ); |
48 | |
49 | $self->_initialize_body; |
50 | |
51 | return $self; |
52 | } |
53 | |
54 | sub _new { |
55 | my $class = shift; |
56 | my $options = @_ == 1 ? $_[0] : {@_}; |
57 | |
58 | return bless $options, $class; |
59 | } |
60 | |
a6ae7438 |
61 | sub root_types { (shift)->{'root_types'} } |
62 | |
f7fd22b6 |
63 | sub _initialize_body { |
64 | my $self = shift; |
65 | |
66 | $self->{'body'} = $self->_eval_code( $self->_generate_method ); |
67 | |
68 | return; |
69 | } |
70 | |
f5f08b5f |
71 | sub _eval_environment { |
72 | my $self = shift; |
73 | |
74 | my $env = $self->SUPER::_eval_environment; |
75 | |
76 | $env->{'@curried'} = $self->curried_arguments; |
77 | |
78 | return $env; |
79 | } |
80 | |
855f4af8 |
81 | sub _inline_curried_arguments { |
82 | my $self = shift; |
83 | |
84 | return q{} unless @{ $self->curried_arguments }; |
85 | |
86 | return 'unshift @_, @curried;' |
87 | } |
88 | |
89 | sub _inline_check_argument_count { |
90 | my $self = shift; |
91 | |
92 | my $code = q{}; |
93 | |
94 | if ( my $min = $self->_minimum_arguments ) { |
95 | my $err_msg = sprintf( |
96 | q{"Cannot call %s without at least %s argument%s"}, |
97 | $self->delegate_to_method, |
98 | $min, |
99 | ( $min == 1 ? q{} : 's' ) |
100 | ); |
101 | |
102 | $code |
103 | .= "\n" |
104 | . $self->_inline_throw_error($err_msg) |
105 | . " unless \@_ >= $min;"; |
106 | } |
107 | |
108 | if ( defined( my $max = $self->_maximum_arguments ) ) { |
109 | my $err_msg = sprintf( |
110 | q{"Cannot call %s with %s argument%s"}, |
111 | $self->delegate_to_method, |
112 | ( $max ? "more than $max" : 'any' ), |
113 | ( $max == 1 ? q{} : 's' ) |
114 | ); |
115 | |
116 | $code |
117 | .= "\n" |
118 | . $self->_inline_throw_error($err_msg) |
119 | . " if \@_ > $max;"; |
120 | } |
121 | |
122 | return $code; |
123 | } |
124 | |
125 | sub _minimum_arguments { 0 } |
126 | sub _maximum_arguments { undef } |
127 | |
128 | sub _inline_check_arguments { q{} } |
129 | |
f7fd22b6 |
130 | 1; |