← Back
Editing: 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 1
Save File
Cancel