← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:11 2016

Filename/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/Perl/Critic/Policy/NamingConventions/Capitalization.pm
StatementsExecuted 41 statements in 2.29ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111501µs27.3msPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@29Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@29
111231µs325µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@25Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@25
11166µs78µsPerl::Critic::Policy::NamingConventions::Capitalization::::supported_parametersPerl::Critic::Policy::NamingConventions::Capitalization::supported_parameters
11116µs16µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@10Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@10
1119µs27µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@19Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@19
1118µs22µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@20Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@20
1118µs27µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@26Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@26
7718µs8µsPerl::Critic::Policy::NamingConventions::Capitalization::::CORE:qrPerl::Critic::Policy::NamingConventions::Capitalization::CORE:qr (opcode)
1118µs26µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@15Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@15
1118µs63µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@33Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@33
1117µs11µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@12Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@12
1117µs138µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@17Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@17
1117µs18µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@11Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@11
1117µs366µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@14Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@14
1117µs396µsPerl::Critic::Policy::NamingConventions::Capitalization::::BEGIN@21Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@21
1116µs7µsPerl::Critic::Policy::NamingConventions::Capitalization::::default_severityPerl::Critic::Policy::NamingConventions::Capitalization::default_severity
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::__ANON__[:250]Perl::Critic::Policy::NamingConventions::Capitalization::__ANON__[:250]
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_check_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_check_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_constant_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_constant_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_derive_capitalization_exemption_test_regexesPerl::Critic::Policy::NamingConventions::Capitalization::_derive_capitalization_exemption_test_regexes
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_derive_capitalization_test_regex_and_messagePerl::Critic::Policy::NamingConventions::Capitalization::_derive_capitalization_test_regex_and_message
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_foreach_variable_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_foreach_variable_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_is_directly_in_scope_blockPerl::Critic::Policy::NamingConventions::Capitalization::_is_directly_in_scope_block
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_is_not_real_labelPerl::Critic::Policy::NamingConventions::Capitalization::_is_not_real_label
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_label_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_label_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_name_is_exemptPerl::Critic::Policy::NamingConventions::Capitalization::_name_is_exempt
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_package_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_package_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_subroutine_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_subroutine_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::_variable_capitalizationPerl::Critic::Policy::NamingConventions::Capitalization::_variable_capitalization
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::applies_toPerl::Critic::Policy::NamingConventions::Capitalization::applies_to
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::default_themesPerl::Critic::Policy::NamingConventions::Capitalization::default_themes
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::initialize_if_enabledPerl::Critic::Policy::NamingConventions::Capitalization::initialize_if_enabled
0000s0sPerl::Critic::Policy::NamingConventions::Capitalization::::violatesPerl::Critic::Policy::NamingConventions::Capitalization::violates
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1##############################################################################
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6##############################################################################
7
8package Perl::Critic::Policy::NamingConventions::Capitalization;
9
10242µs116µs
# spent 16µs within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@10 which was called: # once (16µs+0s) by Module::Pluggable::Object::_require at line 10
use 5.006001;
# spent 16µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@10
11220µs230µs
# spent 18µs (7+11) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@11 which was called: # once (7µs+11µs) by Module::Pluggable::Object::_require at line 11
use strict;
# spent 18µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@11 # spent 11µs making 1 call to strict::import
12221µs215µs
# spent 11µs (7+4) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@12 which was called: # once (7µs+4µs) by Module::Pluggable::Object::_require at line 12
use warnings;
# spent 11µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@12 # spent 4µs making 1 call to warnings::import
13
14222µs2724µs
# spent 366µs (7+358) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@14 which was called: # once (7µs+358µs) by Module::Pluggable::Object::_require at line 14
use English qw< -no_match_vars >;
# spent 366µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@14 # spent 358µs making 1 call to English::import
15222µs245µs
# spent 26µs (8+19) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@15 which was called: # once (8µs+19µs) by Module::Pluggable::Object::_require at line 15
use Readonly;
# spent 26µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@15 # spent 19µs making 1 call to Exporter::import
16
17222µs2268µs
# spent 138µs (7+130) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@17 which was called: # once (7µs+130µs) by Module::Pluggable::Object::_require at line 17
use List::MoreUtils qw< any >;
# spent 138µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@17 # spent 130µs making 1 call to Exporter::Tiny::import
18
19221µs246µs
# spent 27µs (9+18) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@19 which was called: # once (9µs+18µs) by Module::Pluggable::Object::_require at line 19
use Perl::Critic::Exception::AggregateConfiguration;
# spent 27µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@19 # spent 18µs making 1 call to Exporter::import
20224µs235µs
# spent 22µs (8+14) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@20 which was called: # once (8µs+14µs) by Module::Pluggable::Object::_require at line 20
use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue;
# spent 22µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@20 # spent 14µs making 1 call to Exporter::import
211200ns
# spent 396µs (7+390) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@21 which was called: # once (7µs+390µs) by Module::Pluggable::Object::_require at line 24
use Perl::Critic::Utils qw<
22 :booleans :characters :severities
23 hashify is_perl_global
24124µs2786µs>;
# spent 396µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@21 # spent 390µs making 1 call to Exporter::import
25292µs2353µs
# spent 325µs (231+94) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@25 which was called: # once (231µs+94µs) by Module::Pluggable::Object::_require at line 25
use Perl::Critic::Utils::Perl qw< symbol_without_sigil >;
# spent 325µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@25 # spent 28µs making 1 call to Exporter::import
261400ns
# spent 27µs (8+19) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@26 which was called: # once (8µs+19µs) by Module::Pluggable::Object::_require at line 28
use Perl::Critic::Utils::PPI qw<
27 is_in_subroutine
28122µs246µs>;
# spent 27µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@26 # spent 19µs making 1 call to Exporter::import
29166µs
# spent 27.3ms (501µs+26.8) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@29 which was called: # once (501µs+26.8ms) by Module::Pluggable::Object::_require at line 31
use PPIx::Utilities::Statement qw<
30 get_constant_name_elements_from_declaring_statement
31131µs227.3ms>;
# spent 27.3ms making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@29 # spent 30µs making 1 call to Exporter::import
32
3321.72ms2118µs
# spent 63µs (8+55) within Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@33 which was called: # once (8µs+55µs) by Module::Pluggable::Object::_require at line 33
use base 'Perl::Critic::Policy';
# spent 63µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::BEGIN@33 # spent 55µs making 1 call to base::import
34
351600nsour $VERSION = '1.121';
36
37#-----------------------------------------------------------------------------
38
39# Don't worry about leading digits-- let perl/PPI do that.
40111µs244µsReadonly::Scalar my $ALL_ONE_CASE_REGEX =>
# spent 42µs making 1 call to Readonly::Scalar # spent 2µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
41 qr< \A [@%\$]? (?: [[:lower:]_\d]+ | [[:upper:]_\d]+ ) \z >xms;
4215µs223µsReadonly::Scalar my $ALL_LOWER_REGEX => qr< \A [[:lower:]_\d]+ \z >xms;
# spent 22µs making 1 call to Readonly::Scalar # spent 1µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
4314µs221µsReadonly::Scalar my $ALL_UPPER_REGEX => qr< \A [[:upper:]_\d]+ \z >xms;
# spent 20µs making 1 call to Readonly::Scalar # spent 900ns making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
4414µs221µsReadonly::Scalar my $STARTS_WITH_LOWER_REGEX => qr< \A _* [[:lower:]\d] >xms;
# spent 20µs making 1 call to Readonly::Scalar # spent 900ns making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
4514µs221µsReadonly::Scalar my $STARTS_WITH_UPPER_REGEX => qr< \A _* [[:upper:]\d] >xms;
# spent 20µs making 1 call to Readonly::Scalar # spent 900ns making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
4614µs221µsReadonly::Scalar my $NO_RESTRICTION_REGEX => qr< . >xms;
# spent 20µs making 1 call to Readonly::Scalar # spent 900ns making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
47
48127µs13186µsReadonly::Hash my %CAPITALIZATION_SCHEME_TAGS => (
# spent 174µs making 1 call to Readonly::Hash # spent 12µs making 12 calls to Readonly::Scalar::FETCH, avg 1µs/call
49 ':single_case' => {
50 regex => $ALL_ONE_CASE_REGEX,
51 regex_violation => 'is not all lower case or all upper case',
52 },
53 ':all_lower' => {
54 regex => $ALL_LOWER_REGEX,
55 regex_violation => 'is not all lower case',
56 },
57 ':all_upper' => {
58 regex => $ALL_UPPER_REGEX,
59 regex_violation => 'is not all upper case',
60 },
61 ':starts_with_lower' => {
62 regex => $STARTS_WITH_LOWER_REGEX,
63 regex_violation => 'does not start with a lower case letter',
64 },
65 ':starts_with_upper' => {
66 regex => $STARTS_WITH_UPPER_REGEX,
67 regex_violation => 'does not start with a upper case letter',
68 },
69 ':no_restriction' => {
70 regex => $NO_RESTRICTION_REGEX,
71 regex_violation => 'there is a bug in Perl::Critic if you are reading this',
72 },
73);
74
7516µs223µsReadonly::Scalar my $PACKAGE_REGEX => qr/ :: | ' /xms;
# spent 22µs making 1 call to Readonly::Scalar # spent 1µs making 1 call to Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr
76
7711µs129µsReadonly::Hash my %NAME_FOR_TYPE => (
# spent 29µs making 1 call to Readonly::Hash
78 package => 'Package',
79 subroutine => 'Subroutine',
80 local_lexical_variable => 'Local lexical variable',
81 scoped_lexical_variable => 'Scoped lexical variable',
82 file_lexical_variable => 'File lexical variable',
83 global_variable => 'Global variable',
84 constant => 'Constant',
85 label => 'Label',
86);
87
8813µs233µsReadonly::Hash my %IS_COMMA => hashify( $COMMA, $FATCOMMA );
# spent 20µs making 1 call to Readonly::Hash # spent 14µs making 1 call to Perl::Critic::Utils::hashify
89
9012µs149µsReadonly::Scalar my $EXPL => [ 45, 46 ];
# spent 49µs making 1 call to Readonly::Scalar
91
92#-----------------------------------------------------------------------------
93
94# Can't handle named parameters yet.
95
# spent 78µs (66+13) within Perl::Critic::Policy::NamingConventions::Capitalization::supported_parameters which was called: # once (66µs+13µs) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm
sub supported_parameters {
96 return (
97 {
98153µs1113µs name => 'packages',
# spent 13µs making 11 calls to Readonly::Scalar::FETCH, avg 1µs/call
99 description => 'How package name components should be capitalized. Valid values are :single_case, :all_lower, :all_upper:, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
100 default_string => ':starts_with_upper',
101 behavior => 'string',
102 },
103 {
104 name => 'package_exemptions',
105 description => 'Package names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
106 default_string => 'main',
107 behavior => 'string list',
108 },
109 {
110 name => 'subroutines',
111 description => 'How subroutine names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
112 default_string => ':single_case', # Matches ProhibitMixedCaseSubs
113 behavior => 'string',
114 },
115 {
116 name => 'subroutine_exemptions',
117 description => 'Subroutine names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
118 default_string =>
119 join (
120 $SPACE,
121 qw<
122
123 AUTOLOAD BUILD BUILDARGS CLEAR CLOSE
124 DELETE DEMOLISH DESTROY EXISTS EXTEND
125 FETCH FETCHSIZE FIRSTKEY GETC NEXTKEY
126 POP PRINT PRINTF PUSH READ
127 READLINE SCALAR SHIFT SPLICE STORE
128 STORESIZE TIEARRAY TIEHANDLE TIEHASH TIESCALAR
129 UNSHIFT UNTIE WRITE
130
131 >,
132 ),
133 behavior => 'string list',
134 },
135 {
136 name => 'local_lexical_variables',
137 description => 'How local lexical variables names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
138 default_string => ':single_case', # Matches ProhibitMixedCaseVars
139 behavior => 'string',
140 },
141 {
142 name => 'local_lexical_variable_exemptions',
143 description => 'Local lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
144 default_string => $EMPTY,
145 behavior => 'string list',
146 },
147 {
148 name => 'scoped_lexical_variables',
149 description => 'How lexical variables that are scoped to a subset of subroutines, should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
150 default_string => ':single_case', # Matches ProhibitMixedCaseVars
151 behavior => 'string',
152 },
153 {
154 name => 'scoped_lexical_variable_exemptions',
155 description => 'Names for variables in anonymous blocks that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
156 default_string => $EMPTY,
157 behavior => 'string list',
158 },
159 {
160 name => 'file_lexical_variables',
161 description => 'How lexical variables at the file level should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
162 default_string => ':single_case', # Matches ProhibitMixedCaseVars
163 behavior => 'string',
164 },
165 {
166 name => 'file_lexical_variable_exemptions',
167 description => 'File-scope lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
168 default_string => $EMPTY,
169 behavior => 'string list',
170 },
171 {
172 name => 'global_variables',
173 description => 'How global (package) variables should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
174 default_string => ':single_case', # Matches ProhibitMixedCaseVars
175 behavior => 'string',
176 },
177 {
178 name => 'global_variable_exemptions',
179 description => 'Global variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
180 default_string => '\$VERSION @ISA @EXPORT(?:_OK)? %EXPORT_TAGS \$AUTOLOAD %ENV %SIG \$TODO', ## no critic (RequireInterpolation)
181 behavior => 'string list',
182 },
183 {
184 name => 'constants',
185 description => 'How constant names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
186 default_string => ':all_upper',
187 behavior => 'string',
188 },
189 {
190 name => 'constant_exemptions',
191 description => 'Constant names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
192 default_string => $EMPTY,
193 behavior => 'string list',
194 },
195 {
196 name => 'labels',
197 description => 'How labels should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.',
198 default_string => ':all_upper',
199 behavior => 'string',
200 },
201 {
202 name => 'label_exemptions',
203 description => 'Labels that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.',
204 default_string => $EMPTY,
205 behavior => 'string list',
206 },
207 );
208}
209
21012µs
# spent 7µs (6+1) within Perl::Critic::Policy::NamingConventions::Capitalization::default_severity which was called: # once (6µs+1µs) by Perl::Critic::Policy::get_severity at line 331 of Perl/Critic/Policy.pm
sub default_severity { return $SEVERITY_LOWEST }
211sub default_themes { return qw< core pbp cosmetic > }
212sub applies_to { return qw< PPI::Statement PPI::Token::Label > }
213
214#-----------------------------------------------------------------------------
215
216sub initialize_if_enabled {
217 my ($self, $config) = @_;
218
219 my $configuration_exceptions =
220 Perl::Critic::Exception::AggregateConfiguration->new();
221
222 KIND:
223 foreach my $kind_of_name ( qw<
224 package subroutine
225 local_lexical_variable scoped_lexical_variable
226 file_lexical_variable global_variable
227 constant label
228 > ) {
229 my ($capitalization_regex, $message) =
230 $self->_derive_capitalization_test_regex_and_message(
231 $kind_of_name, $configuration_exceptions,
232 );
233 my $exemption_regexes =
234 $self->_derive_capitalization_exemption_test_regexes(
235 $kind_of_name, $configuration_exceptions,
236 );
237
238 # Keep going, despite problems, so that all problems can be reported
239 # at one go, rather than the user fixing one problem, receiving a new
240 # error, etc..
241 next KIND if $configuration_exceptions->has_exceptions();
242
243 $self->{"_${kind_of_name}_test"} = sub {
244 my ($name) = @_;
245
246 return if _name_is_exempt($name, $exemption_regexes);
247
248 return $message if $name !~ m/$capitalization_regex/xms;
249 return;
250 }
251 }
252
253 if ( $configuration_exceptions->has_exceptions() ) {
254 $configuration_exceptions->throw();
255 }
256
257 return $TRUE;
258}
259
260sub _derive_capitalization_test_regex_and_message {
261 my ($self, $kind_of_name, $configuration_exceptions) = @_;
262
263 my $capitalization_option = "${kind_of_name}s";
264 my $capitalization = $self->{"_$capitalization_option"};
265
266 if ( my $tag_properties = $CAPITALIZATION_SCHEME_TAGS{$capitalization} ) {
267 return @{$tag_properties}{ qw< regex regex_violation > };
268 }
269 elsif ($capitalization =~ m< \A : >xms) {
270 $configuration_exceptions->add_exception(
271 Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new(
272 policy => $self,
273 option_name => $capitalization_option,
274 option_value => $capitalization,
275 message_suffix =>
276 'is not a known capitalization scheme tag. Valid tags are: '
277 . (join q<, >, sort keys %CAPITALIZATION_SCHEME_TAGS)
278 . $PERIOD,
279 )
280 );
281 return;
282 }
283
284 my $regex;
285 eval { $regex = qr< \A $capitalization \z >xms; }
286 or do {
287 $configuration_exceptions->add_exception(
288 Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new(
289 policy => $self,
290 option_name => $capitalization_option,
291 option_value => $capitalization,
292 message_suffix =>
293 "is not a valid regular expression: $EVAL_ERROR",
294 )
295 );
296 return;
297 };
298
299 return $regex, qq<does not match "\\A$capitalization\\z".>;
300}
301
302sub _derive_capitalization_exemption_test_regexes {
303 my ($self, $kind_of_name, $configuration_exceptions) = @_;
304
305 my $exemptions_option = "${kind_of_name}_exemptions";
306 my $exemptions = $self->{"_$exemptions_option"};
307
308 my @regexes;
309
310 PATTERN:
311 foreach my $pattern ( keys %{$exemptions} ) {
312 my $regex;
313 eval { $regex = qr< \A $pattern \z >xms; }
314 or do {
315 $configuration_exceptions->add_exception(
316 Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new(
317 policy => $self,
318 option_name => $exemptions_option,
319 option_value => $pattern,
320 message_suffix =>
321 "is not a valid regular expression: $EVAL_ERROR",
322 )
323 );
324 next PATTERN;
325 };
326
327 push @regexes, $regex;
328 }
329
330 return \@regexes;
331}
332
333sub _name_is_exempt {
334 my ($name, $exemption_regexes) = @_;
335
336 foreach my $regex ( @{$exemption_regexes} ) {
337 return $TRUE if $name =~ m/$regex/xms;
338 }
339
340 return $FALSE;
341}
342
343#-----------------------------------------------------------------------------
344
345sub violates {
346 my ( $self, $elem, undef ) = @_;
347
348 # Want given. Want 5.10. Gimme gimme gimme. :]
349 if ( $elem->isa('PPI::Statement::Variable') ) {
350 return $self->_variable_capitalization($elem);
351 }
352
353 if ( $elem->isa('PPI::Statement::Sub') ) {
354 return $self->_subroutine_capitalization($elem);
355 }
356
357 if (
358 my @names = get_constant_name_elements_from_declaring_statement($elem)
359 ) {
360 return ( grep { $_ }
361 map { $self->_constant_capitalization( $elem, $_ ) } @names )
362 }
363
364 if ( $elem->isa('PPI::Statement::Package') ) {
365 return $self->_package_capitalization($elem);
366 }
367
368 if (
369 $elem->isa('PPI::Statement::Compound') and $elem->type() eq 'foreach'
370 ) {
371 return $self->_foreach_variable_capitalization($elem);
372 }
373
374 if ( $elem->isa('PPI::Token::Label') ) {
375 return $self->_label_capitalization($elem);
376 }
377
378 return;
379}
380
381sub _variable_capitalization {
382 my ($self, $elem) = @_;
383
384 my @violations;
385
386 NAME:
387 for my $name ( map { $_->symbol() } $elem->symbols() ) {
388 if ($elem->type() eq 'local') {
389 # Fully qualified names are exempt because we can't be responsible
390 # for other people's symbols.
391 next NAME if $name =~ m/$PACKAGE_REGEX/xms;
392 next NAME if is_perl_global($name);
393
394 push
395 @violations,
396 $self->_check_capitalization(
397 symbol_without_sigil($name),
398 $name,
399 'global_variable',
400 $elem,
401 );
402 }
403 elsif ($elem->type() eq 'our') {
404 push
405 @violations,
406 $self->_check_capitalization(
407 symbol_without_sigil($name),
408 $name,
409 'global_variable',
410 $elem,
411 );
412 }
413 else {
414 # Got my or state
415 my $parent = $elem->parent();
416 if ( not $parent or $parent->isa('PPI::Document') ) {
417 push
418 @violations,
419 $self->_check_capitalization(
420 symbol_without_sigil($name),
421 $name,
422 'file_lexical_variable',
423 $elem,
424 );
425 }
426 else {
427 if ( _is_directly_in_scope_block($elem) ) {
428 push
429 @violations,
430 $self->_check_capitalization(
431 symbol_without_sigil($name),
432 $name,
433 'scoped_lexical_variable',
434 $elem,
435 );
436 }
437 else {
438 push
439 @violations,
440 $self->_check_capitalization(
441 symbol_without_sigil($name),
442 $name,
443 'local_lexical_variable',
444 $elem,
445 );
446 }
447 }
448 }
449 }
450
451 return @violations;
452}
453
454sub _subroutine_capitalization {
455 my ($self, $elem) = @_;
456
457 # These names are fixed and you've got no choice what to call them.
458 return if $elem->isa('PPI::Statement::Scheduled');
459
460 my $name = $elem->name();
461 $name =~ s{ .* :: }{}smx; # Allow for "sub Some::Package::foo {}"
462
463 return $self->_check_capitalization($name, $name, 'subroutine', $elem);
464}
465
466sub _constant_capitalization {
467 my ($self, $elem, $name) = @_;
468
469 return $self->_check_capitalization(
470 symbol_without_sigil($name), $name, 'constant', $elem,
471 );
472}
473
474sub _package_capitalization {
475 my ($self, $elem) = @_;
476
477 my $namespace = $elem->namespace();
478 my @components = split m/::/xms, $namespace;
479
480 foreach my $component (@components) {
481 my $violation =
482 $self->_check_capitalization(
483 $component, $namespace, 'package', $elem,
484 );
485 return $violation if $violation;
486 }
487
488 return;
489}
490
491sub _foreach_variable_capitalization {
492 my ($self, $elem) = @_;
493
494 my $type;
495 my $symbol;
496 my $second_element = $elem->schild(1);
497 return if not $second_element;
498
499 if ($second_element->isa('PPI::Token::Word')) {
500 $type = $second_element->content();
501 $symbol = $second_element->snext_sibling();
502 } else {
503 $type = 'my';
504 $symbol = $second_element;
505 }
506
507 return if not $symbol;
508 return if not $symbol->isa('PPI::Token::Symbol');
509
510 my $name = $symbol->symbol();
511
512 if ($type eq 'local') {
513 # Fully qualified names are exempt because we can't be responsible
514 # for other people's symbols.
515 return if $name =~ m/$PACKAGE_REGEX/xms;
516 return if is_perl_global($name);
517
518 return $self->_check_capitalization(
519 symbol_without_sigil($name), $name, 'global_variable', $elem,
520 );
521 }
522 elsif ($type eq 'our') {
523 return $self->_check_capitalization(
524 symbol_without_sigil($name), $name, 'global_variable', $elem,
525 );
526 }
527
528 # Got my or state: treat as local lexical variable
529 return $self->_check_capitalization(
530 symbol_without_sigil($name), $name, 'local_lexical_variable', $elem,
531 );
532}
533
534sub _label_capitalization {
535 my ($self, $elem, $name) = @_;
536
537 return if _is_not_real_label($elem);
538 ( my $label = $elem->content() ) =~ s< \s* : \z ><>xms;
539 return $self->_check_capitalization($label, $label, 'label', $elem);
540}
541
542sub _check_capitalization {
543 my ($self, $to_match, $full_name, $name_type, $elem) = @_;
544
545 my $test = $self->{"_${name_type}_test"};
546 if ( my $message = $test->($to_match) ) {
547 return $self->violation(
548 qq<$NAME_FOR_TYPE{$name_type} "$full_name" $message>,
549 $EXPL,
550 $elem,
551 );
552 }
553
554 return;
555}
556
557
558# { my $x } parses as
559# PPI::Document
560# PPI::Statement::Compound
561# PPI::Structure::Block { ... }
562# PPI::Statement::Variable
563# PPI::Token::Word 'my'
564# PPI::Token::Symbol '$x'
565# PPI::Token::Structure ';'
566#
567# Also, type() on the PPI::Statement::Compound returns "continue". *sigh*
568#
569# The parameter is expected to be the PPI::Statement::Variable.
570sub _is_directly_in_scope_block {
571 my ($elem) = @_;
572
573
574 return if is_in_subroutine($elem);
575
576 my $parent = $elem->parent();
577 return if not $parent->isa('PPI::Structure::Block');
578
579 my $grand_parent = $parent->parent();
580 return $TRUE if not $grand_parent;
581 return $TRUE if $grand_parent->isa('PPI::Document');
582
583 return if not $grand_parent->isa('PPI::Statement::Compound');
584
585 my $type = $grand_parent->type();
586 return if not $type;
587 return if $type ne 'continue';
588
589 my $great_grand_parent = $grand_parent->parent();
590 return if
591 $great_grand_parent and not $great_grand_parent->isa('PPI::Document');
592
593 # Make sure we aren't really in a continue block.
594 my $prior_to_grand_parent = $grand_parent->sprevious_sibling();
595 return $TRUE if not $prior_to_grand_parent;
596 return $TRUE if not $prior_to_grand_parent->isa('PPI::Token::Word');
597 return $prior_to_grand_parent->content() ne 'continue';
598}
599
600sub _is_not_real_label {
601 my $elem = shift;
602
603 # PPI misparses part of a ternary expression as a label
604 # when the token to the left of the ":" is a bareword.
605 # See http://rt.cpan.org/Ticket/Display.html?id=41170
606 # For example...
607 #
608 # $foo = $condition ? undef : 1;
609 #
610 # PPI thinks that "undef" is a label. To workaround this,
611 # I'm going to check that whatever PPI thinks is the label,
612 # actually is the first token in the statement. I believe
613 # this should be true for all real labels.
614
615 my $stmnt = $elem->statement() || return;
616 my $first_child = $stmnt->schild(0) || return;
617 return $first_child ne $elem;
618}
619
620114µs1;
621
622__END__
 
# spent 8µs within Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr which was called 7 times, avg 1µs/call: # once (2µs+0s) by Module::Pluggable::Object::_require at line 40 # once (1µs+0s) by Module::Pluggable::Object::_require at line 42 # once (1µs+0s) by Module::Pluggable::Object::_require at line 75 # once (900ns+0s) by Module::Pluggable::Object::_require at line 45 # once (900ns+0s) by Module::Pluggable::Object::_require at line 43 # once (900ns+0s) by Module::Pluggable::Object::_require at line 46 # once (900ns+0s) by Module::Pluggable::Object::_require at line 44
sub Perl::Critic::Policy::NamingConventions::Capitalization::CORE:qr; # opcode
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.