Commit | Line | Data |
5bd097e7 |
1 | package MooseX::Antlers::Compiler; |
2 | |
3 | use Moose; |
4 | use IO::All qw(io); |
5 | use String::TT qw(strip tt); |
6 | use B qw(perlstring); |
3691d03f |
7 | use Data::Dumper::Concise; |
8 | use Scalar::Util qw(refaddr); |
5bd097e7 |
9 | use aliased 'MooseX::Antlers::RefTracker'; |
10 | use aliased 'MooseX::Antlers::EvalTracker'; |
11 | use aliased 'MooseX::Antlers::RefFilter'; |
12 | |
13 | has [ qw(_target _attr_refs _attr_et _im_et _raw_source) ] => (is => 'rw'); |
14 | |
15 | sub load_with_compiler { |
16 | my ($class, $target) = @_; |
17 | $class->new->load($target); |
18 | } |
19 | |
20 | sub load { |
21 | my ($self, $target) = @_; |
22 | my %attr_refs; |
23 | my %attr_et; |
24 | my $im_et; |
25 | my $orig_import = Moose->can('import'); |
26 | no warnings 'redefine'; |
27 | local *Moose::import = sub { |
28 | my $targ = caller; |
29 | Moose->$orig_import({ into => $targ }); |
30 | my $has = $targ->can('has'); |
31 | { |
32 | no strict 'refs'; |
33 | *{"${targ}::has"} = sub { |
34 | $attr_refs{$_[0]} = [ |
35 | map RefTracker->trace_refs( $_ => \@_ ), |
36 | '(\@_)', '$has_args{'.perlstring($_[0]).'}' |
37 | ]; |
38 | my $et = EvalTracker->new->enable; |
39 | $has->(@_); |
40 | $attr_et{$_[0]} = $et->disable; |
41 | return; |
42 | }; |
43 | } |
44 | }; |
45 | my $orig_immutable = Moose::Meta::Class->can('make_immutable'); |
46 | local *Moose::Meta::Class::make_immutable = sub { |
47 | my $et = EvalTracker->new->enable; |
48 | $orig_immutable->(@_); |
49 | $im_et = $et->disable; |
50 | return; |
51 | }; |
52 | Class::MOP::load_class($target); |
53 | $self->_attr_refs(\%attr_refs); |
54 | $self->_attr_et(\%attr_et); |
55 | $self->_im_et($im_et); |
56 | $self->_target($target); |
57 | (my $pm_file = $target) =~ s/::/\//g; |
58 | $self->_raw_source(scalar io($INC{"${pm_file}.pm"})->slurp); |
59 | return $self; |
60 | } |
61 | |
62 | sub compiled_source { |
63 | my ($self) = @_; |
64 | my %attr_et = %{$self->_attr_et}; |
65 | my %attr_refs = %{$self->_attr_refs}; |
66 | my $im_et = $self->_im_et; |
67 | my $target = $self->_target; |
68 | my %attr_construct; |
3691d03f |
69 | my $all_refs = { map %{$_->[1]}, values %attr_refs }; |
5bd097e7 |
70 | foreach my $attr_name (keys %attr_refs) { |
71 | $attr_construct{$attr_name} |
72 | = $attr_et{$attr_name}->serialized_construction( |
73 | $attr_refs{$attr_name}[0] |
74 | ); |
75 | } |
3691d03f |
76 | my $im_construct = $im_et->serialized_construction($all_refs); |
77 | my $preamble = tt strip q{ |
fec6319b |
78 | use Sub::Name (); |
5bd097e7 |
79 | my %replay_has; |
80 | my %has_args; |
81 | BEGIN { |
82 | %replay_has = ( |
fec6319b |
83 | [% FOREACH a IN attr_construct_h %] |
5bd097e7 |
84 | [% a.key %] => sub { |
85 | [% a.value %] |
86 | } |
fec6319b |
87 | [% END %] |
5bd097e7 |
88 | ); |
89 | } |
90 | sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable { |
3691d03f |
91 | [% im_construct %] |
92 | no warnings 'redefine'; |
93 | *[% target %]::meta = sub { |
94 | my $meta_code = do { local $/; <[% target %]::DATA> }; |
95 | local $@; |
96 | my $meta = eval $meta_code; |
97 | die $@ if $@; |
98 | $meta; |
99 | }; |
5bd097e7 |
100 | } |
101 | use MooseX::Antlers::StealImport |
102 | Moose => { |
103 | -do => sub { |
104 | strict->import; |
105 | warnings->import; |
106 | }, |
107 | has => sub { |
108 | $has_args{$_[0]} = \@_; |
109 | ($replay_has{$_[0]}||die "Can't find replay for $_[0]") |
110 | ->(@_); |
111 | }, |
112 | meta => sub { 'MooseX::Antlers::ImmutableHackFor::[% target %]' } |
113 | }; |
114 | }; |
115 | |
3691d03f |
116 | my $meta_construct = $self->_meta_construction_code($all_refs); |
117 | |
118 | my $postamble = tt strip q{ |
5bd097e7 |
119 | no MooseX::Antlers::StealImport qw(Moose); |
3691d03f |
120 | __DATA__ |
121 | [% meta_construct %] |
5bd097e7 |
122 | }; |
123 | |
124 | my $compiled = join("\n", $preamble, $self->_raw_source, $postamble); |
125 | |
126 | return $compiled; |
127 | } |
128 | |
3691d03f |
129 | sub _meta_construction_code { |
130 | my ($self, $all_refs) = @_; |
131 | my $target = $self->_target; |
132 | my $meta_obj = $target->meta; |
133 | my $mappings = { |
134 | %$all_refs, |
135 | map +(refaddr($target->can($_)) => '\&'.$target.'::'.$_), |
136 | $meta_obj->get_method_list, 'meta' |
137 | }; |
138 | my $filter = RefFilter->new( |
139 | external_mappings => $mappings, |
140 | root_name => '$meta' |
141 | ); |
142 | my $filtered_meta = Dumper($filter->visit($meta_obj)); |
143 | my $meta_fixup = $filter->fixup_code; |
144 | my $target_string = perlstring($target); |
145 | return tt strip q{ |
146 | require Moose; |
147 | my $meta = [% filtered_meta %]; |
148 | [% meta_fixup %] |
149 | Class::MOP::store_metaclass_by_name([% target_string %] => $meta); |
150 | no warnings 'redefine'; |
151 | *[% target %]::meta = sub { |
152 | Moose::Meta::Class->initialize( ref($_[0]) || $_[0] ); |
153 | }; |
154 | $meta; |
155 | }; |
156 | } |
157 | |
5bd097e7 |
158 | 1; |