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