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