Edit File - File Manager

Edit File: Checker.pm

#############################################################################
# Pod/Checker.pm -- check pod documents for syntax errors
#
# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
# 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;

our $VERSION = '1.73';  ## Current version of this package

=head1 NAME

Pod::Checker - check pod documents for syntax errors

=head1 SYNOPSIS

use Pod::Checker;

$syntax_okay = podchecker($filepath, $outputpath, %options);

my $checker = Pod::Checker->new(%options);
  $checker->parse_from_file($filepath, \*STDERR);

=head1 OPTIONS/ARGUMENTS

C<$filepath> is the input POD to read and C<$outputpath> is
where to write POD syntax error messages. Either argument may be a scalar
indicating a file-path, or else a reference to an open filehandle.
If unspecified, the input-file it defaults to C<\*STDIN>, and
the output-file defaults to C<\*STDERR>.

=head2 podchecker()

This function can take a hash of options:

=over 4

=item B<-warnings> =E<gt> I<val>

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

B<podchecker> will perform syntax checking of Perl5 POD format documentation.

Curious/ambitious users are welcome to propose additional features they wish
to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
consistent with L<perlpod>.

The following checks are currently performed:

=over 4

=item *

Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
and unterminated interior sequences.

=item *

Check for proper balancing of C<=begin> and C<=end>. The contents of such
a block are generally ignored, i.e. no syntax checks are performed.

=item *

Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.

=item *

Check for same nested interior-sequences (e.g.
C<LE<lt>...LE<lt>...E<gt>...E<gt>>).

=item *

Check for malformed or non-existing entities C<EE<lt>...E<gt>>.

=item *

Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
for details.

=item *

Check for unresolved document-internal links. This check may also reveal
misspelled links that seem to be internal links but should be links
to something else.

=back

=head1 DIAGNOSTICS

=head2 Errors

=over 4

=item * empty =headn

A heading (C<=head1> or C<=head2>) without any text? That ain't no
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' outside of any '=over'

=item * =back without =over

An C<=item> or C<=back> command has been found outside a
C<=over>/C<=back> block.

=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 I<TARGET> without matching =begin.

A standalone C<=end> command was found.

=item * '=end' without a target?

'=end' directives need to have a target, just like =begin directives.

=item * '=end I<TARGET>' is invalid.

I<TARGET> needs to be one word

=item * =end I<CONTENT> doesn't match =begin I<TARGET>

I<CONTENT> needs to match =begin's I<TARGET>.

=item * =for without a target?

There is no specification of the formatter after the C<=for> command.

=item * unresolved internal link I<NAME>

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 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 * 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 * Unterminated I<SEQ>E<lt>E<gt> sequence

An unclosed formatting code

=item * An EE<lt>...E<gt> surrounding strange content

The I<STRING> found cannot be interpreted as a character entity.

=item * An empty EE<lt>E<gt>

=item * An empty C<< LE<lt>E<gt> >>

=item * An empty XE<lt>E<gt>

There needs to be content inside E, L, and X formatting codes.

=item * A non-empty ZE<lt>E<gt>

The C<ZE<lt>E<gt>> sequence is supposed to be empty.

=item * Spurious text after =pod / =cut

The commands C<=pod> and C<=cut> do not take any arguments.

=item * =back doesn't take any parameters, but you said =back I<ARGUMENT>

The C<=back> command does not take any arguments.

=item * =pod directives shouldn't be over one line long!  Ignoring all I<N> lines of content

Self explanatory

=item * =cut found outside a pod block.

A '=cut' directive found in the middle of non-POD

=item * Invalid =encoding syntax: I<CONTENT>

Syntax error in =encoding directive

=back

=head2 Warnings

These may not necessarily cause trouble, but indicate mediocre style.

=over 4

=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.
This warning is printed only with warning level greater than one.

=item * line containing nothing but whitespace in paragraph

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.

=item * =item has no contents

There is a list C<=item> that has no text contents. You probably want to delete
empty items.

=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 * 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 * You have '=item x' instead of the expected '=item I<N>'

Erroneous numbering of =item numbers; they need to ascend consecutively.

=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>. 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.>

=item * empty =over/=back block

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 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

