Commit | Line | Data |
3362e41c |
1 | package Moo::HandleMoose; |
2 | |
3 | use strictures 1; |
4 | use Moo::_Utils; |
0cc17078 |
5 | use B qw(perlstring); |
3362e41c |
6 | |
37de175a |
7 | our %TYPE_MAP; |
8 | |
7c418d0b |
9 | our $SETUP_DONE; |
10 | |
11 | sub import { return if $SETUP_DONE; inject_all(); $SETUP_DONE = 1; } |
3362e41c |
12 | |
13 | sub inject_all { |
14 | require Class::MOP; |
0cc17078 |
15 | inject_fake_metaclass_for($_) |
16 | for grep $_ ne 'Moo::Object', do { no warnings 'once'; keys %Moo::MAKERS }; |
7f9775b1 |
17 | inject_fake_metaclass_for($_) for keys %Moo::Role::INFO; |
7ecb13a6 |
18 | require Moose::Meta::Method::Constructor; |
19 | @Moo::HandleMoose::FakeConstructor::ISA = 'Moose::Meta::Method::Constructor'; |
3362e41c |
20 | } |
21 | |
6c49212f |
22 | sub maybe_reinject_fake_metaclass_for { |
23 | my ($name) = @_; |
24 | our %DID_INJECT; |
25 | if (delete $DID_INJECT{$name}) { |
9f8d2cdb |
26 | unless ($Moo::Role::INFO{$name}) { |
27 | Moo->_constructor_maker_for($name)->install_delayed; |
28 | } |
6c49212f |
29 | inject_fake_metaclass_for($name); |
30 | } |
31 | } |
32 | |
3362e41c |
33 | sub inject_fake_metaclass_for { |
34 | my ($name) = @_; |
35 | require Class::MOP; |
6e77b8df |
36 | require Moo::HandleMoose::FakeMetaClass; |
3362e41c |
37 | Class::MOP::store_metaclass_by_name( |
38 | $name, bless({ name => $name }, 'Moo::HandleMoose::FakeMetaClass') |
39 | ); |
59074598 |
40 | require Moose::Util::TypeConstraints; |
41 | if ($Moo::Role::INFO{$name}) { |
42 | Moose::Util::TypeConstraints::find_or_create_does_type_constraint($name); |
43 | } else { |
44 | Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($name); |
45 | } |
3362e41c |
46 | } |
47 | |
7ecb13a6 |
48 | { |
49 | package Moo::HandleMoose::FakeConstructor; |
50 | |
51 | sub _uninlined_body { \&Moose::Object::new } |
52 | } |
7ecb13a6 |
53 | |
3362e41c |
54 | sub inject_real_metaclass_for { |
55 | my ($name) = @_; |
6c49212f |
56 | our %DID_INJECT; |
3362e41c |
57 | return Class::MOP::get_metaclass_by_name($name) if $DID_INJECT{$name}; |
513a3b5d |
58 | require Moose; require Moo; require Moo::Role; require Scalar::Util; |
3362e41c |
59 | Class::MOP::remove_metaclass_by_name($name); |
57d402ef |
60 | my ($am_role, $meta, $attr_specs, $attr_order) = do { |
3362e41c |
61 | if (my $info = $Moo::Role::INFO{$name}) { |
57d402ef |
62 | my @attr_info = @{$info->{attributes}||[]}; |
63 | (1, Moose::Meta::Role->initialize($name), |
64 | { @attr_info }, |
65 | [ @attr_info[grep !($_ % 2), 0..$#attr_info] ] |
66 | ) |
5d20f26c |
67 | } elsif ( my $cmaker = Moo->_constructor_maker_for($name) ) { |
68 | my $specs = $cmaker->all_attribute_specs; |
57d402ef |
69 | (0, Moose::Meta::Class->initialize($name), $specs, |
70 | [ sort { $specs->{$a}{index} <=> $specs->{$b}{index} } keys %$specs ] |
71 | ); |
5d20f26c |
72 | } else { |
73 | # This codepath is used if $name does not exist in $Moo::MAKERS |
74 | (0, Moose::Meta::Class->initialize($name), {}, [] ) |
3362e41c |
75 | } |
76 | }; |
7b27f050 |
77 | |
7887ffd0 |
78 | for my $spec (values %$attr_specs) { |
79 | if (my $inflators = delete $spec->{moosify}) { |
80 | $_->($spec) for @$inflators; |
81 | } |
82 | } |
83 | |
3362e41c |
84 | my %methods = %{Role::Tiny->_concrete_methods_of($name)}; |
c85a5738 |
85 | |
86 | # if stuff gets added afterwards, _maybe_reset_handlemoose should |
87 | # trigger the recreation of the metaclass but we need to ensure the |
88 | # Role::Tiny cache is cleared so we don't confuse Moo itself. |
89 | if (my $info = $Role::Tiny::INFO{$name}) { |
90 | delete $info->{methods}; |
91 | } |
92 | |
46269e18 |
93 | # needed to ensure the method body is stable and get things named |
94 | Sub::Defer::undefer_sub($_) for grep defined, values %methods; |
3362e41c |
95 | my @attrs; |
96 | { |
55afe266 |
97 | # This local is completely not required for roles but harmless |
3362e41c |
98 | local @{_getstash($name)}{keys %methods}; |
c100c04c |
99 | my %seen_name; |
57d402ef |
100 | foreach my $name (@$attr_order) { |
c100c04c |
101 | $seen_name{$name} = 1; |
55afe266 |
102 | my %spec = %{$attr_specs->{$name}}; |
820e3970 |
103 | my %spec_map = ( |
74ec40e9 |
104 | map { $_->name => $_->init_arg||$_->name } |
105 | ( |
106 | (grep { $_->has_init_arg } |
107 | $meta->attribute_metaclass->meta->get_all_attributes), |
3412023c |
108 | grep { exists($_->{init_arg}) ? defined($_->init_arg) : 1 } |
74ec40e9 |
109 | map { |
110 | my $meta = Moose::Util::resolve_metatrait_alias('Attribute', $_) |
111 | ->meta; |
112 | map $meta->get_attribute($_), $meta->get_attribute_list |
113 | } @{$spec{traits}||[]} |
114 | ) |
820e3970 |
115 | ); |
5bd6dac7 |
116 | # have to hard code this because Moose's role meta-model is lacking |
117 | $spec_map{traits} ||= 'traits'; |
820e3970 |
118 | |
2bb6aaa3 |
119 | $spec{is} = 'ro' if $spec{is} eq 'lazy' or $spec{is} eq 'rwp'; |
3985eb35 |
120 | my $coerce = $spec{coerce}; |
37de175a |
121 | if (my $isa = $spec{isa}) { |
9dc13bea |
122 | my $tc = $spec{isa} = do { |
37de175a |
123 | if (my $mapped = $TYPE_MAP{$isa}) { |
3985eb35 |
124 | my $type = $mapped->(); |
513a3b5d |
125 | Scalar::Util::blessed($type) && $type->isa("Moose::Meta::TypeConstraint") |
126 | or die "error inflating attribute '$name' for package '$_[0]': \$TYPE_MAP{$isa} did not return a valid type constraint'"; |
3985eb35 |
127 | $coerce ? $type->create_child_type(name => $type->name) : $type; |
37de175a |
128 | } else { |
129 | Moose::Meta::TypeConstraint->new( |
130 | constraint => sub { eval { &$isa; 1 } } |
131 | ); |
132 | } |
133 | }; |
3985eb35 |
134 | if ($coerce) { |
9dc13bea |
135 | $tc->coercion(Moose::Meta::TypeCoercion->new) |
136 | ->_compiled_type_coercion($coerce); |
137 | $spec{coerce} = 1; |
138 | } |
3985eb35 |
139 | } elsif ($coerce) { |
0cc17078 |
140 | my $attr = perlstring($name); |
141 | my $tc = Moose::Meta::TypeConstraint->new( |
142 | constraint => sub { die "This is not going to work" }, |
8863604c |
143 | inlined => sub { |
144 | 'my $r = $_[42]{'.$attr.'}; $_[42]{'.$attr.'} = 1; $r' |
145 | }, |
0cc17078 |
146 | ); |
9dc13bea |
147 | $tc->coercion(Moose::Meta::TypeCoercion->new) |
148 | ->_compiled_type_coercion($coerce); |
149 | $spec{isa} = $tc; |
150 | $spec{coerce} = 1; |
37de175a |
151 | } |
b6ab6837 |
152 | %spec = |
153 | map { $spec_map{$_} => $spec{$_} } |
154 | grep { exists $spec_map{$_} } |
155 | keys %spec; |
55afe266 |
156 | push @attrs, $meta->add_attribute($name => %spec); |
3362e41c |
157 | } |
c100c04c |
158 | foreach my $mouse (do { our %MOUSE; @{$MOUSE{$name}||[]} }) { |
159 | foreach my $attr ($mouse->get_all_attributes) { |
160 | my %spec = %{$attr}; |
161 | delete @spec{qw( |
162 | associated_class associated_methods __METACLASS__ |
163 | provides curries |
164 | )}; |
165 | my $name = delete $spec{name}; |
166 | next if $seen_name{$name}++; |
167 | push @attrs, $meta->add_attribute($name => %spec); |
168 | } |
169 | } |
3362e41c |
170 | } |
2334229b |
171 | for my $meth_name (keys %methods) { |
172 | my $meth_code = $methods{$meth_name}; |
c7779183 |
173 | $meta->add_method($meth_name, $meth_code) if $meth_code; |
174 | } |
175 | |
55afe266 |
176 | if ($am_role) { |
146fb407 |
177 | my $info = $Moo::Role::INFO{$name}; |
178 | $meta->add_required_methods(@{$info->{requires}}); |
179 | foreach my $modifier (@{$info->{modifiers}}) { |
180 | my ($type, @args) = @$modifier; |
25ceb5de |
181 | my $code = pop @args; |
182 | $meta->${\"add_${type}_method_modifier"}($_, $code) for @args; |
146fb407 |
183 | } |
55afe266 |
184 | } else { |
7f9775b1 |
185 | foreach my $attr (@attrs) { |
186 | foreach my $method (@{$attr->associated_methods}) { |
187 | $method->{body} = $name->can($method->name); |
188 | } |
3362e41c |
189 | } |
7ecb13a6 |
190 | bless( |
191 | $meta->find_method_by_name('new'), |
192 | 'Moo::HandleMoose::FakeConstructor', |
193 | ); |
4de2328f |
194 | # a combination of Moo and Moose may bypass a Moo constructor but still |
195 | # use a Moo DEMOLISHALL. We need to make sure this is loaded before |
196 | # global destruction. |
197 | require Method::Generate::DemolishAll; |
3362e41c |
198 | } |
7c418d0b |
199 | $meta->add_role(Class::MOP::class_of($_)) |
a3411285 |
200 | for grep !/\|/ && $_ ne $name, # reject Foo|Bar and same-role-as-self |
fd04120b |
201 | do { no warnings 'once'; keys %{$Role::Tiny::APPLIED_TO{$name}} }; |
3362e41c |
202 | $DID_INJECT{$name} = 1; |
203 | $meta; |
204 | } |
205 | |
3362e41c |
206 | 1; |