| 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 | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@20 |
| 1 | 1 | 1 | 16µs | 16µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@10 |
| 1 | 1 | 1 | 9µs | 11µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::default_severity |
| 1 | 1 | 1 | 8µs | 8µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::supported_parameters |
| 1 | 1 | 1 | 8µs | 28µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@15 |
| 1 | 1 | 1 | 8µs | 357µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@17 |
| 1 | 1 | 1 | 8µs | 68µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@18 |
| 1 | 1 | 1 | 7µs | 382µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@16 |
| 1 | 1 | 1 | 7µs | 11µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@13 |
| 1 | 1 | 1 | 7µs | 18µs | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::BEGIN@12 |
| 0 | 0 | 0 | 0s | 0s | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::__ANON__[:127] |
| 0 | 0 | 0 | 0s | 0s | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::_allowed_link |
| 0 | 0 | 0 | 0s | 0s | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::applies_to |
| 0 | 0 | 0 | 0s | 0s | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::default_themes |
| 0 | 0 | 0 | 0s | 0s | Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText::violates |
| 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__ |