Commit | Line | Data |
6b73059a |
1 | package Perl::Critic::DynamicMoosePolicy; |
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() } |
244fe3b5 |
14 | sub default_themes { qw(moose dynamic), 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 | |
91827b04 |
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 | |
b971d8fa |
61 | sub violates_metaclass { die "Your policy (" . blessed($_[0]) . ") needs to implement violates_metaclass" } |
62 | |
91827b04 |
63 | sub _compile_document { |
8f31d0d0 |
64 | my $self = shift; |
65 | my $doc = $self->document; |
66 | |
1ad52929 |
67 | my $source_code = $doc->content; |
68 | |
69 | eval $source_code; |
70 | |
71 | die "Unable to execute " . $doc->filename . ": $@" if $@; |
8f31d0d0 |
72 | } |
73 | |
91827b04 |
74 | sub _find_packages { |
8f31d0d0 |
75 | my $self = shift; |
34502164 |
76 | return [ Class::MOP::get_all_metaclass_names ]; |
77 | } |
78 | |
91827b04 |
79 | sub _new_packages { |
34502164 |
80 | my $self = shift; |
81 | my $old = shift; |
82 | my @new; |
83 | my %seen; |
84 | |
85 | $seen{$_} = 1 for @$old; |
86 | |
91827b04 |
87 | for (@{ $self->_find_packages }) { |
34502164 |
88 | push @new, $_ if !$seen{$_}++; |
89 | } |
a3c86d00 |
90 | |
34502164 |
91 | return @new; |
a3c86d00 |
92 | } |
93 | |
a3c86d00 |
94 | no Moose; |
e9c046ee |
95 | __PACKAGE__->meta->make_immutable; |
a3c86d00 |
96 | |
97 | 1; |
98 | |
e556eafb |
99 | __END__ |
100 | |
101 | =head1 NAME |
102 | |
6b73059a |
103 | Perl::Critic::DynamicMoosePolicy |
e556eafb |
104 | |
105 | =head1 DESCRIPTION |
106 | |
3771c01a |
107 | This documentation is written for policy authors. You may instead want |
108 | L<Perl::Critic::Dynamic::Moose>. |
109 | |
0fcc6d48 |
110 | This class is a base class for dynamic Moose policies. This class facilitates |
3771c01a |
111 | critiquing metaclasses (instead of the usual PPI documents). For example, |
112 | L<Perl::Critic::Policy::DynamicMoose::ProhibitPublicBuilders> critiques |
0fcc6d48 |
113 | metaclasses by checking whether any of their attributes' builders do not start |
114 | with an underscore. Due to the very dynamic nature of Moose and |
115 | metaprogramming, such policies will be much more effective than static analysis |
116 | at critiquing classes. |
117 | |
118 | =head1 PUBLIC METHODS |
119 | |
120 | =over 4 |
121 | |
122 | =item C<applies_to_metaclass> |
123 | |
124 | Returns a list of metaclass names that this policy can critique. By default, |
125 | the list is L<Class::MOP::Class>. You may use the augment modifier to add |
126 | other kinds of metaclasses, such as L<Moose::Meta::Role> without having to |
127 | repeat the L<Class::MOP::Class>: |
128 | |
129 | augment applies_to_metaclass => sub { 'Moose::Meta::Role' }; |
130 | |
131 | Note that only the top-level metaclass is given to you. If you want to critique |
132 | only attributes, then you must do the Visiting yourself. |
133 | |
134 | =item C<applies_to_themes> |
135 | |
136 | Returns a list of themes for Perl::Critic so that users can run a particular |
137 | subset of themes on their code. By default, the list contains C<moose> and |
138 | C<dynamic>. You should use the augment modifier to add more themes instead |
139 | of overriding the method: |
140 | |
141 | augment themes => sub { 'role' }; |
142 | |
143 | =item C<violation> |
144 | |
145 | This extends the regular L<Perl::Critic::Policy/violation> method by providing |
146 | a (rather useless) default value for the C<element> parameter. For nearly all |
147 | cases, there's no easy way to find where a metaclass violation occurred. You |
148 | may still pass such an element if you have one. However, since you probably do |
149 | not, you should be exact in your violation's description. |
150 | |
151 | =item C<violates_metaclass> |
152 | |
153 | This method is required to be overridden by subclasses. It takes a metaclass |
154 | object and the L<Perl::Critic::Document> representing the entire compilation |
155 | unit. It is expected to return a list of L<Perl::Critic::Violation> objects. |
156 | |
157 | =over |
158 | |
159 | =head1 POLICIES |
160 | |
e556eafb |
161 | The included policies are: |
162 | |
163 | =over 4 |
164 | |
165 | =item L<Perl::Critic::Policy::DynamicMoose::ProhibitPublicBuilders> |
166 | |
167 | Prohibit public builder methods for attributes. [Severity: 3] |
168 | |
169 | =back |
170 | |
ea5503e8 |
171 | =head1 WARNING |
172 | |
173 | B<VERY IMPORTANT:> Most L<Perl::Critic> Policies (including all the ones that |
174 | ship with Perl::Critic> use pure static analysis -- they never compile nor |
175 | execute any of the code that they analyze. However, this policy is very |
176 | different. It actually attempts to compile your code and then compares the |
177 | subroutines mentioned in your code to those found in the symbol table. |
178 | Therefore you should B<not> use this Policy on any code that you do not trust, |
179 | or may have undesirable side-effects at compile-time (such as connecting to the |
180 | network or mutating files). |
181 | |
182 | For this Policy to work, all the modules included in your code must be |
183 | installed locally, and must compile without error. |
184 | |
e556eafb |
185 | =head1 AUTHOR |
186 | |
187 | Shawn M Moore, C<sartak@bestpractical.com> |
188 | |
189 | =cut |
190 | |