Commit | Line | Data |
fc1d8369 |
1 | package Mouse::Meta::Method::Constructor; |
3821b191 |
2 | use Mouse::Util qw(:meta); # enables strict and warnings |
fc1d8369 |
3 | |
3db78d2a |
4 | sub _inline_create_instance { |
5 | my(undef, $class_expr) = @_; |
6 | return "bless {}, $class_expr"; |
7 | } |
8 | |
9 | sub _inline_slot { |
f8cbb121 |
10 | my(undef, $self_var, $attr_name) = @_; |
11 | return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
12 | } |
13 | |
3db78d2a |
14 | sub _inline_has_slot { |
15 | my($class, $self_var, $attr_name) = @_; |
16 | |
17 | return sprintf 'exists(%s)', $class->_inline_slot($self_var, $attr_name); |
18 | } |
19 | |
20 | sub _inline_get_slot { |
21 | my($class, $self_var, $attr_name) = @_; |
22 | |
23 | return $class->_inline_slot($self_var, $attr_name); |
24 | } |
25 | |
26 | sub _inline_set_slot { |
27 | my($class, $self_var, $attr_name, $rvalue) = @_; |
28 | |
29 | return $class->_inline_slot($self_var, $attr_name) . " = $rvalue"; |
30 | } |
31 | |
32 | sub _inline_weaken_slot { |
33 | my($class, $self_var, $attr_name) = @_; |
34 | |
35 | return sprintf 'Scalar::Util::weaken(%s)', $class->_inline_slot($self_var, $attr_name); |
36 | } |
37 | |
380e1cd7 |
38 | sub _generate_constructor { |
2a464664 |
39 | my ($class, $metaclass, $args) = @_; |
24ad3f66 |
40 | |
7ca5c5fb |
41 | my @attrs = $metaclass->get_all_attributes; |
42 | |
3db78d2a |
43 | my $init_attrs = $class->_generate_processattrs($metaclass, \@attrs); |
7ca5c5fb |
44 | my $buildargs = $class->_generate_BUILDARGS($metaclass); |
3db78d2a |
45 | my $buildall = $class->_generate_BUILDALL($metaclass); |
7ca5c5fb |
46 | |
0bfc7290 |
47 | my @checks = map { $_ && $_->_compiled_type_constraint } |
48 | map { $_->type_constraint } @attrs; |
ad087d11 |
49 | |
3db78d2a |
50 | my $class_name = $metaclass->name; |
51 | my $source = sprintf(<<'END_CONSTRUCTOR', $class_name, __LINE__, __FILE__, $class_name, $buildargs, $class->_inline_create_instance('$class'), $init_attrs, $buildall); |
52 | package %s; |
53 | #line %d "constructor of %s (%s)" |
54 | sub { |
55 | my $class = shift; |
56 | return $class->Mouse::Object::new(@_) |
57 | if $class ne __PACKAGE__; |
0bfc7290 |
58 | # BUILDARGS |
3db78d2a |
59 | %s; |
60 | # create instance |
61 | my $instance = %s; |
0bfc7290 |
62 | # process attributes |
3db78d2a |
63 | %s; |
0bfc7290 |
64 | # BUILDALL |
3db78d2a |
65 | %s; |
66 | return $instance; |
2a464664 |
67 | } |
3db78d2a |
68 | END_CONSTRUCTOR |
0bfc7290 |
69 | #warn $source; |
ad087d11 |
70 | my $code; |
71 | my $e = do{ |
72 | local $@; |
73 | $code = eval $source; |
74 | $@; |
75 | }; |
76 | die $e if $e; |
380e1cd7 |
77 | return $code; |
fc1d8369 |
78 | } |
79 | |
80 | sub _generate_processattrs { |
f8cbb121 |
81 | my ($method_class, $metaclass, $attrs) = @_; |
fc1d8369 |
82 | my @res; |
9df6f0cd |
83 | |
2efc0af1 |
84 | my $has_triggers; |
8801a6e6 |
85 | my $strict = $metaclass->__strict_constructor; |
e128626c |
86 | |
8801a6e6 |
87 | if($strict){ |
e128626c |
88 | push @res, 'my $used = 0;'; |
89 | } |
2efc0af1 |
90 | |
9df6f0cd |
91 | for my $index (0 .. @$attrs - 1) { |
0bfc7290 |
92 | my $code = ''; |
93 | |
c12edd9a |
94 | my $attr = $attrs->[$index]; |
fc1d8369 |
95 | my $key = $attr->name; |
9df6f0cd |
96 | |
0bfc7290 |
97 | my $init_arg = $attr->init_arg; |
98 | my $type_constraint = $attr->type_constraint; |
8aba926d |
99 | my $is_weak_ref = $attr->is_weak_ref; |
0bfc7290 |
100 | my $need_coercion; |
c91862e8 |
101 | |
3db78d2a |
102 | my $instance = '$instance'; |
103 | my $instance_slot = $method_class->_inline_get_slot($instance, $key); |
0bfc7290 |
104 | my $attr_var = "\$attrs[$index]"; |
105 | my $constraint_var; |
c91862e8 |
106 | |
0bfc7290 |
107 | if(defined $type_constraint){ |
108 | $constraint_var = "$attr_var\->{type_constraint}"; |
109 | $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion); |
110 | } |
c91862e8 |
111 | |
0bfc7290 |
112 | $code .= "# initialize $key\n"; |
113 | |
114 | my $post_process = ''; |
115 | if(defined $type_constraint){ |
116 | $post_process .= "\$checks[$index]->($instance_slot)"; |
da23cd4a |
117 | $post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n"; |
0bfc7290 |
118 | } |
8aba926d |
119 | if($is_weak_ref){ |
3db78d2a |
120 | $post_process .= $method_class->_inline_weaken_slot($instance, $key) . " if ref $instance_slot;\n"; |
0bfc7290 |
121 | } |
c91862e8 |
122 | |
0bfc7290 |
123 | if (defined $init_arg) { |
124 | my $value = "\$args->{q{$init_arg}}"; |
c91862e8 |
125 | |
0bfc7290 |
126 | $code .= "if (exists $value) {\n"; |
127 | |
128 | if($need_coercion){ |
620c3203 |
129 | $value = "$constraint_var->coerce($value)"; |
41cdacce |
130 | } |
c91862e8 |
131 | |
3db78d2a |
132 | $code .= $method_class->_inline_set_slot($instance, $key, $value) . ";\n"; |
0bfc7290 |
133 | $code .= $post_process; |
134 | |
9df6f0cd |
135 | if ($attr->has_trigger) { |
2efc0af1 |
136 | $has_triggers++; |
620c3203 |
137 | $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n"; |
fc1d8369 |
138 | } |
c91862e8 |
139 | |
8801a6e6 |
140 | if ($strict){ |
141 | $code .= '++$used;' . "\n"; |
e128626c |
142 | } |
143 | |
144 | $code .= "\n} else {\n"; # $value exists |
9df6f0cd |
145 | } |
c91862e8 |
146 | |
9df6f0cd |
147 | if ($attr->has_default || $attr->has_builder) { |
148 | unless ($attr->is_lazy) { |
149 | my $default = $attr->default; |
150 | my $builder = $attr->builder; |
e8ba7b26 |
151 | |
0bfc7290 |
152 | my $value; |
153 | if (defined($builder)) { |
154 | $value = "\$instance->$builder()"; |
ffbbf459 |
155 | } |
156 | elsif (ref($default) eq 'CODE') { |
0bfc7290 |
157 | $value = "$attr_var\->{default}->(\$instance)"; |
ffbbf459 |
158 | } |
0bfc7290 |
159 | elsif (defined($default)) { |
160 | $value = "$attr_var\->{default}"; |
ffbbf459 |
161 | } |
162 | else { |
0bfc7290 |
163 | $value = 'undef'; |
ffbbf459 |
164 | } |
e8ba7b26 |
165 | |
0bfc7290 |
166 | if($need_coercion){ |
167 | $value = "$constraint_var->coerce($value)"; |
9df6f0cd |
168 | } |
9df6f0cd |
169 | |
3db78d2a |
170 | $code .= $method_class->_inline_set_slot($instance, $key, $value) . ";\n"; |
8aba926d |
171 | if($is_weak_ref){ |
3db78d2a |
172 | $code .= $method_class->_inline_weaken_slot($instance, $key) . ";\n"; |
8aba926d |
173 | } |
fc1d8369 |
174 | } |
713a2a05 |
175 | } |
9df6f0cd |
176 | elsif ($attr->is_required) { |
7756897f |
177 | $code .= "Carp::confess('Attribute ($key) is required');"; |
9df6f0cd |
178 | } |
179 | |
0bfc7290 |
180 | $code .= "}\n" if defined $init_arg; |
9df6f0cd |
181 | |
fc1d8369 |
182 | push @res, $code; |
183 | } |
9df6f0cd |
184 | |
8801a6e6 |
185 | if($strict){ |
e128626c |
186 | push @res, q{if($used < keys %{$args})} |
8801a6e6 |
187 | . sprintf q{{ %s->_report_unknown_args($metaclass, \@attrs, $args) }}, $method_class; |
e128626c |
188 | } |
189 | |
2efc0af1 |
190 | if($metaclass->is_anon_class){ |
a8391b11 |
191 | push @res, q{$instance->{__METACLASS__} = $metaclass;}; |
2efc0af1 |
192 | } |
193 | |
194 | if($has_triggers){ |
195 | unshift @res, q{my @triggers;}; |
e128626c |
196 | push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; |
2efc0af1 |
197 | } |
198 | |
199 | return join "\n", @res; |
fc1d8369 |
200 | } |
201 | |
202 | sub _generate_BUILDARGS { |
0bfc7290 |
203 | my(undef, $metaclass) = @_; |
9dcd7d23 |
204 | |
0bfc7290 |
205 | my $class = $metaclass->name; |
206 | if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) { |
53d4053e |
207 | return 'my $args = $class->BUILDARGS(@_)'; |
9dcd7d23 |
208 | } |
209 | |
210 | return <<'...'; |
53d4053e |
211 | my $args; |
fc1d8369 |
212 | if ( scalar @_ == 1 ) { |
c9aefe26 |
213 | ( ref( $_[0] ) eq 'HASH' ) |
fc1d8369 |
214 | || Carp::confess "Single parameters to new() must be a HASH ref"; |
53d4053e |
215 | $args = +{ %{ $_[0] } }; |
fc1d8369 |
216 | } |
217 | else { |
53d4053e |
218 | $args = +{@_}; |
fc1d8369 |
219 | } |
fc1d8369 |
220 | ... |
221 | } |
222 | |
223 | sub _generate_BUILDALL { |
0bfc7290 |
224 | my (undef, $metaclass) = @_; |
7ca5c5fb |
225 | |
2efc0af1 |
226 | return '' unless $metaclass->name->can('BUILD'); |
fc1d8369 |
227 | |
7ca5c5fb |
228 | my @code; |
229 | for my $class ($metaclass->linearized_isa) { |
a5c683f6 |
230 | if (Mouse::Util::get_code_ref($class, 'BUILD')) { |
7ca5c5fb |
231 | unshift @code, qq{${class}::BUILD(\$instance, \$args);}; |
fc1d8369 |
232 | } |
233 | } |
234 | return join "\n", @code; |
235 | } |
236 | |
e128626c |
237 | sub _report_unknown_args { |
8801a6e6 |
238 | my(undef, $metaclass, $attrs, $args) = @_; |
e128626c |
239 | |
240 | my @unknowns; |
241 | my %init_args; |
242 | foreach my $attr(@{$attrs}){ |
243 | my $init_arg = $attr->init_arg; |
244 | if(defined $init_arg){ |
245 | $init_args{$init_arg}++; |
246 | } |
247 | } |
248 | |
249 | while(my $key = each %{$args}){ |
250 | if(!exists $init_args{$key}){ |
251 | push @unknowns, $key; |
252 | } |
253 | } |
254 | |
255 | $metaclass->throw_error( sprintf |
256 | "Unknown attribute passed to the constructor of %s: %s", |
8801a6e6 |
257 | $metaclass->name, Mouse::Util::english_list(@unknowns), |
e128626c |
258 | ); |
259 | } |
260 | |
fc1d8369 |
261 | 1; |
0126c27c |
262 | __END__ |
a25ca8d6 |
263 | |
264 | =head1 NAME |
265 | |
266 | Mouse::Meta::Method::Constructor - A Mouse method generator for constructors |
267 | |
268 | =head1 VERSION |
269 | |
c2168931 |
270 | This document describes Mouse version 0.50_04 |
a25ca8d6 |
271 | |
272 | =head1 SEE ALSO |
273 | |
274 | L<Moose::Meta::Method::Constructor> |
275 | |
276 | =cut |