Filename | /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm |
Statements | Executed 20 statements in 695µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.07ms | 18.3ms | BEGIN@16 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 16µs | 16µs | BEGIN@10 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 16µs | 18µs | supported_parameters | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 9µs | 412µs | BEGIN@18 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 8µs | 69µs | BEGIN@19 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 8µs | 28µs | BEGIN@14 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 8µs | 11µs | BEGIN@12 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 7µs | 18µs | BEGIN@11 | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
1 | 1 | 1 | 6µs | 7µs | default_severity | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | _contains_rcs_variable | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | _looks_like_email_address | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | _looks_like_use_vars | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | _needs_interpolation | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | applies_to | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | default_themes | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | initialize_if_enabled | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
0 | 0 | 0 | 0s | 0s | violates | Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | ############################################################################## | ||||
2 | # $URL$ | ||||
3 | # $Date$ | ||||
4 | # $Author$ | ||||
5 | # $Revision$ | ||||
6 | ############################################################################## | ||||
7 | |||||
8 | package Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars; | ||||
9 | |||||
10 | 2 | 39µs | 1 | 16µs | # spent 16µs within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@10 which was called:
# once (16µs+0s) by Module::Pluggable::Object::_require at line 10 # spent 16µs making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@10 |
11 | 2 | 23µs | 2 | 29µs | # spent 18µs (7+11) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@11 which was called:
# once (7µs+11µs) by Module::Pluggable::Object::_require at line 11 # spent 18µs making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@11
# spent 11µs making 1 call to strict::import |
12 | 2 | 19µs | 2 | 15µs | # spent 11µs (8+4) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@12 which was called:
# once (8µs+4µs) by Module::Pluggable::Object::_require at line 12 # spent 11µs making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@12
# spent 4µs making 1 call to warnings::import |
13 | |||||
14 | 2 | 20µs | 2 | 49µs | # spent 28µs (8+20) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@14 which was called:
# once (8µs+20µs) by Module::Pluggable::Object::_require at line 14 # spent 28µs making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@14
# spent 20µs making 1 call to Exporter::import |
15 | |||||
16 | 2 | 91µs | 1 | 18.3ms | # spent 18.3ms (2.07+16.2) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@16 which was called:
# once (2.07ms+16.2ms) by Module::Pluggable::Object::_require at line 16 # spent 18.3ms making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@16 |
17 | |||||
18 | 2 | 28µs | 2 | 815µs | # spent 412µs (9+403) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@18 which was called:
# once (9µs+403µs) by Module::Pluggable::Object::_require at line 18 # spent 412µs making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@18
# spent 403µs making 1 call to Exporter::import |
19 | 2 | 453µs | 2 | 130µs | # spent 69µs (8+61) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@19 which was called:
# once (8µs+61µs) by Module::Pluggable::Object::_require at line 19 # spent 69µs making 1 call to Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::BEGIN@19
# spent 61µs making 1 call to base::import |
20 | |||||
21 | #----------------------------------------------------------------------------- | ||||
22 | |||||
23 | 1 | 600ns | our $VERSION = '1.121'; | ||
24 | |||||
25 | #----------------------------------------------------------------------------- | ||||
26 | |||||
27 | 1 | 2µs | 1 | 44µs | Readonly::Scalar my $DESC => q<String *may* require interpolation>; # spent 44µs making 1 call to Readonly::Scalar |
28 | 1 | 2µs | 1 | 53µs | Readonly::Scalar my $EXPL => [ 51 ]; # spent 53µs making 1 call to Readonly::Scalar |
29 | |||||
30 | #----------------------------------------------------------------------------- | ||||
31 | |||||
32 | # spent 18µs (16+3) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::supported_parameters which was called:
# once (16µs+3µs) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm | ||||
33 | return ( | ||||
34 | { | ||||
35 | 1 | 13µs | 2 | 3µs | name => 'rcs_keywords', # spent 3µs making 2 calls to Readonly::Scalar::FETCH, avg 1µs/call |
36 | description => 'RCS keywords to ignore in potential interpolation.', | ||||
37 | default_string => $EMPTY, | ||||
38 | behavior => 'string list', | ||||
39 | }, | ||||
40 | ); | ||||
41 | } | ||||
42 | |||||
43 | 1 | 2µs | # spent 7µs (6+1) within Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars::default_severity which was called:
# once (6µs+1µs) by Perl::Critic::Policy::get_severity at line 331 of Perl/Critic/Policy.pm | ||
44 | sub default_themes { return qw(core pbp cosmetic) } | ||||
45 | |||||
46 | sub applies_to { | ||||
47 | return qw< PPI::Token::Quote::Single PPI::Token::Quote::Literal >; | ||||
48 | } | ||||
49 | |||||
50 | #----------------------------------------------------------------------------- | ||||
51 | |||||
52 | sub initialize_if_enabled { | ||||
53 | my ($self, $config) = @_; | ||||
54 | |||||
55 | my $rcs_keywords = $self->{_rcs_keywords}; | ||||
56 | my @rcs_keywords = keys %{$rcs_keywords}; | ||||
57 | |||||
58 | if (@rcs_keywords) { | ||||
59 | my $rcs_regexes = [ map { qr/ \$ $_ [^\n\$]* \$ /xms } @rcs_keywords ]; | ||||
60 | $self->{_rcs_regexes} = $rcs_regexes; | ||||
61 | } | ||||
62 | |||||
63 | return $TRUE; | ||||
64 | } | ||||
65 | |||||
66 | sub violates { | ||||
67 | my ( $self, $elem, undef ) = @_; | ||||
68 | |||||
69 | # The string() method strips off the quotes | ||||
70 | my $string = $elem->string(); | ||||
71 | return if not _needs_interpolation($string); | ||||
72 | return if _looks_like_email_address($string); | ||||
73 | return if _looks_like_use_vars($elem); | ||||
74 | |||||
75 | my $rcs_regexes = $self->{_rcs_regexes}; | ||||
76 | return if $rcs_regexes and _contains_rcs_variable($string, $rcs_regexes); | ||||
77 | |||||
78 | return $self->violation( $DESC, $EXPL, $elem ); | ||||
79 | } | ||||
80 | |||||
81 | #----------------------------------------------------------------------------- | ||||
82 | |||||
83 | sub _needs_interpolation { | ||||
84 | my ($string) = @_; | ||||
85 | |||||
86 | return | ||||
87 | # Contains a $ or @ not followed by "{}". | ||||
88 | $string =~ m< [\$\@] (?! [{] [}] ) \S+ >xms | ||||
89 | # Contains metachars | ||||
90 | # Note that \1 ... are not documented (that I can find), but are | ||||
91 | # treated the same way as \0 by S_scan_const in toke.c, at least | ||||
92 | # for regular double-quotish strings. Not, obviously, where | ||||
93 | # regexes are involved. | ||||
94 | || $string =~ m< | ||||
95 | (?: \A | [^\\] ) | ||||
96 | (?: \\{2} )* | ||||
97 | \\ [tnrfbae01234567xcNluLUEQ] | ||||
98 | >xms; | ||||
99 | } | ||||
100 | |||||
101 | #----------------------------------------------------------------------------- | ||||
102 | |||||
103 | sub _looks_like_email_address { | ||||
104 | my ($string) = @_; | ||||
105 | |||||
106 | return if index ($string, q<@>) < 0; | ||||
107 | return if $string =~ m< \W \@ >xms; | ||||
108 | return if $string =~ m< \A \@ \w+ \b >xms; | ||||
109 | |||||
110 | return $string =~ $Email::Address::addr_spec; | ||||
111 | } | ||||
112 | |||||
113 | #----------------------------------------------------------------------------- | ||||
114 | |||||
115 | sub _contains_rcs_variable { | ||||
116 | my ($string, $rcs_regexes) = @_; | ||||
117 | |||||
118 | foreach my $regex ( @{$rcs_regexes} ) { | ||||
119 | return $TRUE if $string =~ m/$regex/xms; | ||||
120 | } | ||||
121 | |||||
122 | return; | ||||
123 | } | ||||
124 | |||||
125 | #----------------------------------------------------------------------------- | ||||
126 | |||||
127 | sub _looks_like_use_vars { | ||||
128 | my ($elem) = @_; | ||||
129 | |||||
130 | my $statement = $elem; | ||||
131 | while ( not $statement->isa('PPI::Statement::Include') ) { | ||||
132 | $statement = $statement->parent() or return; | ||||
133 | } | ||||
134 | |||||
135 | return if $statement->type() ne q<use>; | ||||
136 | return $statement->module() eq q<vars>; | ||||
137 | } | ||||
138 | |||||
139 | 1 | 4µs | 1; | ||
140 | |||||
141 | __END__ |