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}) { |
26 | inject_fake_metaclass_for($name); |
27 | } |
28 | } |
29 | |
3362e41c |
30 | sub inject_fake_metaclass_for { |
31 | my ($name) = @_; |
32 | require Class::MOP; |
33 | Class::MOP::store_metaclass_by_name( |
34 | $name, bless({ name => $name }, 'Moo::HandleMoose::FakeMetaClass') |
35 | ); |
36 | } |
37 | |
7ecb13a6 |
38 | { |
39 | package Moo::HandleMoose::FakeConstructor; |
40 | |
41 | sub _uninlined_body { \&Moose::Object::new } |
42 | } |
43 | |
44 | |
3362e41c |
45 | sub inject_real_metaclass_for { |
46 | my ($name) = @_; |
6c49212f |
47 | our %DID_INJECT; |
3362e41c |
48 | return Class::MOP::get_metaclass_by_name($name) if $DID_INJECT{$name}; |
49 | require Moose; require Moo; require Moo::Role; |
50 | Class::MOP::remove_metaclass_by_name($name); |
57d402ef |
51 | my ($am_role, $meta, $attr_specs, $attr_order) = do { |
3362e41c |
52 | if (my $info = $Moo::Role::INFO{$name}) { |
57d402ef |
53 | my @attr_info = @{$info->{attributes}||[]}; |
54 | (1, Moose::Meta::Role->initialize($name), |
55 | { @attr_info }, |
56 | [ @attr_info[grep !($_ % 2), 0..$#attr_info] ] |
57 | ) |
3362e41c |
58 | } else { |
59 | my $specs = Moo->_constructor_maker_for($name)->all_attribute_specs; |
57d402ef |
60 | (0, Moose::Meta::Class->initialize($name), $specs, |
61 | [ sort { $specs->{$a}{index} <=> $specs->{$b}{index} } keys %$specs ] |
62 | ); |
3362e41c |
63 | } |
64 | }; |
65 | my %methods = %{Role::Tiny->_concrete_methods_of($name)}; |
46269e18 |
66 | # needed to ensure the method body is stable and get things named |
67 | Sub::Defer::undefer_sub($_) for grep defined, values %methods; |
3362e41c |
68 | my @attrs; |
69 | { |
55afe266 |
70 | # This local is completely not required for roles but harmless |
3362e41c |
71 | local @{_getstash($name)}{keys %methods}; |
57d402ef |
72 | foreach my $name (@$attr_order) { |
55afe266 |
73 | my %spec = %{$attr_specs->{$name}}; |
99b8bec0 |
74 | delete $spec{index}; |
2bb6aaa3 |
75 | $spec{is} = 'ro' if $spec{is} eq 'lazy' or $spec{is} eq 'rwp'; |
f8d65713 |
76 | delete $spec{asserter}; |
37de175a |
77 | if (my $isa = $spec{isa}) { |
9dc13bea |
78 | my $tc = $spec{isa} = do { |
37de175a |
79 | if (my $mapped = $TYPE_MAP{$isa}) { |
81cb9bab |
80 | $mapped->(); |
37de175a |
81 | } else { |
82 | Moose::Meta::TypeConstraint->new( |
83 | constraint => sub { eval { &$isa; 1 } } |
84 | ); |
85 | } |
86 | }; |
9dc13bea |
87 | if (my $coerce = $spec{coerce}) { |
88 | $tc->coercion(Moose::Meta::TypeCoercion->new) |
89 | ->_compiled_type_coercion($coerce); |
90 | $spec{coerce} = 1; |
91 | } |
0cc17078 |
92 | } elsif (my $coerce = $spec{coerce}) { |
93 | my $attr = perlstring($name); |
94 | my $tc = Moose::Meta::TypeConstraint->new( |
95 | constraint => sub { die "This is not going to work" }, |
8863604c |
96 | inlined => sub { |
97 | 'my $r = $_[42]{'.$attr.'}; $_[42]{'.$attr.'} = 1; $r' |
98 | }, |
0cc17078 |
99 | ); |
9dc13bea |
100 | $tc->coercion(Moose::Meta::TypeCoercion->new) |
101 | ->_compiled_type_coercion($coerce); |
102 | $spec{isa} = $tc; |
103 | $spec{coerce} = 1; |
37de175a |
104 | } |
55afe266 |
105 | push @attrs, $meta->add_attribute($name => %spec); |
3362e41c |
106 | } |
107 | } |
55afe266 |
108 | if ($am_role) { |
146fb407 |
109 | my $info = $Moo::Role::INFO{$name}; |
110 | $meta->add_required_methods(@{$info->{requires}}); |
111 | foreach my $modifier (@{$info->{modifiers}}) { |
112 | my ($type, @args) = @$modifier; |
113 | $meta->${\"add_${type}_method_modifier"}(@args); |
114 | } |
55afe266 |
115 | } else { |
7f9775b1 |
116 | foreach my $attr (@attrs) { |
117 | foreach my $method (@{$attr->associated_methods}) { |
118 | $method->{body} = $name->can($method->name); |
119 | } |
3362e41c |
120 | } |
7ecb13a6 |
121 | bless( |
122 | $meta->find_method_by_name('new'), |
123 | 'Moo::HandleMoose::FakeConstructor', |
124 | ); |
3362e41c |
125 | } |
7c418d0b |
126 | $meta->add_role(Class::MOP::class_of($_)) |
a3411285 |
127 | for grep !/\|/ && $_ ne $name, # reject Foo|Bar and same-role-as-self |
fd04120b |
128 | do { no warnings 'once'; keys %{$Role::Tiny::APPLIED_TO{$name}} }; |
3362e41c |
129 | $DID_INJECT{$name} = 1; |
130 | $meta; |
131 | } |
132 | |
133 | { |
134 | package Moo::HandleMoose::FakeMetaClass; |
135 | |
136 | sub DESTROY { } |
137 | |
138 | sub AUTOLOAD { |
139 | my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/); |
140 | Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->$meth(@_) |
141 | } |
142 | sub can { |
143 | Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->can(@_) |
144 | } |
145 | sub isa { |
146 | Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->isa(@_) |
147 | } |
148 | } |
149 | |
150 | 1; |