Commit | Line | Data |
a41c0667 |
1 | package Mouse::Meta::Method::Accessor; |
2 | use strict; |
3 | use warnings; |
7b133c92 |
4 | use Scalar::Util qw(blessed); |
a41c0667 |
5 | |
6 | sub _install_accessor{ |
7 | my (undef, $attribute, $method_name, $class, $type) = @_; |
8 | |
9 | my $name = $attribute->name; |
10 | my $default = $attribute->default; |
11 | my $constraint = $attribute->type_constraint; |
12 | my $builder = $attribute->builder; |
13 | my $trigger = $attribute->trigger; |
14 | my $is_weak = $attribute->is_weak_ref; |
15 | my $should_deref = $attribute->should_auto_deref; |
16 | my $should_coerce = $attribute->should_coerce; |
17 | |
ffbbf459 |
18 | my $compiled_type_constraint = $constraint ? $constraint->_compiled_type_constraint : undef; |
a41c0667 |
19 | |
20 | my $self = '$_[0]'; |
7b133c92 |
21 | my $key = sprintf q{"%s"}, quotemeta $name; |
a41c0667 |
22 | |
23 | $type ||= 'accessor'; |
24 | |
25 | my $accessor = |
26 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
27 | "sub {\n"; |
28 | if ($type eq 'accessor' || $type eq 'writer') { |
29 | if($type eq 'accessor'){ |
30 | $accessor .= |
31 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
32 | 'if (scalar(@_) >= 2) {' . "\n"; |
33 | } |
34 | else{ # writer |
35 | $accessor .= |
36 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
37 | 'if(@_ < 2){ Carp::confess("Not enough arguments for writer '.$method_name.'") }'. |
38 | '{' . "\n"; |
39 | } |
40 | |
41 | my $value = '$_[1]'; |
42 | |
14d7595a |
43 | if (defined $constraint) { |
ffbbf459 |
44 | if(!$compiled_type_constraint){ |
14d7595a |
45 | Carp::confess("[BUG] Missing compiled type constraint for $constraint"); |
ffbbf459 |
46 | } |
a41c0667 |
47 | if ($should_coerce) { |
48 | $accessor .= |
49 | "\n". |
50 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
ffbbf459 |
51 | 'my $val = $constraint->coerce('.$value.');'; |
a41c0667 |
52 | $value = '$val'; |
53 | } |
14d7595a |
54 | $accessor .= |
55 | "\n". |
56 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
57 | 'unless ($compiled_type_constraint->('.$value.')) { |
58 | $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint}); |
59 | }' . "\n"; |
a41c0667 |
60 | } |
61 | |
62 | # if there's nothing left to do for the attribute we can return during |
63 | # this setter |
64 | $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
65 | |
66 | $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n"; |
67 | |
68 | if ($is_weak) { |
69 | $accessor .= 'Scalar::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; |
70 | } |
71 | |
72 | if ($trigger) { |
73 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
74 | } |
75 | |
76 | $accessor .= "}\n"; |
77 | } |
78 | elsif($type eq 'reader') { |
79 | $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n"; |
80 | } |
81 | else{ |
82 | $class->throw_error("Unknown accessor type '$type'"); |
83 | } |
84 | |
85 | if ($attribute->is_lazy) { |
86 | $accessor .= $self.'->{'.$key.'} = '; |
87 | |
14d7595a |
88 | if($should_coerce && defined($constraint)){ |
89 | $accessor .= '$attribute->_coerce_and_verify('; |
90 | } |
91 | $accessor .= $attribute->has_builder ? $self.'->$builder' |
92 | : ref($default) eq 'CODE' ? '$default->('.$self.')' |
93 | : '$default'; |
94 | |
95 | if($should_coerce && defined $constraint){ |
96 | $accessor .= ')'; |
97 | } |
a41c0667 |
98 | $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n"; |
99 | } |
100 | |
101 | if ($should_deref) { |
102 | if ($constraint->is_a_type_of('ArrayRef')) { |
103 | $accessor .= 'if (wantarray) { |
104 | return @{ '.$self.'->{'.$key.'} || [] }; |
105 | }'; |
106 | } |
107 | elsif($constraint->is_a_type_of('HashRef')){ |
108 | $accessor .= 'if (wantarray) { |
109 | return %{ '.$self.'->{'.$key.'} || {} }; |
110 | }'; |
111 | } |
112 | else{ |
113 | $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); |
114 | } |
115 | } |
116 | |
117 | $accessor .= 'return '.$self.'->{'.$key."};\n}"; |
118 | |
119 | #print $accessor, "\n"; |
120 | my $code = eval $accessor; |
121 | $attribute->throw_error($@) if $@; |
122 | |
123 | $class->add_method($method_name => $code); |
124 | return; |
125 | } |
126 | |
127 | sub _install_reader{ |
128 | my $class = shift; |
129 | $class->_install_accessor(@_, 'reader'); |
130 | return; |
131 | } |
132 | |
133 | sub _install_writer{ |
134 | my $class = shift; |
135 | $class->_install_accessor(@_, 'writer'); |
136 | return; |
137 | } |
138 | |
139 | |
140 | sub _install_predicate { |
141 | my (undef, $attribute, $method_name, $class) = @_; |
142 | |
7b133c92 |
143 | my $slot = $attribute->name; |
a41c0667 |
144 | |
7b133c92 |
145 | $class->add_method($method_name => sub{ |
146 | return exists $_[0]->{$slot}; |
147 | }); |
a41c0667 |
148 | return; |
149 | } |
150 | |
151 | sub _install_clearer { |
152 | my (undef, $attribute, $method_name, $class) = @_; |
153 | |
7b133c92 |
154 | my $slot = $attribute->name; |
a41c0667 |
155 | |
7b133c92 |
156 | $class->add_method($method_name => sub{ |
157 | delete $_[0]->{$slot}; |
158 | }); |
a41c0667 |
159 | return; |
160 | } |
161 | |
162 | sub _install_handles { |
163 | my (undef, $attribute, $handles, $class) = @_; |
164 | |
7b133c92 |
165 | my $reader = $attribute->reader || $attribute->accessor |
166 | or $class->throw_error("You must pass a reader method for '".$attribute->name."'"); |
a41c0667 |
167 | |
7b133c92 |
168 | my %handles = $attribute->_canonicalize_handles($handles); |
a41c0667 |
169 | |
7b133c92 |
170 | foreach my $handle_name (keys %handles) { |
171 | my $method_to_call = $handles{$handle_name}; |
172 | |
bc71de54 |
173 | my $code = sub { |
174 | my $instance = shift; |
175 | my $proxy = $instance->$reader(); |
176 | |
177 | my $error = !defined($proxy) ? ' is not defined' |
178 | : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} |
179 | : undef; |
912fa381 |
180 | if ($error) { |
bc71de54 |
181 | $instance->meta->throw_error( |
182 | "Cannot delegate $handle_name to $method_to_call because " |
183 | . "the value of " |
184 | . $attribute->name |
912fa381 |
185 | . $error |
bc71de54 |
186 | ); |
187 | } |
188 | $proxy->$method_to_call(@_); |
7b133c92 |
189 | }; |
190 | $class->add_method($handle_name => $code); |
a41c0667 |
191 | } |
192 | return; |
193 | } |
194 | |
195 | |
196 | 1; |