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); |
7 | use aliased 'MooseX::Antlers::RefTracker'; |
8 | use aliased 'MooseX::Antlers::EvalTracker'; |
9 | use aliased 'MooseX::Antlers::RefFilter'; |
10 | |
11 | has [ qw(_target _attr_refs _attr_et _im_et _raw_source) ] => (is => 'rw'); |
12 | |
13 | sub load_with_compiler { |
14 | my ($class, $target) = @_; |
15 | $class->new->load($target); |
16 | } |
17 | |
18 | sub load { |
19 | my ($self, $target) = @_; |
20 | my %attr_refs; |
21 | my %attr_et; |
22 | my $im_et; |
23 | my $orig_import = Moose->can('import'); |
24 | no warnings 'redefine'; |
25 | local *Moose::import = sub { |
26 | my $targ = caller; |
27 | Moose->$orig_import({ into => $targ }); |
28 | my $has = $targ->can('has'); |
29 | { |
30 | no strict 'refs'; |
31 | *{"${targ}::has"} = sub { |
32 | $attr_refs{$_[0]} = [ |
33 | map RefTracker->trace_refs( $_ => \@_ ), |
34 | '(\@_)', '$has_args{'.perlstring($_[0]).'}' |
35 | ]; |
36 | my $et = EvalTracker->new->enable; |
37 | $has->(@_); |
38 | $attr_et{$_[0]} = $et->disable; |
39 | return; |
40 | }; |
41 | } |
42 | }; |
43 | my $orig_immutable = Moose::Meta::Class->can('make_immutable'); |
44 | local *Moose::Meta::Class::make_immutable = sub { |
45 | my $et = EvalTracker->new->enable; |
46 | $orig_immutable->(@_); |
47 | $im_et = $et->disable; |
48 | return; |
49 | }; |
50 | Class::MOP::load_class($target); |
51 | $self->_attr_refs(\%attr_refs); |
52 | $self->_attr_et(\%attr_et); |
53 | $self->_im_et($im_et); |
54 | $self->_target($target); |
55 | (my $pm_file = $target) =~ s/::/\//g; |
56 | $self->_raw_source(scalar io($INC{"${pm_file}.pm"})->slurp); |
57 | return $self; |
58 | } |
59 | |
60 | sub compiled_source { |
61 | my ($self) = @_; |
62 | my %attr_et = %{$self->_attr_et}; |
63 | my %attr_refs = %{$self->_attr_refs}; |
64 | my $im_et = $self->_im_et; |
65 | my $target = $self->_target; |
66 | my %attr_construct; |
67 | foreach my $attr_name (keys %attr_refs) { |
68 | $attr_construct{$attr_name} |
69 | = $attr_et{$attr_name}->serialized_construction( |
70 | $attr_refs{$attr_name}[0] |
71 | ); |
72 | } |
73 | my $im_construct = $im_et->serialized_construction( |
74 | { map %{$_->[1]}, values %attr_refs } |
75 | ); |
76 | my $preamble = strip tt q{ |
77 | my %replay_has; |
78 | my %has_args; |
79 | BEGIN { |
80 | %replay_has = ( |
81 | [% FOREACH a IN attr_construct_h %] |
82 | [% a.key %] => sub { |
83 | [% a.value %] |
84 | } |
85 | [% END %] |
86 | ); |
87 | } |
88 | sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable { |
89 | [% im_construct %] |
90 | } |
91 | use MooseX::Antlers::StealImport |
92 | Moose => { |
93 | -do => sub { |
94 | strict->import; |
95 | warnings->import; |
96 | }, |
97 | has => sub { |
98 | $has_args{$_[0]} = \@_; |
99 | ($replay_has{$_[0]}||die "Can't find replay for $_[0]") |
100 | ->(@_); |
101 | }, |
102 | meta => sub { 'MooseX::Antlers::ImmutableHackFor::[% target %]' } |
103 | }; |
104 | }; |
105 | |
106 | my $postamble = strip q{ |
107 | no MooseX::Antlers::StealImport qw(Moose); |
108 | }; |
109 | |
110 | my $compiled = join("\n", $preamble, $self->_raw_source, $postamble); |
111 | |
112 | return $compiled; |
113 | } |
114 | |
115 | 1; |