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