Filename | /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/Perl/Critic/Policy/Documentation/RequirePodLinksIncludeText.pm |
Statements | Executed 24 statements in 691µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 295µs | 425µs | BEGIN@20 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 16µs | 16µs | BEGIN@10 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 9µs | 11µs | default_severity | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 8µs | 8µs | supported_parameters | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 8µs | 28µs | BEGIN@15 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 8µs | 357µs | BEGIN@17 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 8µs | 68µs | BEGIN@18 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 7µs | 382µs | BEGIN@16 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 7µs | 11µs | BEGIN@13 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
1 | 1 | 1 | 7µs | 18µs | BEGIN@12 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
0 | 0 | 0 | 0s | 0s | __ANON__[:127] | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
0 | 0 | 0 | 0s | 0s | _allowed_link | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
0 | 0 | 0 | 0s | 0s | applies_to | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
0 | 0 | 0 | 0s | 0s | default_themes | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
0 | 0 | 0 | 0s | 0s | violates | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::
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::Documentation::RequirePodLinksIncludeText; | ||||
9 | |||||
10 | 2 | 40µs | 1 | 16µs | # spent 16µs within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::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::Documentation::RequirePodLinksIncludeText::BEGIN@10 |
11 | |||||
12 | 2 | 20µs | 2 | 29µs | # spent 18µs (7+11) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@12 which was called:
# once (7µs+11µs) by Module::Pluggable::Object::_require at line 12 # spent 18µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@12
# spent 11µs making 1 call to strict::import |
13 | 2 | 22µs | 2 | 14µs | # spent 11µs (7+4) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@13 which was called:
# once (7µs+4µs) by Module::Pluggable::Object::_require at line 13 # spent 11µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@13
# spent 4µs making 1 call to warnings::import |
14 | |||||
15 | 2 | 22µs | 2 | 48µs | # spent 28µs (8+20) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@15 which was called:
# once (8µs+20µs) by Module::Pluggable::Object::_require at line 15 # spent 28µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@15
# spent 20µs making 1 call to Exporter::import |
16 | 2 | 25µs | 2 | 757µs | # spent 382µs (7+375) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@16 which was called:
# once (7µs+375µs) by Module::Pluggable::Object::_require at line 16 # spent 382µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@16
# spent 375µs making 1 call to English::import |
17 | 2 | 24µs | 2 | 706µs | # spent 357µs (8+349) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@17 which was called:
# once (8µs+349µs) by Module::Pluggable::Object::_require at line 17 # spent 357µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@17
# spent 349µs making 1 call to Exporter::import |
18 | 2 | 23µs | 2 | 128µs | # spent 68µs (8+60) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@18 which was called:
# once (8µs+60µs) by Module::Pluggable::Object::_require at line 18 # spent 68µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@18
# spent 60µs making 1 call to base::import |
19 | |||||
20 | 2 | 487µs | 2 | 441µs | # spent 425µs (295+130) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@20 which was called:
# once (295µs+130µs) by Module::Pluggable::Object::_require at line 20 # spent 425µs making 1 call to Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@20
# spent 16µs making 1 call to Exporter::import |
21 | |||||
22 | #----------------------------------------------------------------------------- | ||||
23 | |||||
24 | 1 | 600ns | our $VERSION = '1.121'; | ||
25 | |||||
26 | #----------------------------------------------------------------------------- | ||||
27 | |||||
28 | 1 | 2µs | 1 | 33µs | Readonly::Scalar my $EXPL => 'Without text, you are at the mercy of the POD translator'; # spent 33µs making 1 call to Readonly::Scalar |
29 | |||||
30 | #----------------------------------------------------------------------------- | ||||
31 | |||||
32 | # spent 8µs within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::supported_parameters which was called:
# once (8µs+0s) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm | ||||
33 | return ( | ||||
34 | { | ||||
35 | 1 | 10µs | name => 'allow_external_sections', | ||
36 | description => 'Allow external sections without text', | ||||
37 | default_string => '1', | ||||
38 | behavior => 'boolean', | ||||
39 | }, | ||||
40 | { | ||||
41 | name => 'allow_internal_sections', | ||||
42 | description => 'Allow internal sections without text', | ||||
43 | default_string => '1', | ||||
44 | behavior => 'boolean', | ||||
45 | }, | ||||
46 | ); | ||||
47 | } | ||||
48 | 1 | 2µs | # spent 11µs (9+2) within Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::default_severity which was called:
# once (9µs+2µs) by Perl::Critic::Policy::get_severity at line 331 of Perl/Critic/Policy.pm | ||
49 | sub default_themes { return qw(core maintenance) } | ||||
50 | sub applies_to { return 'PPI::Token::Pod' } | ||||
51 | |||||
52 | #----------------------------------------------------------------------------- | ||||
53 | |||||
54 | 1 | 1µs | 1 | 22µs | Readonly::Scalar my $INCREMENT_NESTING => 1; # spent 22µs making 1 call to Readonly::Scalar |
55 | 1 | 1µs | 1 | 21µs | Readonly::Scalar my $DECREMENT_NESTING => -1; # spent 21µs making 1 call to Readonly::Scalar |
56 | 1 | 2µs | 1 | 44µs | Readonly::Hash my %ESCAPE_NESTING => ( # spent 44µs making 1 call to Readonly::Hash |
57 | '<' => $INCREMENT_NESTING, | ||||
58 | '>' => $DECREMENT_NESTING, | ||||
59 | ); | ||||
60 | |||||
61 | sub violates { | ||||
62 | my ( $self, $elem, $doc ) = @_; | ||||
63 | |||||
64 | my @violations; | ||||
65 | |||||
66 | =begin comment | ||||
67 | |||||
68 | my $pod = $elem->content(); | ||||
69 | |||||
70 | # We look for _any_ POD escape, not just L<>. This way we can avoid false | ||||
71 | # positives on constructions like C<< L<Foo> >>. In an attempt to be | ||||
72 | # upward compatible (and at a slight (I hope!) risk of false negatives), | ||||
73 | # we accept any upper case letter as beginning a formatting sequence, not | ||||
74 | # just [IBCLEFSXZ]. | ||||
75 | SCAN_POD: | ||||
76 | while ( $pod =~ m/ ( [[:upper:]] ) ( <+ ) /smxg ) { | ||||
77 | |||||
78 | # Collect the results of the match. | ||||
79 | my $formatter = $1; | ||||
80 | my $link_start = $LAST_MATCH_START[0]; | ||||
81 | my $content_start = $LAST_MATCH_END[0]; | ||||
82 | my $num_brkt = length $2; | ||||
83 | |||||
84 | # The only way to handle arbitrarily-nested brackets before Perl | ||||
85 | # 5.10 is the (??{}) construction, which is _still_ marked | ||||
86 | # 'experimental' as of 5.12.3 and 5.13.9. Taking them at their | ||||
87 | # word, I'm going to find the end of the POD escape the hard | ||||
88 | # way. | ||||
89 | my $link_end = $link_start + 1; | ||||
90 | my $nest = 0; | ||||
91 | while ( 1 ) { | ||||
92 | $nest += $ESCAPE_NESTING{ substr $pod, $link_end++, 1 } || 0; | ||||
93 | $nest or last; | ||||
94 | $link_end < length $pod | ||||
95 | or last SCAN_POD; | ||||
96 | } | ||||
97 | |||||
98 | # Manually advance past the end of the link so the regular | ||||
99 | # expression does not find any possible nested formatting. | ||||
100 | pos $pod = $link_end; | ||||
101 | |||||
102 | # If it's not an 'L' formatter, we are not interested. | ||||
103 | 'L' eq $formatter or next; | ||||
104 | |||||
105 | # Save both the link itself and its contents for further analysis. | ||||
106 | my $link = substr $pod, $link_start, $link_end - $link_start; | ||||
107 | my $content = substr $pod, $content_start, | ||||
108 | $link_end - $num_brkt - $content_start; | ||||
109 | |||||
110 | # If the link is allowed, pass on to the next one. | ||||
111 | $self->_allowed_link( $content ) and next; | ||||
112 | |||||
113 | # A-Hah! Gotcha! | ||||
114 | my $line_number = $elem->line_number() + ( | ||||
115 | substr( $pod, 0, $link_start ) =~ tr/\n/\n/ ); | ||||
116 | push @violations, $self->violation( | ||||
117 | "Link $link on line $line_number does not specify text", | ||||
118 | $EXPL, $elem ); | ||||
119 | |||||
120 | } | ||||
121 | |||||
122 | =end comment | ||||
123 | |||||
124 | =cut | ||||
125 | |||||
126 | my $parser = Perl::Critic::Utils::POD::ParseInteriorSequence->new(); | ||||
127 | $parser->errorsub( sub { return 1 } ); # Suppress error messages. | ||||
128 | |||||
129 | foreach my $seq ( $parser->get_interior_sequences( $elem->content() ) ) { | ||||
130 | |||||
131 | # Not interested in nested thing like C<< L<Foo> >>. I think. | ||||
132 | $seq->nested() and next; | ||||
133 | |||||
134 | # Not interested in anything but L<...>. | ||||
135 | 'L' eq $seq->cmd_name() or next; | ||||
136 | |||||
137 | # If the link is allowed, pass on to the next one. | ||||
138 | $self->_allowed_link( $seq ) and next; | ||||
139 | |||||
140 | # A-Hah! Gotcha! | ||||
141 | my $line_number = $elem->line_number() + ( $seq->file_line() )[1] - 1; | ||||
142 | push @violations, $self->violation( | ||||
143 | join( $SPACE, 'Link', $seq->raw_text(), | ||||
144 | "on line $line_number does not specify text" ), | ||||
145 | $EXPL, $elem ); | ||||
146 | } | ||||
147 | |||||
148 | return @violations; | ||||
149 | } | ||||
150 | |||||
151 | sub _allowed_link { | ||||
152 | |||||
153 | =begin comment | ||||
154 | |||||
155 | my ( $self, $content ) = @_; | ||||
156 | |||||
157 | =end comment | ||||
158 | |||||
159 | =cut | ||||
160 | |||||
161 | my ( $self, $pod_seq ) = @_; | ||||
162 | |||||
163 | # Extract the content of the sequence. | ||||
164 | my $content = $pod_seq->raw_text(); | ||||
165 | $content = substr $content, 0, - length $pod_seq->right_delimiter(); | ||||
166 | $content = substr $content, length( $pod_seq->cmd_name() ) + length( | ||||
167 | $pod_seq->left_delimiter() ); | ||||
168 | |||||
169 | # Not interested in hyperlinks. | ||||
170 | $content =~ m{ \A \w+ : (?! : ) }smx | ||||
171 | and return $TRUE; | ||||
172 | |||||
173 | # Links with text specified are good. | ||||
174 | $content =~ m/ [|] /smx | ||||
175 | and return $TRUE; | ||||
176 | |||||
177 | # Internal sections without text are either good or bad, depending on how | ||||
178 | # we are configured. | ||||
179 | $content =~ m{ \A [/"] }smx | ||||
180 | and return $self->{_allow_internal_sections}; | ||||
181 | |||||
182 | # External sections without text are either good or bad, depending on how | ||||
183 | # we are configured. | ||||
184 | $content =~ m{ / }smx | ||||
185 | and return $self->{_allow_external_sections}; | ||||
186 | |||||
187 | # Anything else without text is bad. | ||||
188 | return $FALSE; | ||||
189 | } | ||||
190 | |||||
191 | 1 | 8µs | 1; | ||
192 | |||||
193 | __END__ |