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