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