Commit | Line | Data |
3fea05b9 |
1 | package Mouse::Meta::Method::Constructor; |
2 | use Mouse::Util qw(:meta); # enables strict and warnings |
3 | |
4 | sub _inline_slot{ |
5 | my(undef, $self_var, $attr_name) = @_; |
6 | return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
7 | } |
8 | |
9 | sub _generate_constructor { |
10 | my ($class, $metaclass, $args) = @_; |
11 | |
12 | my $associated_metaclass_name = $metaclass->name; |
13 | |
14 | my @attrs = $metaclass->get_all_attributes; |
15 | |
16 | my $buildall = $class->_generate_BUILDALL($metaclass); |
17 | my $buildargs = $class->_generate_BUILDARGS($metaclass); |
18 | my $processattrs = $class->_generate_processattrs($metaclass, \@attrs); |
19 | |
20 | my @checks = map { $_ && $_->_compiled_type_constraint } |
21 | map { $_->type_constraint } @attrs; |
22 | |
23 | my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"..."; |
24 | sub \{ |
25 | my \$class = shift; |
26 | return \$class->Mouse::Object::new(\@_) |
27 | if \$class ne q{$associated_metaclass_name}; |
28 | # BUILDARGS |
29 | $buildargs; |
30 | my \$instance = bless {}, \$class; |
31 | # process attributes |
32 | $processattrs; |
33 | # BUILDALL |
34 | $buildall; |
35 | return \$instance; |
36 | } |
37 | ... |
38 | #warn $source; |
39 | my $code; |
40 | my $e = do{ |
41 | local $@; |
42 | $code = eval $source; |
43 | $@; |
44 | }; |
45 | die $e if $e; |
46 | return $code; |
47 | } |
48 | |
49 | sub _generate_processattrs { |
50 | my ($method_class, $metaclass, $attrs) = @_; |
51 | my @res; |
52 | |
53 | my $has_triggers; |
54 | |
55 | for my $index (0 .. @$attrs - 1) { |
56 | my $code = ''; |
57 | |
58 | my $attr = $attrs->[$index]; |
59 | my $key = $attr->name; |
60 | |
61 | my $init_arg = $attr->init_arg; |
62 | my $type_constraint = $attr->type_constraint; |
63 | my $is_weak_ref = $attr->is_weak_ref; |
64 | my $need_coercion; |
65 | |
66 | my $instance_slot = $method_class->_inline_slot('$instance', $key); |
67 | my $attr_var = "\$attrs[$index]"; |
68 | my $constraint_var; |
69 | |
70 | if(defined $type_constraint){ |
71 | $constraint_var = "$attr_var\->{type_constraint}"; |
72 | $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion); |
73 | } |
74 | |
75 | $code .= "# initialize $key\n"; |
76 | |
77 | my $post_process = ''; |
78 | if(defined $type_constraint){ |
79 | $post_process .= "\$checks[$index]->($instance_slot)"; |
80 | $post_process .= " or $attr_var->verify_type_constraint_error(q{$key}, $instance_slot, $constraint_var);\n"; |
81 | } |
82 | if($is_weak_ref){ |
83 | $post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n"; |
84 | } |
85 | |
86 | if (defined $init_arg) { |
87 | my $value = "\$args->{q{$init_arg}}"; |
88 | |
89 | $code .= "if (exists $value) {\n"; |
90 | |
91 | if($need_coercion){ |
92 | $value = "$constraint_var->coerce($value)"; |
93 | } |
94 | |
95 | $code .= "$instance_slot = $value;\n"; |
96 | $code .= $post_process; |
97 | |
98 | if ($attr->has_trigger) { |
99 | $has_triggers++; |
100 | $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n"; |
101 | } |
102 | |
103 | $code .= "\n} else {\n"; |
104 | } |
105 | |
106 | if ($attr->has_default || $attr->has_builder) { |
107 | unless ($attr->is_lazy) { |
108 | my $default = $attr->default; |
109 | my $builder = $attr->builder; |
110 | |
111 | my $value; |
112 | if (defined($builder)) { |
113 | $value = "\$instance->$builder()"; |
114 | } |
115 | elsif (ref($default) eq 'CODE') { |
116 | $value = "$attr_var\->{default}->(\$instance)"; |
117 | } |
118 | elsif (defined($default)) { |
119 | $value = "$attr_var\->{default}"; |
120 | } |
121 | else { |
122 | $value = 'undef'; |
123 | } |
124 | |
125 | if($need_coercion){ |
126 | $value = "$constraint_var->coerce($value)"; |
127 | } |
128 | |
129 | $code .= "$instance_slot = $value;\n"; |
130 | if($is_weak_ref){ |
131 | $code .= "Scalar::Util::weaken($instance_slot);\n"; |
132 | } |
133 | } |
134 | } |
135 | elsif ($attr->is_required) { |
136 | $code .= "Carp::confess('Attribute ($key) is required');"; |
137 | } |
138 | |
139 | $code .= "}\n" if defined $init_arg; |
140 | |
141 | push @res, $code; |
142 | } |
143 | |
144 | if($metaclass->is_anon_class){ |
145 | push @res, q{$instance->{__METACLASS__} = $metaclass;}; |
146 | } |
147 | |
148 | if($has_triggers){ |
149 | unshift @res, q{my @triggers;}; |
150 | push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; |
151 | } |
152 | |
153 | return join "\n", @res; |
154 | } |
155 | |
156 | sub _generate_BUILDARGS { |
157 | my(undef, $metaclass) = @_; |
158 | |
159 | my $class = $metaclass->name; |
160 | if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) { |
161 | return 'my $args = $class->BUILDARGS(@_)'; |
162 | } |
163 | |
164 | return <<'...'; |
165 | my $args; |
166 | if ( scalar @_ == 1 ) { |
167 | ( ref( $_[0] ) eq 'HASH' ) |
168 | || Carp::confess "Single parameters to new() must be a HASH ref"; |
169 | $args = +{ %{ $_[0] } }; |
170 | } |
171 | else { |
172 | $args = +{@_}; |
173 | } |
174 | ... |
175 | } |
176 | |
177 | sub _generate_BUILDALL { |
178 | my (undef, $metaclass) = @_; |
179 | |
180 | return '' unless $metaclass->name->can('BUILD'); |
181 | |
182 | my @code; |
183 | for my $class ($metaclass->linearized_isa) { |
184 | if (Mouse::Util::get_code_ref($class, 'BUILD')) { |
185 | unshift @code, qq{${class}::BUILD(\$instance, \$args);}; |
186 | } |
187 | } |
188 | return join "\n", @code; |
189 | } |
190 | |
191 | 1; |
192 | __END__ |
193 | |
194 | =head1 NAME |
195 | |
196 | Mouse::Meta::Method::Constructor - A Mouse method generator for constructors |
197 | |
198 | =head1 VERSION |
199 | |
200 | This document describes Mouse version 0.43 |
201 | |
202 | =head1 SEE ALSO |
203 | |
204 | L<Moose::Meta::Method::Constructor> |
205 | |
206 | =cut |