The NAME section (C<=head1 NAME>) should consist of a single paragraph
with the script/module name, followed by a dash `-' and a very short
description of what the thing is good for.

=item * =headI<n> without preceding higher level

For example if there is a C<=head2> in the POD file prior to a
C<=head1>.

=back

=head2 Hyperlinks

There are some warnings with respect to malformed hyperlinks:

=over 4

=item * ignoring leading/trailing whitespace in link

There is whitespace at the beginning or the end of the contents of
LE<lt>...E<gt>.

=item * alternative text/node '%s' contains non-escaped | or /

The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
Although the hyperlink parser does its best to determine which "/" is
text and which is a delimiter in case of doubt, one ought to escape
these literal characters like this:

/     E<sol>
  |     E<verbar>

=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
there were no POD commands at all found in the file.

=head1 EXAMPLES

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
for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
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 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 'import';
use base qw/Pod::Simple::Methody/;

our @EXPORT = qw(&podchecker);

##---------------------------------
## Function definitions begin here
##---------------------------------

sub podchecker {
    my ($infile, $outfile, %options) = @_;
    local $_;

## Set defaults
    $infile  ||= \*STDIN;
    $outfile ||= \*STDERR;

## Now create a pod checker
    my $checker = Pod::Checker->new(%options);

## Now check the pod document for errors
    $checker->parse_from_file($infile, $outfile);

## Return the number of errors found
    return $checker->num_errors();
}

##---------------------------------------------------------------------------

##-------------------------------
## Method definitions begin here
##-------------------------------

##################################

=over 4

=item C<Pod::Checker-E<gt>new( %options )>

Return a reference to a new Pod::Checker object that inherits from
Pod::Simple and is used for calling the required methods later. The
following options are recognized:

C<-warnings =E<gt> num>
  Print warnings if C<num> is true. The higher the value of C<num>,
the more warnings are printed. Currently there are only levels 1 and 2.

C<-quiet =E<gt> num>
  If C<num> is true, do not print any errors/warnings. This is useful
when Pod::Checker is used to munge POD code into plain text from within
POD formatters.

=cut

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;
}

##################################

=item C<$checker-E<gt>poderror( @args )>

=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:

-msg

A message to print prior to C<@args>.

-line

The line number the error occurred in.

-file

The file (name) the error occurred in. Defaults to the name of the current
file being processed.

-severity

The error level, should be 'WARNING' or 'ERROR'.

=cut

# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
sub poderror {
    my $self = shift;
    my %opts = (ref $_[0]) ? %{shift()} : ();

## Retrieve options
    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+// );
    }
    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_fh'} || \*STDERR;
      print $out_fh ($severity, $msg, $line, $file, "\n")
        if($self->{'-warnings'} || !%opts || $opts{'-severity'} ne 'WARNING');
    }
}

##################################

=item C<$checker-E<gt>num_errors()>

Set (if argument specified) and retrieve the number of errors found.

=cut

sub num_errors {
   return (@_ > 1) ? ($_[0]->{'_NUM_ERRORS'} = $_[1]) : $_[0]->{'_NUM_ERRORS'};
}

##################################

=item C<$checker-E<gt>num_warnings()>

Set (if argument specified) and retrieve the number of warnings found.

=cut

sub num_warnings {
   return (@_ > 1) ? ($_[0]->{'_NUM_WARNINGS'} = $_[1]) :
                      $_[0]->{'_NUM_WARNINGS'};
}

##################################

=item C<$checker-E<gt>name()>

Set (if argument specified) and retrieve the canonical name of POD as
found in the C<=head1 NAME> section.

=cut

sub name {
    return (@_ > 1 && $_[1]) ?
        ($_[0]->{'_pod_name'} = $_[1]) : $_[0]->{'_pod_name'};
}

##################################

=item C<$checker-E<gt>node()>

Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
and C<=item>) of the current POD. The nodes are returned in the order of
their occurrence. They consist of plain text, each piece of whitespace is
collapsed to a single blank.

=cut

sub node {
    my ($self,$text) = @_;
    if(defined $text) {
        $text =~ s/\s+$//s; # strip trailing whitespace
        $text =~ s/\s+/ /gs; # collapse whitespace
        # add node, order important!
        push(@{$self->{'_nodes'}}, $text);
        # keep also a uniqueness counter
        $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
        return $text;
    }
    @{$self->{'_nodes'}};
}

##################################

=item C<$checker-E<gt>idx()>

Add (if argument specified) and retrieve the index entries (as defined by
C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
of whitespace is collapsed to a single blank.

=cut

# set/return index entries of current POD
sub idx {
    my ($self,$text) = @_;
    if(defined $text) {
        $text =~ s/\s+$//s; # strip trailing whitespace
        $text =~ s/\s+/ /gs; # collapse whitespace
        # add node, order important!
        push(@{$self->{'_index'}}, $text);
        # keep also a uniqueness counter
        $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
        return $text;
    }
    @{$self->{'_index'}};
}

##################################

# 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];
}

=item C<$checker-E<gt>hyperlinks()>

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

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"});
    }
}

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;

my %nodes;
    for ($self->node()) {
        $nodes{$_} = 1;
        if(/^(\S+)\s+\S/) {
            # we have more than one word. Use the first as a node, too.
            # This is used heavily in perlfunc.pod
            $nodes{$1} ||= 2; # derived node
        }
    }
    for ($self->idx()) {
        $nodes{$_} = 3; # index 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'} > 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'"});
            }
        }
    }
}

########  Formatting codes

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;
}

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 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 {
            $self->hyperlink($link);
        }
    }
}

sub end_L {
    my $self = shift;
    $self->end_fcode();
}

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();
}

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;
}

=item line()

Returns the approximate line number in which the link was encountered

=cut

sub line {
    return $_[0]->{-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};
}

=item page()

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>,
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>

=cut

Back to File Manager