Commit | Line | Data |
fc1d8369 |
1 | package Mouse::Meta::Method::Constructor; |
2 | use strict; |
3 | use warnings; |
4 | |
5 | sub generate_constructor_method_inline { |
6 | my ($class, $meta) = @_; |
41cdacce |
7 | my $code = $class->_generate_constructor_method_inline($meta); |
8 | warn $code if $ENV{DEBUG}; |
9 | |
10 | local $@; |
11 | my $res = eval $code; |
12 | die $@ if $@; |
13 | $res; |
14 | } |
15 | |
16 | sub _generate_constructor_method_inline { |
17 | my ($class, $meta) = @_; |
fc1d8369 |
18 | my $buildall = $class->_generate_BUILDALL($meta); |
19 | my $buildargs = $class->_generate_BUILDARGS(); |
20 | my $classname = $meta->name; |
21 | my $processattrs = $class->_generate_processattrs($meta); |
22 | |
41cdacce |
23 | return <<"..."; |
fc1d8369 |
24 | sub { |
25 | my \$class = shift; |
26 | my \$args = $buildargs; |
27 | my \$instance = bless {}, '$classname'; |
41cdacce |
28 | my \$meta = \$instance->meta; |
fc1d8369 |
29 | $processattrs; |
30 | $buildall; |
31 | return \$instance; |
32 | } |
33 | ... |
fc1d8369 |
34 | } |
35 | |
36 | sub _generate_processattrs { |
37 | my ($class, $meta, ) = @_; |
38 | my @attrs = $meta->compute_all_applicable_attributes; |
39 | my @res; |
40 | for my $attr (@attrs) { |
41 | my $from = $attr->init_arg; |
42 | my $key = $attr->name; |
43 | my $part1 = do { |
44 | my @code; |
45 | if ($attr->should_coerce) { |
46 | push @code, "\$args->{\$from} = \$attr->coerce_constraint( \$args->{\$from} );"; |
47 | } |
48 | if ($attr->has_type_constraint) { |
49 | push @code, "\$attr->verify_type_constraint( \$args->{\$from} );"; |
50 | } |
51 | push @code, "\$instance->{\$key} = \$args->{\$from};"; |
41cdacce |
52 | if ($attr->is_weak_ref) { |
53 | push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} );"; |
54 | } |
fc1d8369 |
55 | if ( $attr->has_trigger ) { |
56 | push @code, "\$attr->trigger->( \$instance, \$args->{\$from}, \$attr );"; |
57 | } |
58 | join "\n", @code; |
59 | }; |
60 | my $part2 = do { |
61 | my @code; |
62 | if ( $attr->has_default || $attr->has_builder ) { |
63 | unless ( $attr->is_lazy ) { |
64 | my $default = $attr->default; |
65 | my $builder = $attr->builder; |
66 | if ($attr->has_builder) { |
67 | push @code, "my \$value = \$instance->$builder;"; |
68 | } elsif (ref($default) eq 'CODE') { |
69 | push @code, "my \$value = \$attr->default()->();"; |
70 | } else { |
71 | push @code, "my \$value = \$attr->default();"; |
72 | } |
73 | if ($attr->should_coerce) { |
74 | push @code, "\$value = \$attr->coerce_constraint(\$value);"; |
75 | } |
76 | if ($attr->has_type_constraint) { |
77 | push @code, "\$attr->verify_type_constraint(\$value);"; |
78 | } |
79 | push @code, "\$instance->{\$key} = \$value;"; |
80 | if ($attr->is_weak_ref) { |
81 | push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} );"; |
82 | } |
83 | } |
84 | join "\n", @code; |
85 | } |
86 | else { |
87 | if ( $attr->is_required ) { |
88 | q{Carp::confess("Attribute (} . $attr->name . q{) is required");}; |
89 | } else { |
90 | "" |
91 | } |
92 | } |
93 | }; |
94 | my $code = <<"..."; |
95 | { |
41cdacce |
96 | my \$attr = \$meta->get_attribute('$key'); |
fc1d8369 |
97 | my \$from = '$from'; |
98 | my \$key = '$key'; |
99 | if (defined(\$from) && exists(\$args->{\$from})) { |
100 | $part1; |
101 | } else { |
102 | $part2; |
103 | } |
104 | } |
105 | ... |
106 | push @res, $code; |
107 | } |
108 | return join "\n", @res; |
109 | } |
110 | |
111 | sub _generate_BUILDARGS { |
112 | <<'...'; |
113 | do { |
114 | if ( scalar @_ == 1 ) { |
115 | if ( defined $_[0] ) { |
116 | ( ref( $_[0] ) eq 'HASH' ) |
117 | || Carp::confess "Single parameters to new() must be a HASH ref"; |
118 | +{ %{ $_[0] } }; |
119 | } |
120 | else { |
121 | +{}; |
122 | } |
123 | } |
124 | else { |
125 | +{@_}; |
126 | } |
127 | }; |
128 | ... |
129 | } |
130 | |
131 | sub _generate_BUILDALL { |
132 | my ($class, $meta) = @_; |
133 | return '' unless $meta->name->can('BUILD'); |
134 | |
135 | my @code = (); |
136 | push @code, q{no strict 'refs';}; |
137 | push @code, q{no warnings 'once';}; |
138 | no strict 'refs'; |
139 | for my $class ($meta->linearized_isa) { |
140 | if (*{ $class . '::BUILD' }{CODE}) { |
141 | push @code, qq{${class}::BUILD->(\$instance, \$args);}; |
142 | } |
143 | } |
144 | return join "\n", @code; |
145 | } |
146 | |
147 | 1; |