Commit | Line | Data |
84a1bb62 |
1 | package Perl::Critic::Policy::DynamicMoose; |
a3c86d00 |
2 | use Moose; |
8f31d0d0 |
3 | use MooseX::NonMoose; |
a3c86d00 |
4 | extends 'Perl::Critic::DynamicPolicy'; |
5 | |
8f31d0d0 |
6 | has document => ( |
1e6decf8 |
7 | is => 'rw', |
8 | isa => 'PPI::Document', |
9 | handles => [qw/ppi_document/], |
8f31d0d0 |
10 | ); |
11 | |
cc784ef4 |
12 | sub applies_to { 'PPI::Document' } |
914f300c |
13 | sub applies_to_metaclass { 'Class::MOP::Class', inner() } |
8f31d0d0 |
14 | |
15 | around violation => sub { |
1e6decf8 |
16 | my $orig = shift; |
17 | my $self = shift; |
18 | my $desc = shift; |
19 | my $expl = shift; |
20 | my $element = shift; |
21 | |
22 | if (!$element) { |
23 | my $doc = $self->ppi_document; |
0004d229 |
24 | |
25 | # Without this hack, Storable complains of being unable to reconstruct |
26 | # overloading for an unknown package (perhaps PPI::Document?). For some |
27 | # reason it works for PPI::Element. Anyway, this should hopefully be |
28 | # replaced with a more useful location, something like |
29 | # ( class:MyClass / attr:foo / builder:build_foo ) |
1e6decf8 |
30 | $element = $doc->find('PPI::Element')->[0]; |
31 | } |
8f31d0d0 |
32 | |
1e6decf8 |
33 | return $self->$orig($desc, $expl, $element, @_); |
8f31d0d0 |
34 | }; |
35 | |
a3c86d00 |
36 | sub violates_dynamic { |
37 | my $self = shift; |
38 | my $doc = shift; |
39 | |
8f31d0d0 |
40 | $self->document($doc); |
8f31d0d0 |
41 | |
34502164 |
42 | my $old_packages = $self->find_packages; |
43 | $self->compile_document; |
44 | my @new_packages = $self->new_packages($old_packages); |
8f31d0d0 |
45 | |
46 | my @violations; |
34502164 |
47 | for my $package (@new_packages) { |
c140dc59 |
48 | my $meta = Class::MOP::class_of($package) |
49 | or next; |
50 | |
51 | grep { $meta->isa($_) } $self->applies_to_metaclass |
52 | or next; |
8f31d0d0 |
53 | |
54 | push @violations, $self->violates_metaclass($meta, $doc); |
55 | } |
56 | |
57 | return @violations; |
58 | } |
59 | |
60 | sub compile_document { |
61 | my $self = shift; |
62 | my $doc = $self->document; |
63 | |
1ad52929 |
64 | my $source_code = $doc->content; |
65 | |
66 | eval $source_code; |
67 | |
68 | die "Unable to execute " . $doc->filename . ": $@" if $@; |
8f31d0d0 |
69 | } |
70 | |
71 | sub find_packages { |
72 | my $self = shift; |
34502164 |
73 | return [ Class::MOP::get_all_metaclass_names ]; |
74 | } |
75 | |
76 | sub new_packages { |
77 | my $self = shift; |
78 | my $old = shift; |
79 | my @new; |
80 | my %seen; |
81 | |
82 | $seen{$_} = 1 for @$old; |
83 | |
84 | for (@{ $self->find_packages }) { |
85 | push @new, $_ if !$seen{$_}++; |
86 | } |
a3c86d00 |
87 | |
34502164 |
88 | return @new; |
a3c86d00 |
89 | } |
90 | |
a3c86d00 |
91 | no Moose; |
92 | |
93 | 1; |
94 | |