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 | |
61 | sub _initialize_body { |
62 | my $self = shift; |
63 | |
64 | $self->{'body'} = $self->_eval_code( $self->_generate_method ); |
65 | |
66 | return; |
67 | } |
68 | |
f5f08b5f |
69 | sub _eval_environment { |
70 | my $self = shift; |
71 | |
72 | my $env = $self->SUPER::_eval_environment; |
73 | |
74 | $env->{'@curried'} = $self->curried_arguments; |
75 | |
76 | return $env; |
77 | } |
78 | |
f7fd22b6 |
79 | 1; |