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