summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Pod/Checker.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Checker.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Checker.pm1406
1 files changed, 583 insertions, 823 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Checker.pm
index 2bff3c9c4c9..0d18aaedb10 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Checker.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Checker.pm
@@ -2,31 +2,27 @@
# Pod/Checker.pm -- check pod documents for syntax errors
#
# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
-# This file is part of "PodParser". PodParser is free software;
-# you can redistribute it and/or modify it under the same terms
-# as Perl itself.
+# This is free software; you can redistribute it and/or modify it under the
+# same terms as Perl itself.
#############################################################################
package Pod::Checker;
use strict;
+use warnings;
-use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);
-$VERSION = '1.60'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-use Pod::ParseUtils; ## for hyperlinks and lists
+our $VERSION = '1.73'; ## Current version of this package
=head1 NAME
-Pod::Checker, podchecker() - check pod documents for syntax errors
+Pod::Checker - check pod documents for syntax errors
=head1 SYNOPSIS
use Pod::Checker;
- $num_errors = podchecker($filepath, $outputpath, %options);
+ $syntax_okay = podchecker($filepath, $outputpath, %options);
- my $checker = new Pod::Checker %options;
+ my $checker = Pod::Checker->new(%options);
$checker->parse_from_file($filepath, \*STDERR);
=head1 OPTIONS/ARGUMENTS
@@ -48,6 +44,10 @@ This function can take a hash of options:
Turn warnings on/off. I<val> is usually 1 for on, but higher values
trigger additional warnings. See L<"Warnings">.
+=item B<-quiet> =E<gt> I<val>
+
+If C<val> is true, do not print any errors/warnings.
+
=back
=head1 DESCRIPTION
@@ -111,42 +111,56 @@ heading!
=item * =over on line I<N> without closing =back
+=item * You forgot a '=back' before '=headI<N>'
+
+=item * =over is the last thing in the document?!
+
The C<=over> command does not have a corresponding C<=back> before the
next heading (C<=head1> or C<=head2>) or the end of the file.
-=item * =item without previous =over
+=item * '=item' outside of any '=over'
-=item * =back without previous =over
+=item * =back without =over
An C<=item> or C<=back> command has been found outside a
C<=over>/C<=back> block.
-=item * No argument for =begin
+=item * Can't have a 0 in =over I<N>
+
+You need to indent a strictly positive number of spaces, not 0.
+
+=item * =over should be: '=over' or '=over positive_number'
+
+Either have an argumentless =over, or have its argument a strictly positive number.
+
+=item * =begin I<TARGET> without matching =end I<TARGET>
+
+A C<=begin> command was found that has no matching =end command.
+
+=item * =begin without a target?
A C<=begin> command was found that is not followed by the formatter
specification.
-=item * =end without =begin
+=item * =end I<TARGET> without matching =begin.
A standalone C<=end> command was found.
-=item * Nested =begin's
+=item * '=end' without a target?
-There were at least two consecutive C<=begin> commands without
-the corresponding C<=end>. Only one C<=begin> may be active at
-a time.
+'=end' directives need to have a target, just like =begin directives.
-=item * =for without formatter specification
+=item * '=end I<TARGET>' is invalid.
-There is no specification of the formatter after the C<=for> command.
+I<TARGET> needs to be one word
-=item * Apparent command =foo not preceded by blank line
+=item * =end I<CONTENT> doesn't match =begin I<TARGET>
-A command which has ended up in the middle of a paragraph or other command,
-such as
+I<CONTENT> needs to match =begin's I<TARGET>.
- =item one
- =item two <-- bad
+=item * =for without a target?
+
+There is no specification of the formatter after the C<=for> command.
=item * unresolved internal link I<NAME>
@@ -154,60 +168,58 @@ The given link to I<NAME> does not have a matching node in the current
POD. This also happened when a single word node name is not enclosed in
C<"">.
-=item * Unknown command "I<CMD>"
+=item * Unknown directive: I<CMD>
An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
C<=for>, C<=pod>, C<=cut>
-=item * Unknown interior-sequence "I<SEQ>"
+=item * Deleting unknown formatting code I<SEQ>
An invalid markup command has been encountered. Valid are:
C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
C<ZE<lt>E<gt>>
-=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
+=item * Unterminated I<SEQ>E<lt>E<gt> sequence
-Two nested identical markup commands have been found. Generally this
-does not make sense.
+An unclosed formatting code
-=item * garbled entity I<STRING>
+=item * An EE<lt>...E<gt> surrounding strange content
The I<STRING> found cannot be interpreted as a character entity.
-=item * Entity number out of range
+=item * An empty EE<lt>E<gt>
-An entity specified by number (dec, hex, oct) is out of range (1-255).
+=item * An empty C<< LE<lt>E<gt> >>
-=item * malformed link LE<lt>E<gt>
+=item * An empty XE<lt>E<gt>
-The link found cannot be parsed because it does not conform to the
-syntax described in L<perlpod>.
+There needs to be content inside E, L, and X formatting codes.
-=item * nonempty ZE<lt>E<gt>
+=item * A non-empty ZE<lt>E<gt>
The C<ZE<lt>E<gt>> sequence is supposed to be empty.
-=item * empty XE<lt>E<gt>
-
-The index entry specified contains nothing but whitespace.
-
=item * Spurious text after =pod / =cut
The commands C<=pod> and C<=cut> do not take any arguments.
-=item * Spurious =cut command
+=item * =back doesn't take any parameters, but you said =back I<ARGUMENT>
-A C<=cut> command was found without a preceding POD paragraph.
+The C<=back> command does not take any arguments.
-=item * Spurious =pod command
+=item * =pod directives shouldn't be over one line long! Ignoring all I<N> lines of content
-A C<=pod> command was found after a preceding POD paragraph.
+Self explanatory
-=item * Spurious character(s) after =back
+=item * =cut found outside a pod block.
-The C<=back> command does not take any arguments.
+A '=cut' directive found in the middle of non-POD
+
+=item * Invalid =encoding syntax: I<CONTENT>
+
+Syntax error in =encoding directive
=back
@@ -217,7 +229,12 @@ These may not necessarily cause trouble, but indicate mediocre style.
=over 4
-=item * multiple occurrence of link target I<name>
+=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
+
+Two nested identical markup commands have been found. Generally this
+does not make sense.
+
+=item * multiple occurrences (I<N>) of link target I<name>
The POD file has some C<=item> and/or C<=head> commands that have
the same text. Potential hyperlinks to such a text cannot be unique then.
@@ -229,59 +246,46 @@ There is some whitespace on a seemingly empty line. POD is very sensitive
to such things, so this is flagged. B<vi> users switch on the B<list>
option to avoid this problem.
-=begin _disabled_
-
-=item * file does not start with =head
+=item * =item has no contents
-The file starts with a different POD directive than head.
-This is most probably something you do not want.
+There is a list C<=item> that has no text contents. You probably want to delete
+empty items.
-=end _disabled_
-
-=item * previous =item has no contents
-
-There is a list C<=item> right above the flagged line that has no
-text contents. You probably want to delete empty items.
-
-=item * preceding non-item paragraph(s)
+=item * You can't have =items (as at line I<N>) unless the first thing after the =over is an =item
A list introduced by C<=over> starts with a text or verbatim paragraph,
but continues with C<=item>s. Move the non-item paragraph out of the
C<=over>/C<=back> block.
-=item * =item type mismatch (I<one> vs. I<two>)
+=item * Expected '=item I<EXPECTED VALUE>'
+
+=item * Expected '=item *'
+
+=item * Possible =item type mismatch: 'I<x>' found leading a supposed definition =item
A list started with e.g. a bullet-like C<=item> and continued with a
numbered one. This is obviously inconsistent. For most translators the
type of the I<first> C<=item> determines the type of the list.
-=item * I<N> unescaped C<E<lt>E<gt>> in paragraph
+=item * You have '=item x' instead of the expected '=item I<N>'
-Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>
-can potentially cause errors as they could be misinterpreted as
-markup commands. This is only printed when the -warnings level is
-greater than 1.
+Erroneous numbering of =item numbers; they need to ascend consecutively.
-=item * Unknown entity
+=item * Unknown E content in EE<lt>I<CONTENT>E<gt>
A character entity was found that does not belong to the standard
-ISO set or the POD specials C<verbar> and C<sol>.
-
-=item * No items in =over
+ISO set or the POD specials C<verbar> and C<sol>. I<Currently, this warning
+only appears if a character entity was found that does not have a Unicode
+character. This should be fixed to adhere to the original warning.>
-The list opened with C<=over> does not contain any items.
+=item * empty =over/=back block
-=item * No argument for =item
-
-C<=item> without any parameters is deprecated. It should either be followed
-by C<*> to indicate an unordered list, by a number (optionally followed
-by a dot) to indicate an ordered (numbered) list or simple text for a
-definition list.
+The list opened with C<=over> does not contain anything.
=item * empty section in previous paragraph
The previous section (introduced by a C<=head> command) does not contain
-any text. This usually indicates that something is missing. Note: A
+any valid content. This usually indicates that something is missing. Note: A
C<=head1> followed immediately by C<=head2> does not trigger this warning.
=item * Verbatim paragraph in NAME section
@@ -308,14 +312,6 @@ There are some warnings with respect to malformed hyperlinks:
There is whitespace at the beginning or the end of the contents of
LE<lt>...E<gt>.
-=item * (section) in '$page' deprecated
-
-There is a section detected in the page name of LE<lt>...E<gt>, e.g.
-C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only.
-Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able
-to expand this to appropriate code. For links to (builtin) functions,
-please say C<LE<lt>perlfunc/mkdirE<gt>>, without ().
-
=item * alternative text/node '%s' contains non-escaped | or /
The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
@@ -328,6 +324,11 @@ these literal characters like this:
=back
+Note that the line number of the error/warning may refer to the line number of
+the start of the paragraph in which the error/warning exists, not the line
+number that the error/warning is on. This bug is present in errors/warnings
+related to formatting codes. I<This should be fixed.>
+
=head1 RETURN VALUE
B<podchecker> returns the number of POD syntax errors found or -1 if
@@ -337,6 +338,14 @@ there were no POD commands at all found in the file.
See L</SYNOPSIS>
+=head1 SCRIPTS
+
+The B<podchecker> script that comes with this distribution is a lean wrapper
+around this module. See the online manual with
+
+ podchecker -help
+ podchecker -man
+
=head1 INTERFACE
While checking, this module collects document properties, e.g. the nodes
@@ -345,169 +354,28 @@ POD translators can use this feature to syntax-check and get the nodes in
a first pass before actually starting to convert. This is expensive in terms
of execution time, but allows for very robust conversions.
-Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror>
+Since v1.24 the B<Pod::Checker> module uses only the B<poderror>
method to print errors and warnings. The summary output (e.g.
"Pod syntax OK") has been dropped from the module and has been included in
B<podchecker> (the script). This allows users of B<Pod::Checker> to
control completely the output behavior. Users of B<podchecker> (the script)
get the well-known behavior.
+v1.45 inherits from Pod::Simple as opposed to all previous versions
+inheriting from Pod::Parser. Do B<not> use Pod::Simple's interface when
+using Pod::Checker unless it is documented somewhere on this page. I
+repeat, DO B<NOT> USE POD::SIMPLE'S INTERFACE.
+
=cut
#############################################################################
#use diagnostics;
use Carp qw(croak);
-use Exporter;
-use Pod::Parser;
-
-@ISA = qw(Pod::Parser);
-@EXPORT = qw(&podchecker);
-
-my %VALID_COMMANDS = (
- 'pod' => 1,
- 'cut' => 1,
- 'head1' => 1,
- 'head2' => 1,
- 'head3' => 1,
- 'head4' => 1,
- 'over' => 1,
- 'back' => 1,
- 'item' => 1,
- 'for' => 1,
- 'begin' => 1,
- 'end' => 1,
- 'encoding' => 1,
-);
-
-my %VALID_SEQUENCES = (
- 'I' => 1,
- 'B' => 1,
- 'S' => 1,
- 'C' => 1,
- 'L' => 1,
- 'F' => 1,
- 'X' => 1,
- 'Z' => 1,
- 'E' => 1,
-);
-
-# stolen from HTML::Entities
-my %ENTITIES = (
- # Some normal chars that have special meaning in SGML context
- amp => '&', # ampersand
-'gt' => '>', # greater than
-'lt' => '<', # less than
- quot => '"', # double quote
-
- # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
- AElig => 'Æ', # capital AE diphthong (ligature)
- Aacute => 'Á', # capital A, acute accent
- Acirc => 'Â', # capital A, circumflex accent
- Agrave => 'À', # capital A, grave accent
- Aring => 'Å', # capital A, ring
- Atilde => 'Ã', # capital A, tilde
- Auml => 'Ä', # capital A, dieresis or umlaut mark
- Ccedil => 'Ç', # capital C, cedilla
- ETH => 'Ð', # capital Eth, Icelandic
- Eacute => 'É', # capital E, acute accent
- Ecirc => 'Ê', # capital E, circumflex accent
- Egrave => 'È', # capital E, grave accent
- Euml => 'Ë', # capital E, dieresis or umlaut mark
- Iacute => 'Í', # capital I, acute accent
- Icirc => 'Î', # capital I, circumflex accent
- Igrave => 'Ì', # capital I, grave accent
- Iuml => 'Ï', # capital I, dieresis or umlaut mark
- Ntilde => 'Ñ', # capital N, tilde
- Oacute => 'Ó', # capital O, acute accent
- Ocirc => 'Ô', # capital O, circumflex accent
- Ograve => 'Ò', # capital O, grave accent
- Oslash => 'Ø', # capital O, slash
- Otilde => 'Õ', # capital O, tilde
- Ouml => 'Ö', # capital O, dieresis or umlaut mark
- THORN => 'Þ', # capital THORN, Icelandic
- Uacute => 'Ú', # capital U, acute accent
- Ucirc => 'Û', # capital U, circumflex accent
- Ugrave => 'Ù', # capital U, grave accent
- Uuml => 'Ü', # capital U, dieresis or umlaut mark
- Yacute => 'Ý', # capital Y, acute accent
- aacute => 'á', # small a, acute accent
- acirc => 'â', # small a, circumflex accent
- aelig => 'æ', # small ae diphthong (ligature)
- agrave => 'à', # small a, grave accent
- aring => 'å', # small a, ring
- atilde => 'ã', # small a, tilde
- auml => 'ä', # small a, dieresis or umlaut mark
- ccedil => 'ç', # small c, cedilla
- eacute => 'é', # small e, acute accent
- ecirc => 'ê', # small e, circumflex accent
- egrave => 'è', # small e, grave accent
- eth => 'ð', # small eth, Icelandic
- euml => 'ë', # small e, dieresis or umlaut mark
- iacute => 'í', # small i, acute accent
- icirc => 'î', # small i, circumflex accent
- igrave => 'ì', # small i, grave accent
- iuml => 'ï', # small i, dieresis or umlaut mark
- ntilde => 'ñ', # small n, tilde
- oacute => 'ó', # small o, acute accent
- ocirc => 'ô', # small o, circumflex accent
- ograve => 'ò', # small o, grave accent
- oslash => 'ø', # small o, slash
- otilde => 'õ', # small o, tilde
- ouml => 'ö', # small o, dieresis or umlaut mark
- szlig => 'ß', # small sharp s, German (sz ligature)
- thorn => 'þ', # small thorn, Icelandic
- uacute => 'ú', # small u, acute accent
- ucirc => 'û', # small u, circumflex accent
- ugrave => 'ù', # small u, grave accent
- uuml => 'ü', # small u, dieresis or umlaut mark
- yacute => 'ý', # small y, acute accent
- yuml => 'ÿ', # small y, dieresis or umlaut mark
-
- # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
- copy => '©', # copyright sign
- reg => '®', # registered sign
- nbsp => "\240", # non breaking space
-
- # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
- iexcl => '¡',
- cent => '¢',
- pound => '£',
- curren => '¤',
- yen => '¥',
- brvbar => '¦',
- sect => '§',
- uml => '¨',
- ordf => 'ª',
- laquo => '«',
-'not' => '¬', # not is a keyword in perl
- shy => '­',
- macr => '¯',
- deg => '°',
- plusmn => '±',
- sup1 => '¹',
- sup2 => '²',
- sup3 => '³',
- acute => '´',
- micro => 'µ',
- para => '¶',
- middot => '·',
- cedil => '¸',
- ordm => 'º',
- raquo => '»',
- frac14 => '¼',
- frac12 => '½',
- frac34 => '¾',
- iquest => '¿',
-'times' => '×', # times is a keyword in perl
- divide => '÷',
-
-# some POD special entities
- verbar => '|',
- sol => '/'
-);
+use Exporter 'import';
+use base qw/Pod::Simple::Methody/;
-##---------------------------------------------------------------------------
+our @EXPORT = qw(&podchecker);
##---------------------------------
## Function definitions begin here
@@ -522,7 +390,7 @@ sub podchecker {
$outfile ||= \*STDERR;
## Now create a pod checker
- my $checker = new Pod::Checker(%options);
+ my $checker = Pod::Checker->new(%options);
## Now check the pod document for errors
$checker->parse_from_file($infile, $outfile);
@@ -531,6 +399,7 @@ sub podchecker {
return $checker->num_errors();
}
+
##---------------------------------------------------------------------------
##-------------------------------
@@ -544,7 +413,7 @@ sub podchecker {
=item C<Pod::Checker-E<gt>new( %options )>
Return a reference to a new Pod::Checker object that inherits from
-Pod::Parser and is used for calling the required methods later. The
+Pod::Simple and is used for calling the required methods later. The
following options are recognized:
C<-warnings =E<gt> num>
@@ -558,35 +427,41 @@ POD formatters.
=cut
-## sub new {
-## my $this = shift;
-## my $class = ref($this) || $this;
-## my %params = @_;
-## my $self = {%params};
-## bless $self, $class;
-## $self->initialize();
-## return $self;
-## }
-
-sub initialize {
- my $self = shift;
- ## Initialize number of errors, and setup an error function to
- ## increment this number and then print to the designated output.
- $self->{_NUM_ERRORS} = 0;
- $self->{_NUM_WARNINGS} = 0;
- $self->{-quiet} ||= 0;
- # set the error handling subroutine
- $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror');
- $self->{_commands} = 0; # total number of POD commands encountered
- $self->{_list_stack} = []; # stack for nested lists
- $self->{_have_begin} = ''; # stores =begin
- $self->{_links} = []; # stack for internal hyperlinks
- $self->{_nodes} = []; # stack for =head/=item nodes
- $self->{_index} = []; # text in X<>
- # print warnings?
- $self->{-warnings} = 1 unless(defined $self->{-warnings});
- $self->{_current_head1} = ''; # the current =head1 block
- $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings});
+sub new {
+ my $new = shift->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDERR{IO};
+
+ # Set options
+ my %opts = @_;
+ $new->{'-warnings'} = defined $opts{'-warnings'} ?
+ $opts{'-warnings'} : 1; # default on
+ $new->{'-quiet'} = $opts{'-quiet'} || 0; # default off
+
+ # Initialize number of errors/warnings
+ $new->{'_NUM_ERRORS'} = 0;
+ $new->{'_NUM_WARNINGS'} = 0;
+
+ # 'current' also means 'most recent' in the follow comments
+ $new->{'_thispara'} = ''; # current POD paragraph
+ $new->{'_line'} = 0; # current line number
+ $new->{'_head_num'} = 0; # current =head level (set to 0 to make
+ # logic easier down the road)
+ $new->{'_cmds_since_head'} = 0; # num of POD directives since prev. =headN
+ $new->{'_nodes'} = []; # stack for =head/=item nodes
+ $new->{'_fcode_stack'} = []; # stack for nested formatting codes
+ $new->{'_fcode_pos'} = []; # stack for position in paragraph of fcodes
+ $new->{'_begin_stack'} = []; # stack for =begins: [line #, target]
+ $new->{'_links'} = []; # stack for hyperlinks to external entities
+ $new->{'_internal_links'} = []; # set of linked-to internal sections
+ $new->{'_index'} = []; # stack for text in X<>s
+
+ $new->accept_targets('*'); # check all =begin/=for blocks
+ $new->cut_handler( \&handle_pod_and_cut ); # warn if text after =cut
+ $new->pod_handler( \&handle_pod_and_cut ); # warn if text after =pod
+ $new->whiteline_handler( \&handle_whiteline ); # warn if whiteline
+ $new->parse_empty_lists(1); # warn if they are empty
+
+ return $new;
}
##################################
@@ -595,9 +470,9 @@ sub initialize {
=item C<$checker-E<gt>poderror( {%opts}, @args )>
-Internal method for printing errors and warnings. If no options are
-given, simply prints "@_". The following options are recognized and used
-to form the output:
+Internal method for printing errors and warnings. If no options are given,
+simply prints "@_". The following options are recognized and used to form
+the output:
-msg
@@ -609,7 +484,8 @@ The line number the error occurred in.
-file
-The file (name) the error occurred in.
+The file (name) the error occurred in. Defaults to the name of the current
+file being processed.
-severity
@@ -623,24 +499,28 @@ sub poderror {
my %opts = (ref $_[0]) ? %{shift()} : ();
## Retrieve options
- chomp( my $msg = ($opts{-msg} || '')."@_" );
- my $line = (exists $opts{-line}) ? " at line $opts{-line}" : '';
- my $file = (exists $opts{-file}) ? " in file $opts{-file}" : '';
- unless (exists $opts{-severity}) {
+ chomp( my $msg = ($opts{'-msg'} || '')."@_" );
+ my $line = (exists $opts{'-line'}) ? " at line $opts{'-line'}" : '';
+ my $file = ' in file ' . ((exists $opts{'-file'})
+ ? $opts{'-file'}
+ : ((defined $self->source_filename)
+ ? $self->source_filename
+ : "???"));
+ unless (exists $opts{'-severity'}) {
## See if can find severity in message prefix
- $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
+ $opts{'-severity'} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
}
- my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : '';
+ my $severity = (exists $opts{'-severity'}) ? "*** $opts{-severity}: " : '';
## Increment error count and print message "
- ++($self->{_NUM_ERRORS})
- if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));
- ++($self->{_NUM_WARNINGS})
- if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING'));
- unless($self->{-quiet}) {
- my $out_fh = $self->output_handle() || \*STDERR;
+ ++($self->{'_NUM_ERRORS'})
+ if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'ERROR'));
+ ++($self->{'_NUM_WARNINGS'})
+ if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'WARNING'));
+ unless($self->{'-quiet'}) {
+ my $out_fh = $self->{'output_fh'} || \*STDERR;
print $out_fh ($severity, $msg, $line, $file, "\n")
- if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');
+ if($self->{'-warnings'} || !%opts || $opts{'-severity'} ne 'WARNING');
}
}
@@ -653,7 +533,7 @@ Set (if argument specified) and retrieve the number of errors found.
=cut
sub num_errors {
- return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};
+ return (@_ > 1) ? ($_[0]->{'_NUM_ERRORS'} = $_[1]) : $_[0]->{'_NUM_ERRORS'};
}
##################################
@@ -665,7 +545,8 @@ Set (if argument specified) and retrieve the number of warnings found.
=cut
sub num_warnings {
- return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS};
+ return (@_ > 1) ? ($_[0]->{'_NUM_WARNINGS'} = $_[1]) :
+ $_[0]->{'_NUM_WARNINGS'};
}
##################################
@@ -679,7 +560,7 @@ found in the C<=head1 NAME> section.
sub name {
return (@_ > 1 && $_[1]) ?
- ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
+ ($_[0]->{'_pod_name'} = $_[1]) : $_[0]->{'_pod_name'};
}
##################################
@@ -699,12 +580,12 @@ sub node {
$text =~ s/\s+$//s; # strip trailing whitespace
$text =~ s/\s+/ /gs; # collapse whitespace
# add node, order important!
- push(@{$self->{_nodes}}, $text);
+ push(@{$self->{'_nodes'}}, $text);
# keep also a uniqueness counter
- $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
+ $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
return $text;
}
- @{$self->{_nodes}};
+ @{$self->{'_nodes'}};
}
##################################
@@ -724,58 +605,270 @@ sub idx {
$text =~ s/\s+$//s; # strip trailing whitespace
$text =~ s/\s+/ /gs; # collapse whitespace
# add node, order important!
- push(@{$self->{_index}}, $text);
+ push(@{$self->{'_index'}}, $text);
# keep also a uniqueness counter
- $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
+ $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
return $text;
}
- @{$self->{_index}};
+ @{$self->{'_index'}};
}
##################################
-=item C<$checker-E<gt>hyperlink()>
+# add a hyperlink to the list of those of the current POD; returns current
+# list after the addition has been done
+sub hyperlink {
+ my $self = shift;
+ push(@{$self->{'_links'}}, $_[0]);
+ return $_[0];
+}
-Add (if argument specified) and retrieve the hyperlinks (as defined by
-C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line
-number and C<Pod::Hyperlink> object.
+=item C<$checker-E<gt>hyperlinks()>
-=back
+Retrieve an array containing the hyperlinks to things outside
+the current POD (as defined by C<LE<lt>E<gt>>).
+
+Each is an instance of a class with the following methods:
=cut
-# set/return hyperlinks of the current POD
-sub hyperlink {
- my $self = shift;
- if($_[0]) {
- push(@{$self->{_links}}, $_[0]);
- return $_[0];
+sub hyperlinks {
+ @{shift->{'_links'}};
+}
+
+##################################
+
+# override Pod::Simple's whine() and scream() to use poderror()
+
+# Note:
+# Ignore $self->{'no_whining'} b/c $self->{'quiet'} takes care of it in poderror
+# Don't bother incrementing $self->{'errors_seen'} -- it's not used
+# Don't bother pushing to $self->{'errata'} b/c poderror() outputs immediately
+# We don't need to set $self->no_errata_section(1) b/c of these overrides
+
+
+sub whine {
+ my ($self, $line, $complaint) = @_;
+
+ my $severity = 'ERROR';
+
+ if (0) {
+ # XXX: Let's standardize what's a warning and what's an error. Let's not
+ # move stuff up and down the severity tree. -- rjbs, 2013-04-12
+ # Convert errors in Pod::Simple that are warnings in Pod::Checker
+ # XXX Do differently so the $complaint can be reworded without this breaking
+ $severity = 'WARNING' if
+ $complaint =~ /^Expected '=item .+?'$/ ||
+ $complaint =~ /^You can't have =items \(as at line .+?\) unless the first thing after the =over is an =item$/ ||
+ $complaint =~ /^You have '=item .+?' instead of the expected '=item .+?'$/;
+ }
+
+ $self->poderror({ -line => $line,
+ -severity => $severity,
+ -msg => $complaint });
+
+ return 1; # assume everything is peachy keen
+}
+
+sub scream {
+ my ($self, $line, $complaint) = @_;
+
+ $self->poderror({ -line => $line,
+ -severity => 'ERROR', # consider making severity 'FATAL'
+ -msg => $complaint });
+
+ return 1;
+}
+
+
+##################################
+
+# Some helper subroutines
+
+sub _init_event { # assignments done at the start of most events
+ $_[0]{'_thispara'} = '';
+ $_[0]{'_line'} = $_[1]{'start_line'};
+ $_[0]{'_cmds_since_head'}++;
+}
+
+sub _check_fcode {
+ my ($self, $inner, $outers) = @_;
+ # Check for an fcode inside another of the same fcode
+ # XXX line number is the line of the start of the paragraph that the warning
+ # is in, not the line that the warning is on. Fix this
+
+ # Later versions of Pod::Simple forbid nested L<>'s
+ return if $inner eq 'L' && $Pod::Simple::VERSION ge '3.33';
+
+ if (grep { $_ eq $inner } @$outers) {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => "nested commands $inner<...$inner<...>...>"});
+ }
+}
+
+##################################
+
+sub handle_text { $_[0]{'_thispara'} .= $_[1] }
+
+# whiteline is a seemingly blank line that matches /[^\S\r\n]/
+sub handle_whiteline {
+ my ($line, $line_n, $self) = @_;
+ $self->poderror({
+ -line => $line_n,
+ -severity => 'WARNING',
+ -msg => 'line containing nothing but whitespace in paragraph'});
+}
+
+######## Directives
+sub handle_pod_and_cut {
+ my ($line, $line_n, $self) = @_;
+ $self->{'_cmds_since_head'}++;
+ if ($line =~ /=(pod|cut)\s+\S/) {
+ $self->poderror({ -line => $line_n,
+ -severity => 'ERROR',
+ -msg => "Spurious text after =$1"});
}
- @{$self->{_links}};
}
-## overrides for Pod::Parser
-
-sub end_pod {
- ## Do some final checks and
- ## print the number of errors found
- my $self = shift;
- my $infile = $self->input_file();
-
- if(@{$self->{_list_stack}}) {
- my $list;
- while(($list = $self->_close_list('EOF',$infile)) &&
- $list->indent() ne 'auto') {
- $self->poderror({ -line => 'EOF', -file => $infile,
- -severity => 'ERROR', -msg => '=over on line ' .
- $list->start() . ' without closing =back' });
+sub start_Para { shift->_init_event(@_); }
+sub end_Para {
+ my $self = shift;
+ # Get the NAME of the pod document
+ if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') {
+ if ($self->{'_thispara'} =~ /^\s*(\S+?)\s*[,-]/) {
+ $self->{'_pod_name'} = $1 unless defined $self->{'_pod_name'};
}
}
+}
+
+sub start_Verbatim {
+ my $self = shift;
+ $self->_init_event(@_);
+
+ if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'Verbatim paragraph in NAME section' });
+ }
+}
+# Don't need an end_Verbatim
+
+# Do I need to do anything else with this?
+sub start_Data { shift->_init_event() }
+
+sub start_head1 { shift->start_head(1, @_) }
+sub start_head2 { shift->start_head(2, @_) }
+sub start_head3 { shift->start_head(3, @_) }
+sub start_head4 { shift->start_head(4, @_) }
+sub start_head {
+ my $self = shift;
+ my $h = shift;
+ $self->_init_event(@_);
+ my $prev_h = $self->{'_head_num'};
+ $self->{'_head_num'} = $h;
+ $self->{"_count_head$h"}++;
+
+ if ($h > 1 && !$self->{'_count_head'.($h-1)}) {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => "=head$h without preceding higher level"});
+ }
+
+ # If this is the first =head of the doc, $prev_h is 0, thus less than $h
+ if ($self->{'_cmds_since_head'} == 1 && $prev_h >= $h) {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'empty section in previous paragraph'});
+ }
+}
+
+sub end_head1 { shift->end_head(@_) }
+sub end_head2 { shift->end_head(@_) }
+sub end_head3 { shift->end_head(@_) }
+sub end_head4 { shift->end_head(@_) }
+sub end_head {
+ my $self = shift;
+ my $arg = $self->{'_thispara'};
+ $arg =~ s/\s+$//;
+ $self->{'_head_text'} = $arg;
+ $self->{'_cmds_since_head'} = 0;
+ my $h = $self->{'_head_num'};
+ $self->node($arg); # remember this node
+ if ($arg eq '') {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'ERROR',
+ -msg => "empty =head$h" });
+ }
+}
+
+sub start_over_bullet { shift->start_over(@_, 'bullet') }
+sub start_over_number { shift->start_over(@_, 'number') }
+sub start_over_text { shift->start_over(@_, 'definition') }
+sub start_over_block { shift->start_over(@_, 'block') }
+sub start_over_empty {
+ my $self = shift;
+ $self->start_over(@_, 'empty');
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'empty =over/=back block' });
+}
+sub start_over {
+ my $self = shift;
+ my $type = pop;
+ $self->_init_event(@_);
+}
+
+sub start_item_bullet { shift->_init_event(@_) }
+sub start_item_number { shift->_init_event(@_) }
+sub start_item_text { shift->_init_event(@_) }
+sub end_item_bullet { shift->end_item('bullet') }
+sub end_item_number { shift->end_item('number') }
+sub end_item_text { shift->end_item('definition') }
+sub end_item {
+ my $self = shift;
+ my $type = shift;
+ # If there is verbatim text in this item, it will show up as part of
+ # 'paras', and not part of '_thispara'. If the first para after this is a
+ # verbatim one, it actually will be (part of) the contents for this item.
+ if ( $self->{'_thispara'} eq ''
+ && ( ! @{$self->{'paras'}}
+ || $self->{'paras'}[0][0] !~ /Verbatim/i))
+ {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => '=item has no contents' });
+ }
+
+ $self->node($self->{'_thispara'}); # remember this node
+}
+
+sub start_for { # =for and =begin directives
+ my ($self, $flags) = @_;
+ $self->_init_event($flags);
+ push @{$self->{'_begin_stack'}}, [$self->{'_line'}, $flags->{'target'}];
+}
+
+sub end_for {
+ my ($self, $flags) = @_;
+ my ($line, $target) = @{pop @{$self->{'_begin_stack'}}};
+ if ($flags->{'fake-closer'}) { # meaning Pod::Simple generated this =end
+ $self->poderror({ -line => $line,
+ -severity => 'ERROR',
+ -msg => "=begin $target without matching =end $target"
+ });
+ }
+}
+
+sub end_Document {
+ # Some final error checks
+ my $self = shift;
+
+ # no POD found here
+ $self->num_errors(-1) && return unless $self->content_seen;
- # check validity of document internal hyperlinks
- # first build the node names from the paragraph text
my %nodes;
- foreach($self->node()) {
+ for ($self->node()) {
$nodes{$_} = 1;
if(/^(\S+)\s+\S/) {
# we have more than one word. Use the first as a node, too.
@@ -783,548 +876,215 @@ sub end_pod {
$nodes{$1} ||= 2; # derived node
}
}
- foreach($self->idx()) {
+ for ($self->idx()) {
$nodes{$_} = 3; # index node
}
- foreach($self->hyperlink()) {
- my ($line,$link) = @$_;
- # _TODO_ what if there is a link to the page itself by the name,
- # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">
- if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {
- my $node = $self->_check_ptree($self->parse_text($link->node(),
- $line), $line, $infile, 'L');
- if($node && !$nodes{$node}) {
- $self->poderror({ -line => $line || '', -file => $infile,
- -severity => 'ERROR',
- -msg => "unresolved internal link '$node'"});
- }
+
+ # XXX update unresolved internal link POD -- single word not enclosed in ""?
+ # I don't know what I was thinking when I made the above TODO, and I don't
+ # know what it means...
+
+ for my $link (@{ $self->{'_internal_links'} }) {
+ my ($name, $line) = @$link;
+ unless ( $nodes{$name} ) {
+ $self->poderror({ -line => $line,
+ -severity => 'ERROR',
+ -msg => "unresolved internal link '$name'"});
}
}
# check the internal nodes for uniqueness. This pertains to
# =headX, =item and X<...>
- if($self->{-warnings} && $self->{-warnings}>1) {
- foreach(grep($self->{_unique_nodes}->{$_} > 1,
- keys %{$self->{_unique_nodes}})) {
- $self->poderror({ -line => '-', -file => $infile,
- -severity => 'WARNING',
- -msg => "multiple occurrence of link target '$_'"});
- }
- }
-
- # no POD found here
- $self->num_errors(-1) if($self->{_commands} == 0);
-}
-
-# check a POD command directive
-sub command {
- my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
- my ($file, $line) = $pod_para->file_line;
- ## Check the command syntax
- my $arg; # this will hold the command argument
- if (! $VALID_COMMANDS{$cmd}) {
- $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
- -msg => "Unknown command '$cmd'" });
- }
- else { # found a valid command
- $self->{_commands}++; # delete this line if below is enabled again
-
- $self->_commands_in_paragraphs($paragraph, $pod_para);
-
- ##### following check disabled due to strong request
- #if(!$self->{_commands}++ && $cmd !~ /^head/) {
- # $self->poderror({ -line => $line, -file => $file,
- # -severity => 'WARNING',
- # -msg => "file does not start with =head" });
- #}
-
- # check syntax of particular command
- if($cmd eq 'over') {
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- my $indent = 4; # default
- if($arg && $arg =~ /^\s*(\d+)\s*$/) {
- $indent = $1;
- }
- # start a new list
- $self->_open_list($indent,$line,$file);
- }
- elsif($cmd eq 'item') {
- # are we in a list?
- unless(@{$self->{_list_stack}}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=item without previous =over' });
- # auto-open in case we encounter many more
- $self->_open_list('auto',$line,$file);
- }
- my $list = $self->{_list_stack}->[0];
- # check whether the previous item had some contents
- if(defined $self->{_list_item_contents} &&
- $self->{_list_item_contents} == 0) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'previous =item has no contents' });
- }
- if($list->{_has_par}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'preceding non-item paragraph(s)' });
- delete $list->{_has_par};
- }
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line, $file);
- if($arg && $arg =~ /(\S+)/) {
- $arg =~ s/[\s\n]+$//;
- my $type;
- if($arg =~ /^[*]\s*(\S*.*)/) {
- $type = 'bullet';
- $self->{_list_item_contents} = $1 ? 1 : 0;
- $arg = $1;
- }
- elsif($arg =~ /^\d+\.?\s+(\S*)/) {
- $type = 'number';
- $self->{_list_item_contents} = $1 ? 1 : 0;
- $arg = $1;
- }
- else {
- $type = 'definition';
- $self->{_list_item_contents} = 1;
- }
- my $first = $list->type();
- if($first && $first ne $type) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "=item type mismatch ('$first' vs. '$type')"});
- }
- else { # first item
- $list->type($type);
- }
- }
- else {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'No argument for =item' });
- $arg = ' '; # empty
- $self->{_list_item_contents} = 0;
- }
- # add this item
- $list->item($arg);
- # remember this node
- $self->node($arg);
- }
- elsif($cmd eq 'back') {
- # check if we have an open list
- unless(@{$self->{_list_stack}}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=back without previous =over' });
- }
- else {
- # check for spurious characters
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- if($arg && $arg =~ /\S/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Spurious character(s) after =back' });
- }
- # close list
- my $list = $self->_close_list($line,$file);
- # check for empty lists
- if(!$list->item() && $self->{-warnings}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'No items in =over (at line ' .
- $list->start() . ') / =back list'});
- }
- }
- }
- elsif($cmd =~ /^head(\d+)/) {
- my $hnum = $1;
- $self->{"_have_head_$hnum"}++; # count head types
- if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "=head$hnum without preceding higher level"});
- }
- # check whether the previous =head section had some contents
- if(defined $self->{_commands_in_head} &&
- $self->{_commands_in_head} == 0 &&
- defined $self->{_last_head} &&
- $self->{_last_head} >= $hnum) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'empty section in previous paragraph'});
- }
- $self->{_commands_in_head} = -1;
- $self->{_last_head} = $hnum;
- # check if there is an open list
- if(@{$self->{_list_stack}}) {
- my $list;
- while(($list = $self->_close_list($line,$file)) &&
- $list->indent() ne 'auto') {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=over on line '. $list->start() .
- " without closing =back (at $cmd)" });
- }
- }
- # remember this node
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- $arg =~ s/[\s\n]+$//s;
- $self->node($arg);
- unless(length($arg)) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "empty =$cmd"});
- }
- if($cmd eq 'head1') {
- $self->{_current_head1} = $arg;
- } else {
- $self->{_current_head1} = '';
- }
- }
- elsif($cmd eq 'begin') {
- if($self->{_have_begin}) {
- # already have a begin
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => q{Nested =begin's (first at line } .
- $self->{_have_begin} . ')'});
- }
- else {
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- unless($arg && $arg =~ /(\S+)/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'No argument for =begin'});
- }
- # remember the =begin
- $self->{_have_begin} = "$line:$1";
- }
- }
- elsif($cmd eq 'end') {
- if($self->{_have_begin}) {
- # close the existing =begin
- $self->{_have_begin} = '';
- # check for spurious characters
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- # the closing argument is optional
- #if($arg && $arg =~ /\S/) {
- # $self->poderror({ -line => $line, -file => $file,
- # -severity => 'WARNING',
- # -msg => "Spurious character(s) after =end" });
- #}
- }
- else {
- # don't have a matching =begin
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=end without =begin' });
- }
- }
- elsif($cmd eq 'for') {
- unless($paragraph =~ /\s*(\S+)\s*/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=for without formatter specification' });
- }
- $arg = ''; # do not expand paragraph below
- }
- elsif($cmd =~ /^(pod|cut)$/) {
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- if($arg && $arg =~ /(\S+)/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "Spurious text after =$cmd"});
+ if ($self->{'-warnings'} > 1 ) {
+ for my $node (sort keys %{ $self->{'_unique_nodes'} }) {
+ my $count = $self->{'_unique_nodes'}{$node};
+ if ($count > 1) { # not unique
+ $self->poderror({
+ -line => '-',
+ -severity => 'WARNING',
+ -msg => "multiple occurrences ($count) of link target ".
+ "'$node'"});
}
- if($cmd eq 'cut' && (!$self->{_PREVIOUS} || $self->{_PREVIOUS} eq 'cut')) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "Spurious =cut command"});
- }
- if($cmd eq 'pod' && $self->{_PREVIOUS} && $self->{_PREVIOUS} ne 'cut') {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "Spurious =pod command"});
- }
}
- $self->{_commands_in_head}++;
- ## Check the interior sequences in the command-text
- $self->interpolate_and_check($paragraph, $line,$file)
- unless(defined $arg);
}
}
-sub _open_list
-{
- my ($self,$indent,$line,$file) = @_;
- my $list = Pod::List->new(
- -indent => $indent,
- -start => $line,
- -file => $file);
- unshift(@{$self->{_list_stack}}, $list);
- undef $self->{_list_item_contents};
- $list;
-}
+######## Formatting codes
-sub _close_list
-{
- my ($self,$line,$file) = @_;
- my $list = shift(@{$self->{_list_stack}});
- if(defined $self->{_list_item_contents} &&
- $self->{_list_item_contents} == 0) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'previous =item has no contents' });
- }
- undef $self->{_list_item_contents};
- $list;
+sub start_B { shift->start_fcode('B') }
+sub start_C { shift->start_fcode('C') }
+sub start_F { shift->start_fcode('F') }
+sub start_I { shift->start_fcode('I') }
+sub start_S { shift->start_fcode('S') }
+sub start_fcode {
+ my ($self, $fcode) = @_;
+ unshift @{$self->{'_fcode_stack'}}, $fcode;
}
-# process a block of some text
-sub interpolate_and_check {
- my ($self, $paragraph, $line, $file) = @_;
- ## Check the interior sequences in the command-text
- # and return the text
- $self->_check_ptree(
- $self->parse_text($paragraph,$line), $line, $file, '');
+sub end_B { shift->end_fcode() }
+sub end_C { shift->end_fcode() }
+sub end_F { shift->end_fcode() }
+sub end_I { shift->end_fcode() }
+sub end_S { shift->end_fcode() }
+sub end_fcode {
+ my $self = shift;
+ $self->_check_fcode(shift @{$self->{'_fcode_stack'}}, # current fcode removed
+ $self->{'_fcode_stack'}); # previous fcodes
}
-sub _check_ptree {
- my ($self,$ptree,$line,$file,$nestlist) = @_;
- local($_);
- my $text = '';
- # process each node in the parse tree
- foreach(@$ptree) {
- # regular text chunk
- unless(ref) {
- # count the unescaped angle brackets
- # complain only when warning level is greater than 1
- if($self->{-warnings} && $self->{-warnings}>1) {
- my $count;
- if($count = tr/<>/<>/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "$count unescaped <> in paragraph" });
- }
- }
- $text .= $_;
- next;
- }
- # have an interior sequence
- my $cmd = $_->cmd_name();
- my $contents = $_->parse_tree();
- ($file,$line) = $_->file_line();
- # check for valid tag
- if (! $VALID_SEQUENCES{$cmd}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => qq(Unknown interior-sequence '$cmd')});
- # expand it anyway
- $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
- next;
- }
- if(index($nestlist, $cmd) != -1) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "nested commands $cmd<...$cmd<...>...>"});
- # _TODO_ should we add the contents anyway?
- # expand it anyway, see below
- }
- if($cmd eq 'E') {
- # preserve entities
- if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'garbled entity ' . $_->raw_text()});
- next;
- }
- my $ent = $$contents[0];
- my $val;
- if($ent =~ /^0x[0-9a-f]+$/i) {
- # hexadec entity
- $val = hex($ent);
- }
- elsif($ent =~ /^0\d+$/) {
- # octal
- $val = oct($ent);
- }
- elsif($ent =~ /^\d+$/) {
- # numeric entity
- $val = $ent;
- }
- if(defined $val) {
- if($val>0 && $val<256) {
- $text .= chr($val);
- }
- else {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Entity number out of range ' . $_->raw_text()});
- }
- }
- elsif($ENTITIES{$ent}) {
- # known ISO entity
- $text .= $ENTITIES{$ent};
- }
- else {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'Unknown entity ' . $_->raw_text()});
- $text .= "E<$ent>";
- }
- }
- elsif($cmd eq 'L') {
- # try to parse the hyperlink
- my $link = Pod::Hyperlink->new($contents->raw_text());
- unless(defined $link) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'malformed link ' . $_->raw_text() ." : $@"});
- next;
- }
- $link->line($line); # remember line
- if($self->{-warnings}) {
- foreach my $w ($link->warning()) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => $w });
- }
- }
- # check the link text
- $text .= $self->_check_ptree($self->parse_text($link->text(),
- $line), $line, $file, "$nestlist$cmd");
- # remember link
- $self->hyperlink([$line,$link]);
- }
- elsif($cmd =~ /[BCFIS]/) {
- # add the guts
- $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
- }
- elsif($cmd eq 'Z') {
- if(length($contents->raw_text())) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Nonempty Z<>'});
- }
- }
- elsif($cmd eq 'X') {
- my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
- if($idx =~ /^\s*$/s) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Empty X<>'});
- }
- else {
- # remember this node
- $self->idx($idx);
- }
+sub start_L {
+ my ($self, $flags) = @_;
+ $self->start_fcode('L');
+
+ my $link = Pod::Checker::Hyperlink->new($flags, $self);
+ if ($link) {
+ if ( $link->type eq 'pod'
+ && $link->node
+ # It's an internal-to-this-page link if no page is given, or
+ # if the given one is to our NAME.
+ && (! $link->page || ( $self->{'_pod_name'}
+ && $link->page eq $self->{'_pod_name'})))
+ {
+ push @{ $self->{'_internal_links'} }, [ $link->{'-raw_node'}, $link->line ];
}
else {
- # not reached
- croak 'internal error';
+ $self->hyperlink($link);
}
}
- $text;
}
-# process a block of verbatim text
-sub verbatim {
- ## Nothing particular to check
- my ($self, $paragraph, $line_num, $pod_para) = @_;
-
- $self->_preproc_par($paragraph);
- $self->_commands_in_paragraphs($paragraph, $pod_para);
+sub end_L {
+ my $self = shift;
+ $self->end_fcode();
+}
- if($self->{_current_head1} eq 'NAME') {
- my ($file, $line) = $pod_para->file_line;
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'Verbatim paragraph in NAME section' });
+sub start_X {
+ my $self = shift;
+ $self->start_fcode('X');
+ # keep track of where X<> starts in the paragraph
+ # (this is a stack so nested X<>s are handled correctly)
+ push @{$self->{'_fcode_pos'}}, length $self->{'_thispara'};
+}
+sub end_X {
+ my $self = shift;
+ # extract contents of X<> and replace with ''
+ my $start = pop @{$self->{'_fcode_pos'}}; # start at the beginning of X<>
+ my $end = length($self->{'_thispara'}) - $start; # end at end of X<>
+ my $x = substr($self->{'_thispara'}, $start, $end, '');
+ if ($x eq "") {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'ERROR',
+ -msg => "An empty X<>" });
}
+ $self->idx($x); # remember this node
+ $self->end_fcode();
}
-# process a block of regular text
-sub textblock {
- my ($self, $paragraph, $line_num, $pod_para) = @_;
- my ($file, $line) = $pod_para->file_line;
-
- $self->_preproc_par($paragraph);
- $self->_commands_in_paragraphs($paragraph, $pod_para);
-
- # skip this paragraph if in a =begin block
- unless($self->{_have_begin}) {
- my $block = $self->interpolate_and_check($paragraph, $line,$file);
- if($self->{_current_head1} eq 'NAME') {
- if($block =~ /^\s*(\S+?)\s*[,-]/) {
- # this is the canonical name
- $self->{-name} = $1 unless(defined $self->{-name});
- }
- }
+package Pod::Checker::Hyperlink;
+
+# This class is used to represent L<> link structures, so that the individual
+# elements are easily accessible. It is based on code in Pod::Hyperlink
+
+sub new {
+ my ($class,
+ $simple_link, # The link structure returned by Pod::Simple
+ $caller # The caller class
+ ) = @_;
+
+ my $self = +{};
+ bless $self, $class;
+
+ $self->{'-line'} ||= $caller->{'_line'};
+ $self->{'-type'} ||= $simple_link->{'type'};
+
+ # Force stringification of page and node. (This expands any E<>.)
+ $self->{'-page'} = exists $simple_link->{'to'} ? "$simple_link->{'to'}" : "";
+ $self->{'-node'} = exists $simple_link->{'section'} ? "$simple_link->{'section'}" : "";
+
+ # Save the unmodified node text, as the .t files are expecting the message
+ # for internal link failures to include it (hence this preserves backward
+ # compatibility).
+ $self->{'-raw_node'} = $self->{'-node'};
+
+ # Remove leading/trailing white space. Pod::Simple already warns about
+ # these, so if the only error is this, and the link is otherwise correct,
+ # only the Pod::Simple warning will be output, avoiding unnecessary
+ # confusion.
+ $self->{'-page'} =~ s/ ^ \s+ //x;
+ $self->{'-page'} =~ s/ \s+ $ //x;
+
+ $self->{'-node'} =~ s/ ^ \s+ //x;
+ $self->{'-node'} =~ s/ \s+ $ //x;
+
+ # Pod::Simple warns about L<> and L< >, but not L</>
+ if ($self->{'-page'} eq "" && $self->{'-node'} eq "") {
+ $caller->poderror({ -line => $caller->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'empty link'});
+ return;
}
+
+ return $self;
}
-sub _preproc_par
-{
- my $self = shift;
- $_[0] =~ s/[\s\n]+$//;
- if($_[0]) {
- $self->{_commands_in_head}++;
- $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});
- if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {
- $self->{_list_stack}->[0]->{_has_par} = 1;
- }
- }
+=item line()
+
+Returns the approximate line number in which the link was encountered
+
+=cut
+
+sub line {
+ return $_[0]->{-line};
}
-# look for =foo commands at the start of a line within a paragraph, as for
-# instance the following which prints as "* one =item two".
-#
-# =item one
-# =item two
-#
-# Examples of =foo written in docs are expected to be indented in a verbatim
-# or marked up C<=foo> so won't be caught. A double-angle C<< =foo >> could
-# have the =foo at the start of a line, but that should be unlikely and is
-# easily enough dealt with by not putting a newline after the C<<.
-#
-sub _commands_in_paragraphs {
- my ($self, $str, $pod_para) = @_;
- while ($str =~ /[^\n]\n=([a-z][a-z0-9]+)/sg) {
- my $cmd = $1;
- my $pos = pos($str);
- if ($VALID_COMMANDS{$cmd}) {
- my ($file, $line) = $pod_para->file_line;
- my $part = substr($str, 0, $pos);
- $line += ($part =~ tr/\n//); # count of newlines
-
- $self->poderror
- ({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "Apparent command =$cmd not preceded by blank line"});
- }
- }
+=item type()
+
+Returns the type of the link; one of:
+C<"url"> for things like
+C<http://www.foo>, C<"man"> for man pages, or C<"pod">.
+
+=cut
+
+sub type {
+ return $_[0]->{-type};
}
-1;
+=item page()
-__END__
+Returns the linked-to page or url.
+
+=cut
+
+sub page {
+ return $_[0]->{-page};
+}
+
+=item node()
+
+Returns the anchor or node within the linked-to page, or an empty string
+(C<"">) if none appears in the link.
+
+=back
+
+=cut
+
+sub node {
+ return $_[0]->{-node};
+}
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),
-Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
+Marc Green E<lt>marcgreen@cpan.orgE<gt> (port to Pod::Simple)
+Ricardo Signes E<lt>rjbs@cpan.orgE<gt> (more porting to Pod::Simple)
+Karl Williamson E<lt>khw@cpan.orgE<gt> (more porting to Pod::Simple)
Based on code for B<Pod::Text::pod2text()> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
-B<Pod::Checker> is part of the Pod-Checker distribution, and is based on
-L<Pod::Parser>.
-
=cut
+1