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 | |
43 | if ($constraint) { |
ffbbf459 |
44 | if(!$compiled_type_constraint){ |
45 | Carp::confess("[BUG]Missing compiled type constraint for $constraint"); |
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 | } |
54 | if ($compiled_type_constraint) { |
55 | $accessor .= |
56 | "\n". |
57 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
58 | 'unless ($compiled_type_constraint->('.$value.')) { |
59 | $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint}); |
60 | }' . "\n"; |
61 | } else { |
62 | $accessor .= |
63 | "\n". |
64 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
65 | 'unless ($constraint->check('.$value.')) { |
66 | $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint}); |
67 | }' . "\n"; |
68 | } |
69 | } |
70 | |
71 | # if there's nothing left to do for the attribute we can return during |
72 | # this setter |
73 | $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
74 | |
75 | $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n"; |
76 | |
77 | if ($is_weak) { |
78 | $accessor .= 'Scalar::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; |
79 | } |
80 | |
81 | if ($trigger) { |
82 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
83 | } |
84 | |
85 | $accessor .= "}\n"; |
86 | } |
87 | elsif($type eq 'reader') { |
88 | $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n"; |
89 | } |
90 | else{ |
91 | $class->throw_error("Unknown accessor type '$type'"); |
92 | } |
93 | |
94 | if ($attribute->is_lazy) { |
95 | $accessor .= $self.'->{'.$key.'} = '; |
96 | |
97 | $accessor .= $attribute->has_builder |
98 | ? $self.'->$builder' |
99 | : ref($default) eq 'CODE' |
100 | ? '$default->('.$self.')' |
101 | : '$default'; |
102 | $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n"; |
103 | } |
104 | |
105 | if ($should_deref) { |
106 | if ($constraint->is_a_type_of('ArrayRef')) { |
107 | $accessor .= 'if (wantarray) { |
108 | return @{ '.$self.'->{'.$key.'} || [] }; |
109 | }'; |
110 | } |
111 | elsif($constraint->is_a_type_of('HashRef')){ |
112 | $accessor .= 'if (wantarray) { |
113 | return %{ '.$self.'->{'.$key.'} || {} }; |
114 | }'; |
115 | } |
116 | else{ |
117 | $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); |
118 | } |
119 | } |
120 | |
121 | $accessor .= 'return '.$self.'->{'.$key."};\n}"; |
122 | |
123 | #print $accessor, "\n"; |
124 | my $code = eval $accessor; |
125 | $attribute->throw_error($@) if $@; |
126 | |
127 | $class->add_method($method_name => $code); |
128 | return; |
129 | } |
130 | |
131 | sub _install_reader{ |
132 | my $class = shift; |
133 | $class->_install_accessor(@_, 'reader'); |
134 | return; |
135 | } |
136 | |
137 | sub _install_writer{ |
138 | my $class = shift; |
139 | $class->_install_accessor(@_, 'writer'); |
140 | return; |
141 | } |
142 | |
143 | |
144 | sub _install_predicate { |
145 | my (undef, $attribute, $method_name, $class) = @_; |
146 | |
7b133c92 |
147 | my $slot = $attribute->name; |
a41c0667 |
148 | |
7b133c92 |
149 | $class->add_method($method_name => sub{ |
150 | return exists $_[0]->{$slot}; |
151 | }); |
a41c0667 |
152 | return; |
153 | } |
154 | |
155 | sub _install_clearer { |
156 | my (undef, $attribute, $method_name, $class) = @_; |
157 | |
7b133c92 |
158 | my $slot = $attribute->name; |
a41c0667 |
159 | |
7b133c92 |
160 | $class->add_method($method_name => sub{ |
161 | delete $_[0]->{$slot}; |
162 | }); |
a41c0667 |
163 | return; |
164 | } |
165 | |
166 | sub _install_handles { |
167 | my (undef, $attribute, $handles, $class) = @_; |
168 | |
7b133c92 |
169 | my $reader = $attribute->reader || $attribute->accessor |
170 | or $class->throw_error("You must pass a reader method for '".$attribute->name."'"); |
a41c0667 |
171 | |
7b133c92 |
172 | my %handles = $attribute->_canonicalize_handles($handles); |
a41c0667 |
173 | |
7b133c92 |
174 | foreach my $handle_name (keys %handles) { |
175 | my $method_to_call = $handles{$handle_name}; |
176 | |
bc71de54 |
177 | my $code = sub { |
178 | my $instance = shift; |
179 | my $proxy = $instance->$reader(); |
180 | |
181 | my $error = !defined($proxy) ? ' is not defined' |
182 | : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} |
183 | : undef; |
912fa381 |
184 | if ($error) { |
bc71de54 |
185 | $instance->meta->throw_error( |
186 | "Cannot delegate $handle_name to $method_to_call because " |
187 | . "the value of " |
188 | . $attribute->name |
912fa381 |
189 | . $error |
bc71de54 |
190 | ); |
191 | } |
192 | $proxy->$method_to_call(@_); |
7b133c92 |
193 | }; |
194 | $class->add_method($handle_name => $code); |
a41c0667 |
195 | } |
196 | return; |
197 | } |
198 | |
199 | |
200 | 1; |