home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / Pod / Checker.pm next >
Text File  |  2000-03-13  |  38KB  |  1,196 lines
  1. #############################################################################
  2. # Pod/Checker.pm -- check pod documents for syntax errors
  3. #
  4. # Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
  5. # This file is part of "PodParser". PodParser is free software;
  6. # you can redistribute it and/or modify it under the same terms
  7. # as Perl itself.
  8. #############################################################################
  9.  
  10. package Pod::Checker;
  11.  
  12. use vars qw($VERSION);
  13. $VERSION = 1.098;  ## Current version of this package
  14. require  5.005;    ## requires this Perl version or later
  15.  
  16. use Pod::ParseUtils; ## for hyperlinks and lists
  17.  
  18. =head1 NAME
  19.  
  20. Pod::Checker, podchecker() - check pod documents for syntax errors
  21.  
  22. =head1 SYNOPSIS
  23.  
  24.   use Pod::Checker;
  25.  
  26.   $syntax_okay = podchecker($filepath, $outputpath, %options);
  27.  
  28.   my $checker = new Pod::Checker %options;
  29.   $checker->parse_from_file($filepath, \*STDERR);
  30.  
  31. =head1 OPTIONS/ARGUMENTS
  32.  
  33. C<$filepath> is the input POD to read and C<$outputpath> is
  34. where to write POD syntax error messages. Either argument may be a scalar
  35. indicating a file-path, or else a reference to an open filehandle.
  36. If unspecified, the input-file it defaults to C<\*STDIN>, and
  37. the output-file defaults to C<\*STDERR>.
  38.  
  39. =head2 podchecker()
  40.  
  41. This function can take a hash of options:
  42.  
  43. =over 4
  44.  
  45. =item B<-warnings> =E<gt> I<val>
  46.  
  47. Turn warnings on/off. See L<"Warnings">.
  48.  
  49. =back
  50.  
  51. =head1 DESCRIPTION
  52.  
  53. B<podchecker> will perform syntax checking of Perl5 POD format documentation.
  54.  
  55. I<NOTE THAT THIS MODULE IS CURRENTLY IN THE BETA STAGE!>
  56.  
  57. It is hoped that curious/ambitious user will help flesh out and add the
  58. additional features they wish to see in B<Pod::Checker> and B<podchecker>
  59. and verify that the checks are consistent with L<perlpod>.
  60.  
  61. The following checks are currently preformed:
  62.  
  63. =over 4
  64.  
  65. =item *
  66.  
  67. Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
  68. and unterminated interior sequences.
  69.  
  70. =item *
  71.  
  72. Check for proper balancing of C<=begin> and C<=end>. The contents of such
  73. a block are generally ignored, i.e. no syntax checks are performed.
  74.  
  75. =item *
  76.  
  77. Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
  78.  
  79. =item *
  80.  
  81. Check for same nested interior-sequences (e.g. 
  82. C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
  83.  
  84. =item *
  85.  
  86. Check for malformed or nonexisting entities C<EE<lt>...E<gt>>.
  87.  
  88. =item *
  89.  
  90. Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
  91. for details.
  92.  
  93. =item *
  94.  
  95. Check for unresolved document-internal links. This check may also reveal
  96. misspelled links that seem to be internal links but should be links
  97. to something else.
  98.  
  99. =back
  100.  
  101. =head1 DIAGNOSTICS
  102.  
  103. =head2 Errors
  104.  
  105. =over 4
  106.  
  107. =item * empty =headn
  108.  
  109. A heading (C<=head1> or C<=head2>) without any text? That ain't no
  110. heading!
  111.  
  112. =item * =over on line I<N> without closing =back
  113.  
  114. The C<=over> command does not have a corresponding C<=back> before the
  115. next heading (C<=head1> or C<=head2>) or the end of the file.
  116.  
  117. =item * =item without previous =over
  118.  
  119. =item * =back without previous =over
  120.  
  121. An C<=item> or C<=back> command has been found outside a
  122. C<=over>/C<=back> block.
  123.  
  124. =item * No argument for =begin
  125.  
  126. A C<=begin> command was found that is not followed by the formatter
  127. specification.
  128.  
  129. =item * =end without =begin
  130.  
  131. A standalone C<=end> command was found.
  132.  
  133. =item * Nested =begin's
  134.  
  135. There were at least two consecutive C<=begin> commands without
  136. the corresponding C<=end>. Only one C<=begin> may be active at
  137. a time.
  138.  
  139. =item * =for without formatter specification
  140.  
  141. There is no specification of the formatter after the C<=for> command.
  142.  
  143. =item * unresolved internal link I<NAME>
  144.  
  145. The given link to I<NAME> does not have a matching node in the current
  146. POD. This also happend when a single word node name is not enclosed in
  147. C<"">.
  148.  
  149. =item * Unknown command "I<CMD>"
  150.  
  151. An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
  152. C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, C<=for>, C<=pod>,
  153. C<=cut>
  154.  
  155. =item * Unknown interior-sequence "I<SEQ>"
  156.  
  157. An invalid markup command has been encountered. Valid are:
  158. C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>, 
  159. C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>, 
  160. C<ZE<lt>E<gt>>
  161.  
  162. =item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
  163.  
  164. Two nested identical markup commands have been found. Generally this
  165. does not make sense.
  166.  
  167. =item * garbled entity I<STRING>
  168.  
  169. The I<STRING> found cannot be interpreted as a character entity.
  170.  
  171. =item * Entity number out of range
  172.  
  173. An entity specified by number (dec, hex, oct) is out of range (1-255).
  174.  
  175. =item * malformed link LE<lt>E<gt>
  176.  
  177. The link found cannot be parsed because it does not conform to the
  178. syntax described in L<perlpod>.
  179.  
  180. =item * nonempty ZE<lt>E<gt>
  181.  
  182. The C<ZE<lt>E<gt>> sequence is supposed to be empty.
  183.  
  184. =item * empty XE<lt>E<gt>
  185.  
  186. The index entry specified contains nothing but whitespace.
  187.  
  188. =item * Spurious text after =pod / =cut
  189.  
  190. The commands C<=pod> and C<=cut> do not take any arguments.
  191.  
  192. =item * Spurious character(s) after =back
  193.  
  194. The C<=back> command does not take any arguments.
  195.  
  196. =back
  197.  
  198. =head2 Warnings
  199.  
  200. These may not necessarily cause trouble, but indicate mediocre style.
  201.  
  202. =over 4
  203.  
  204. =item * multiple occurence of link target I<name>
  205.  
  206. The POD file has some C<=item> and/or C<=head> commands that have
  207. the same text. Potential hyperlinks to such a text cannot be unique then.
  208.  
  209. =item * line containing nothing but whitespace in paragraph
  210.  
  211. There is some whitespace on a seemingly empty line. POD is very sensitive
  212. to such things, so this is flagged. B<vi> users switch on the B<list>
  213. option to avoid this problem.
  214.  
  215. =item * file does not start with =head
  216.  
  217. The file starts with a different POD directive than head.
  218. This is most probably something you do not want.
  219.  
  220. =item * No numeric argument for =over
  221.  
  222. The C<=over> command is supposed to have a numeric argument (the
  223. indentation).
  224.  
  225. =item * previous =item has no contents
  226.  
  227. There is a list C<=item> right above the flagged line that has no
  228. text contents. You probably want to delete empty items.
  229.  
  230. =item * preceding non-item paragraph(s)
  231.  
  232. A list introduced by C<=over> starts with a text or verbatim paragraph,
  233. but continues with C<=item>s. Move the non-item paragraph out of the
  234. C<=over>/C<=back> block.
  235.  
  236. =item * =item type mismatch (I<one> vs. I<two>)
  237.  
  238. A list started with e.g. a bulletted C<=item> and continued with a
  239. numbered one. This is obviously inconsistent. For most translators the
  240. type of the I<first> C<=item> determines the type of the list.
  241.  
  242. =item * I<N> unescaped C<E<lt>E<gt>> in paragraph
  243.  
  244. Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>
  245. can potentially cause errors as they could be misinterpreted as
  246. markup commands.
  247.  
  248. =item * Unknown entity
  249.  
  250. A character entity was found that does not belong to the standard
  251. ISO set or the POD specials C<verbar> and C<sol>.
  252.  
  253. =item * No items in =over
  254.  
  255. The list opened with C<=over> does not contain any items.
  256.  
  257. =item * No argument for =item
  258.  
  259. C<=item> without any parameters is deprecated. It should either be followed
  260. by C<*> to indicate an unordered list, by a number (optionally followed
  261. by a dot) to indicate an ordered (numbered) list or simple text for a
  262. definition list.
  263.  
  264. =item * empty section in previous paragraph
  265.  
  266. The previous section (introduced by a C<=head> command) does not contain
  267. any text. This usually indicates that something is missing. Note: A 
  268. C<=head1> followed immediately by C<=head2> does not trigger this warning.
  269.  
  270. =item * Verbatim paragraph in NAME section
  271.  
  272. The NAME section (C<=head1 NAME>) should consist of a single paragraph
  273. with the script/module name, followed by a dash `-' and a very short
  274. description of what the thing is good for.
  275.  
  276. =item * Hyperlinks
  277.  
  278. There are some warnings wrt. hyperlinks:
  279. Leading/trailing whitespace, newlines in hyperlinks,
  280. brackets C<()>.
  281.  
  282. =back
  283.  
  284. =head1 RETURN VALUE
  285.  
  286. B<podchecker> returns the number of POD syntax errors found or -1 if
  287. there were no POD commands at all found in the file.
  288.  
  289. =head1 EXAMPLES
  290.  
  291. I<[T.B.D.]>
  292.  
  293. =head1 INTERFACE
  294.  
  295. While checking, this module collects document properties, e.g. the nodes
  296. for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
  297. POD translators can use this feature to syntax-check and get the nodes in
  298. a first pass before actually starting to convert. This is expensive in terms
  299. of execution time, but allows for very robust conversions.
  300.  
  301. =cut
  302.  
  303. #############################################################################
  304.  
  305. use strict;
  306. #use diagnostics;
  307. use Carp;
  308. use Exporter;
  309. use Pod::Parser;
  310. require VMS::Filespec if $^O eq 'VMS';
  311.  
  312. use vars qw(@ISA @EXPORT);
  313. @ISA = qw(Pod::Parser);
  314. @EXPORT = qw(&podchecker);
  315.  
  316. use vars qw(%VALID_COMMANDS %VALID_SEQUENCES);
  317.  
  318. my %VALID_COMMANDS = (
  319.     'pod'    =>  1,
  320.     'cut'    =>  1,
  321.     'head1'  =>  1,
  322.     'head2'  =>  1,
  323.     'over'   =>  1,
  324.     'back'   =>  1,
  325.     'item'   =>  1,
  326.     'for'    =>  1,
  327.     'begin'  =>  1,
  328.     'end'    =>  1,
  329. );
  330.  
  331. my %VALID_SEQUENCES = (
  332.     'I'  =>  1,
  333.     'B'  =>  1,
  334.     'S'  =>  1,
  335.     'C'  =>  1,
  336.     'L'  =>  1,
  337.     'F'  =>  1,
  338.     'X'  =>  1,
  339.     'Z'  =>  1,
  340.     'E'  =>  1,
  341. );
  342.  
  343. # stolen from HTML::Entities
  344. my %ENTITIES = (
  345.  # Some normal chars that have special meaning in SGML context
  346.  amp    => '&',  # ampersand 
  347. 'gt'    => '>',  # greater than
  348. 'lt'    => '<',  # less than
  349.  quot   => '"',  # double quote
  350.  
  351.  # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
  352.  AElig    => '╞',  # capital AE diphthong (ligature)
  353.  Aacute    => '┴',  # capital A, acute accent
  354.  Acirc    => '┬',  # capital A, circumflex accent
  355.  Agrave    => '└',  # capital A, grave accent
  356.  Aring    => '┼',  # capital A, ring
  357.  Atilde    => '├',  # capital A, tilde
  358.  Auml    => '─',  # capital A, dieresis or umlaut mark
  359.  Ccedil    => '╟',  # capital C, cedilla
  360.  ETH    => '╨',  # capital Eth, Icelandic
  361.  Eacute    => '╔',  # capital E, acute accent
  362.  Ecirc    => '╩',  # capital E, circumflex accent
  363.  Egrave    => '╚',  # capital E, grave accent
  364.  Euml    => '╦',  # capital E, dieresis or umlaut mark
  365.  Iacute    => '═',  # capital I, acute accent
  366.  Icirc    => '╬',  # capital I, circumflex accent
  367.  Igrave    => '╠',  # capital I, grave accent
  368.  Iuml    => '╧',  # capital I, dieresis or umlaut mark
  369.  Ntilde    => '╤',  # capital N, tilde
  370.  Oacute    => '╙',  # capital O, acute accent
  371.  Ocirc    => '╘',  # capital O, circumflex accent
  372.  Ograve    => '╥',  # capital O, grave accent
  373.  Oslash    => '╪',  # capital O, slash
  374.  Otilde    => '╒',  # capital O, tilde
  375.  Ouml    => '╓',  # capital O, dieresis or umlaut mark
  376.  THORN    => '▐',  # capital THORN, Icelandic
  377.  Uacute    => '┌',  # capital U, acute accent
  378.  Ucirc    => '█',  # capital U, circumflex accent
  379.  Ugrave    => '┘',  # capital U, grave accent
  380.  Uuml    => '▄',  # capital U, dieresis or umlaut mark
  381.  Yacute    => '▌',  # capital Y, acute accent
  382.  aacute    => 'ß',  # small a, acute accent
  383.  acirc    => 'Γ',  # small a, circumflex accent
  384.  aelig    => 'µ',  # small ae diphthong (ligature)
  385.  agrave    => 'α',  # small a, grave accent
  386.  aring    => 'σ',  # small a, ring
  387.  atilde    => 'π',  # small a, tilde
  388.  auml    => 'Σ',  # small a, dieresis or umlaut mark
  389.  ccedil    => 'τ',  # small c, cedilla
  390.  eacute    => 'Θ',  # small e, acute accent
  391.  ecirc    => 'Ω',  # small e, circumflex accent
  392.  egrave    => 'Φ',  # small e, grave accent
  393.  eth    => '≡',  # small eth, Icelandic
  394.  euml    => 'δ',  # small e, dieresis or umlaut mark
  395.  iacute    => 'φ',  # small i, acute accent
  396.  icirc    => 'ε',  # small i, circumflex accent
  397.  igrave    => '∞',  # small i, grave accent
  398.  iuml    => '∩',  # small i, dieresis or umlaut mark
  399.  ntilde    => '±',  # small n, tilde
  400.  oacute    => '≤',  # small o, acute accent
  401.  ocirc    => '⌠',  # small o, circumflex accent
  402.  ograve    => '≥',  # small o, grave accent
  403.  oslash    => '°',  # small o, slash
  404.  otilde    => '⌡',  # small o, tilde
  405.  ouml    => '÷',  # small o, dieresis or umlaut mark
  406.  szlig    => '▀',  # small sharp s, German (sz ligature)
  407.  thorn    => '■',  # small thorn, Icelandic
  408.  uacute    => '·',  # small u, acute accent
  409.  ucirc    => '√',  # small u, circumflex accent
  410.  ugrave    => '∙',  # small u, grave accent
  411.  uuml    => 'ⁿ',  # small u, dieresis or umlaut mark
  412.  yacute    => '²',  # small y, acute accent
  413.  yuml    => ' ',  # small y, dieresis or umlaut mark
  414.  
  415.  # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
  416.  copy   => '⌐',  # copyright sign
  417.  reg    => '«',  # registered sign
  418.  nbsp   => "\240", # non breaking space
  419.  
  420.  # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
  421.  iexcl  => 'í',
  422.  cent   => 'ó',
  423.  pound  => 'ú',
  424.  curren => 'ñ',
  425.  yen    => 'Ñ',
  426.  brvbar => 'ª',
  427.  sect   => 'º',
  428.  uml    => '¿',
  429.  ordf   => '¬',
  430.  laquo  => '½',
  431. 'not'   => '¼',    # not is a keyword in perl
  432.  shy    => '¡',
  433.  macr   => '»',
  434.  deg    => '░',
  435.  plusmn => '▒',
  436.  sup1   => '╣',
  437.  sup2   => '▓',
  438.  sup3   => '│',
  439.  acute  => '┤',
  440.  micro  => '╡',
  441.  para   => '╢',
  442.  middot => '╖',
  443.  cedil  => '╕',
  444.  ordm   => '║',
  445.  raquo  => '╗',
  446.  frac14 => '╝',
  447.  frac12 => '╜',
  448.  frac34 => '╛',
  449.  iquest => '┐',
  450. 'times' => '╫',    # times is a keyword in perl
  451.  divide => '≈',
  452.  
  453. # some POD special entities
  454.  verbar => '|',
  455.  sol => '/'
  456. );
  457.  
  458. ##---------------------------------------------------------------------------
  459.  
  460. ##---------------------------------
  461. ## Function definitions begin here
  462. ##---------------------------------
  463.  
  464. sub podchecker( $ ; $ % ) {
  465.     my ($infile, $outfile, %options) = @_;
  466.     local $_;
  467.  
  468.     ## Set defaults
  469.     $infile  ||= \*STDIN;
  470.     $outfile ||= \*STDERR;
  471.  
  472.     ## Now create a pod checker
  473.     my $checker = new Pod::Checker(%options);
  474.     $checker->parseopts(-process_cut_cmd => 1, -warnings => 1);
  475.  
  476.     ## Now check the pod document for errors
  477.     $checker->parse_from_file($infile, $outfile);
  478.  
  479.     ## Return the number of errors found
  480.     return $checker->num_errors();
  481. }
  482.  
  483. ##---------------------------------------------------------------------------
  484.  
  485. ##-------------------------------
  486. ## Method definitions begin here
  487. ##-------------------------------
  488.  
  489. ## sub new {
  490. ##     my $this = shift;
  491. ##     my $class = ref($this) || $this;
  492. ##     my %params = @_;
  493. ##     my $self = {%params};
  494. ##     bless $self, $class;
  495. ##     $self->initialize();
  496. ##     return $self;
  497. ## }
  498.  
  499. sub initialize {
  500.     my $self = shift;
  501.     ## Initialize number of errors, and setup an error function to
  502.     ## increment this number and then print to the designated output.
  503.     $self->{_NUM_ERRORS} = 0;
  504.     $self->errorsub('poderror'); # set the error handling subroutine
  505.     $self->{_commands} = 0; # total number of POD commands encountered
  506.     $self->{_list_stack} = []; # stack for nested lists
  507.     $self->{_have_begin} = ''; # stores =begin
  508.     $self->{_links} = []; # stack for internal hyperlinks
  509.     $self->{_nodes} = []; # stack for =head/=item nodes
  510.     $self->{_index} = []; # text in X<>
  511.     # print warnings?
  512.     $self->{-warnings} = 1 unless(defined $self->{-warnings});
  513.     $self->{_current_head1} = ''; # the current =head1 block
  514. }
  515.  
  516. ##################################
  517.  
  518. =over 4
  519.  
  520. =item C<$checker-E<gt>poderror( @args )>
  521.  
  522. =item C<$checker-E<gt>poderror( {%opts}, @args )>
  523.  
  524. Internal method for printing errors and warnings. If no options are
  525. given, simply prints "@_". The following options are recognized and used
  526. to form the output:
  527.  
  528.   -msg
  529.  
  530. A message to print prior to C<@args>.
  531.  
  532.   -line
  533.  
  534. The line number the error occurred in.
  535.  
  536.   -file
  537.  
  538. The file (name) the error occurred in.
  539.  
  540.   -severity
  541.  
  542. The error level, should be 'WARNING' or 'ERROR'.
  543.  
  544. =cut
  545.  
  546. # Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
  547. sub poderror {
  548.     my $self = shift;
  549.     my %opts = (ref $_[0]) ? %{shift()} : ();
  550.     $opts{-file} = VMS::Filespec::unixify($opts{-file}) if (exists($opts{-file}) && $^O eq 'VMS');
  551.  
  552.     ## Retrieve options
  553.     chomp( my $msg  = ($opts{-msg} || "")."@_" );
  554.     my $line = (exists $opts{-line}) ? " at line $opts{-line}" : "";
  555.     my $file = (exists $opts{-file}) ? " in file $opts{-file}" : "";
  556.     unless (exists $opts{-severity}) {
  557.        ## See if can find severity in message prefix
  558.        $opts{-severity} = $1  if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
  559.     }
  560.     my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : "";
  561.  
  562.     ## Increment error count and print message "
  563.     ++($self->{_NUM_ERRORS}) 
  564.         if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));
  565.     my $out_fh = $self->output_handle();
  566.     print $out_fh ($severity, $msg, $line, $file, "\n")
  567.       if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');
  568. }
  569.  
  570. ##################################
  571.  
  572. =item C<$checker-E<gt>num_errors()>
  573.  
  574. Set (if argument specified) and retrieve the number of errors found.
  575.  
  576. =cut
  577.  
  578. sub num_errors {
  579.    return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};
  580. }
  581.  
  582. ##################################
  583.  
  584. =item C<$checker-E<gt>name()>
  585.  
  586. Set (if argument specified) and retrieve the canonical name of POD as
  587. found in the C<=head1 NAME> section.
  588.  
  589. =cut
  590.  
  591. sub name {
  592.     return (@_ > 1 && $_[1]) ?
  593.         ($_[0]->{-name} = $_[1]) : $_[0]->{-name};  
  594. }
  595.  
  596. ##################################
  597.  
  598. =item C<$checker-E<gt>node()>
  599.  
  600. Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
  601. and C<=item>) of the current POD. The nodes are returned in the order of
  602. their occurence. They consist of plain text, each piece of whitespace is
  603. collapsed to a single blank.
  604.  
  605. =cut
  606.  
  607. sub node {
  608.     my ($self,$text) = @_;
  609.     if(defined $text) {
  610.         $text =~ s/\s+$//s; # strip trailing whitespace
  611.         $text =~ s/\s+/ /gs; # collapse whitespace
  612.         # add node, order important!
  613.         push(@{$self->{_nodes}}, $text);
  614.         # keep also a uniqueness counter
  615.         $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
  616.         return $text;
  617.     }
  618.     @{$self->{_nodes}};
  619. }
  620.  
  621. ##################################
  622.  
  623. =item C<$checker-E<gt>idx()>
  624.  
  625. Add (if argument specified) and retrieve the index entries (as defined by
  626. C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
  627. of whitespace is collapsed to a single blank.
  628.  
  629. =cut
  630.  
  631. # set/return index entries of current POD
  632. sub idx {
  633.     my ($self,$text) = @_;
  634.     if(defined $text) {
  635.         $text =~ s/\s+$//s; # strip trailing whitespace
  636.         $text =~ s/\s+/ /gs; # collapse whitespace
  637.         # add node, order important!
  638.         push(@{$self->{_index}}, $text);
  639.         # keep also a uniqueness counter
  640.         $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
  641.         return $text;
  642.     }
  643.     @{$self->{_index}};
  644. }
  645.  
  646. ##################################
  647.  
  648. =item C<$checker-E<gt>hyperlink()>
  649.  
  650. Add (if argument specified) and retrieve the hyperlinks (as defined by
  651. C<LE<lt>E<gt>>) of the current POD. They consist of an 2-item array: line
  652. number and C<Pod::Hyperlink> object.
  653.  
  654. =back
  655.  
  656. =cut
  657.  
  658. # set/return hyperlinks of the current POD
  659. sub hyperlink {
  660.     my $self = shift;
  661.     if($_[0]) {
  662.         push(@{$self->{_links}}, $_[0]);
  663.         return $_[0];
  664.     }
  665.     @{$self->{_links}};
  666. }
  667.  
  668. ## overrides for Pod::Parser
  669.  
  670. sub end_pod {
  671.     ## Do some final checks and
  672.     ## print the number of errors found
  673.     my $self   = shift;
  674.     my $infile = $self->input_file();
  675.     $infile = VMS::Filespec::unixify($infile) if $^O eq 'VMS';
  676.     my $out_fh = $self->output_handle();
  677.  
  678.     if(@{$self->{_list_stack}}) {
  679.         # _TODO_ display, but don't count them for now
  680.         my $list;
  681.         while(($list = $self->_close_list('EOF',$infile)) &&
  682.           $list->indent() ne 'auto') {
  683.             $self->poderror({ -line => 'EOF', -file => $infile,
  684.                 -severity => 'ERROR', -msg => "=over on line " .
  685.                 $list->start() . " without closing =back" }); #"
  686.         }
  687.     }
  688.  
  689.     # check validity of document internal hyperlinks
  690.     # first build the node names from the paragraph text
  691.     my %nodes;
  692.     foreach($self->node()) {
  693.         $nodes{$_} = 1;
  694.         if(/^(\S+)\s+/) {
  695.             # we have more than one word. Use the first as a node, too.
  696.             # This is used heavily in perlfunc.pod
  697.             $nodes{$1} ||= 2; # derived node
  698.         }
  699.     }
  700.     foreach($self->hyperlink()) {
  701.         my ($line,$link) = @$_;
  702.         # _TODO_ what if there is a link to the page itself by the name,
  703.         # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">
  704.         if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {
  705.             my $node = $self->_check_ptree($self->parse_text($link->node(),
  706.                 $line), $line, $infile, 'L');
  707.             if($node && !$nodes{$node}) {
  708.                 $self->poderror({ -line => $line || '', -file => $infile,
  709.                     -severity => 'ERROR',
  710.                     -msg => "unresolved internal link '$node'"});
  711.             }
  712.         }
  713.     }
  714.  
  715.     # check the internal nodes for uniqueness. This pertains to
  716.     # =headX, =item and X<...>
  717.     foreach(grep($self->{_unique_nodes}->{$_} > 1,
  718.       keys %{$self->{_unique_nodes}})) {
  719.         $self->poderror({ -line => '-', -file => $infile,
  720.             -severity => 'WARNING',
  721.             -msg => "multiple occurence of link target '$_'"});
  722.     }
  723.  
  724.     ## Print the number of errors found
  725.     my $num_errors = $self->num_errors();
  726.     if ($num_errors > 0) {
  727.         printf $out_fh ("$infile has $num_errors pod syntax %s.\n",
  728.                       ($num_errors == 1) ? "error" : "errors");
  729.     }
  730.     elsif($self->{_commands} == 0) {
  731.         print $out_fh "$infile does not contain any pod commands.\n";
  732.         $self->num_errors(-1);
  733.     }
  734.     else {
  735.         print $out_fh "$infile pod syntax OK.\n";
  736.     }
  737. }
  738.  
  739. # check a POD command directive
  740. sub command { 
  741.     my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
  742.     my ($file, $line) = $pod_para->file_line;
  743.     ## Check the command syntax
  744.     my $arg; # this will hold the command argument
  745.     if (! $VALID_COMMANDS{$cmd}) {
  746.        $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
  747.                          -msg => "Unknown command '$cmd'" });
  748.     }
  749.     else {
  750.         # found a valid command
  751.         if(!$self->{_commands}++ && $cmd !~ /^head/) {
  752.             $self->poderror({ -line => $line, -file => $file,
  753.                  -severity => 'WARNING', 
  754.                  -msg => "file does not start with =head" });
  755.         }
  756.         ## check syntax of particular command
  757.         if($cmd eq 'over') {
  758.             # check for argument
  759.             $arg = $self->interpolate_and_check($paragraph, $line,$file);
  760.             my $indent = 4; # default
  761.             if($arg && $arg =~ /^\s*(\d+)\s*$/) {
  762.                 $indent = $1;
  763.             } else {
  764.                 $self->poderror({ -line => $line, -file => $file,
  765.                      -severity => 'WARNING', 
  766.                      -msg => "No numeric argument for =over"});
  767.             }
  768.             # start a new list
  769.             $self->_open_list($indent,$line,$file);
  770.         }
  771.         elsif($cmd eq 'item') {
  772.             # are we in a list?
  773.             unless(@{$self->{_list_stack}}) {
  774.                 $self->poderror({ -line => $line, -file => $file,
  775.                      -severity => 'ERROR', 
  776.                      -msg => "=item without previous =over" });
  777.                 # auto-open in case we encounter many more
  778.                 $self->_open_list('auto',$line,$file);
  779.             }
  780.             my $list = $self->{_list_stack}->[0];
  781.             # check whether the previous item had some contents
  782.             if(defined $self->{_list_item_contents} &&
  783.               $self->{_list_item_contents} == 0) {
  784.                 $self->poderror({ -line => $line, -file => $file,
  785.                      -severity => 'WARNING', 
  786.                      -msg => "previous =item has no contents" });
  787.             }
  788.             if($list->{_has_par}) {
  789.                 $self->poderror({ -line => $line, -file => $file,
  790.                      -severity => 'WARNING', 
  791.                      -msg => "preceding non-item paragraph(s)" });
  792.                 delete $list->{_has_par};
  793.             }
  794.             # check for argument
  795.             $arg = $self->interpolate_and_check($paragraph, $line, $file);
  796.             if($arg && $arg =~ /(\S+)/) {
  797.                 $arg =~ s/[\s\n]+$//;
  798.                 my $type;
  799.                 if($arg =~ /^[*]\s*(\S*.*)/) {
  800.                   $type = 'bullet';
  801.                   $self->{_list_item_contents} = $1 ? 1 : 0;
  802.                   $arg = $1;
  803.                 }
  804.                 elsif($arg =~ /^\d+\.?\s*(\S*)/) {
  805.                   $type = 'number';
  806.                   $self->{_list_item_contents} = $1 ? 1 : 0;
  807.                   $arg = $1;
  808.                 }
  809.                 else {
  810.                   $type = 'definition';
  811.                   $self->{_list_item_contents} = 1;
  812.                 }
  813.                 my $first = $list->type();
  814.                 if($first && $first ne $type) {
  815.                     $self->poderror({ -line => $line, -file => $file,
  816.                        -severity => 'WARNING', 
  817.                        -msg => "=item type mismatch ('$first' vs. '$type')"});
  818.                 }
  819.                 else { # first item
  820.                     $list->type($type);
  821.                 }
  822.             }
  823.             else {
  824.                 $self->poderror({ -line => $line, -file => $file,
  825.                      -severity => 'WARNING', 
  826.                      -msg => "No argument for =item" });
  827.         $arg = ' '; # empty
  828.                 $self->{_list_item_contents} = 0;
  829.             }
  830.             # add this item
  831.             $list->item($arg);
  832.             # remember this node
  833.             $self->node($arg);
  834.         }
  835.         elsif($cmd eq 'back') {
  836.             # check if we have an open list
  837.             unless(@{$self->{_list_stack}}) {
  838.                 $self->poderror({ -line => $line, -file => $file,
  839.                          -severity => 'ERROR', 
  840.                          -msg => "=back without previous =over" });
  841.             }
  842.             else {
  843.                 # check for spurious characters
  844.                 $arg = $self->interpolate_and_check($paragraph, $line,$file);
  845.                 if($arg && $arg =~ /\S/) {
  846.                     $self->poderror({ -line => $line, -file => $file,
  847.                          -severity => 'ERROR', 
  848.                          -msg => "Spurious character(s) after =back" });
  849.                 }
  850.                 # close list
  851.                 my $list = $self->_close_list($line,$file);
  852.                 # check for empty lists
  853.                 if(!$list->item() && $self->{-warnings}) {
  854.                     $self->poderror({ -line => $line, -file => $file,
  855.                          -severity => 'WARNING', 
  856.                          -msg => "No items in =over (at line " .
  857.                          $list->start() . ") / =back list"}); #"
  858.                 }
  859.             }
  860.         }
  861.         elsif($cmd =~ /^head(\d+)/) {
  862.             # check whether the previous =head section had some contents
  863.             if(defined $self->{_commands_in_head} &&
  864.               $self->{_commands_in_head} == 0 &&
  865.               defined $self->{_last_head} &&
  866.               $self->{_last_head} >= $1) {
  867.                 $self->poderror({ -line => $line, -file => $file,
  868.                      -severity => 'WARNING', 
  869.                      -msg => "empty section in previous paragraph"});
  870.             }
  871.             $self->{_commands_in_head} = -1;
  872.             $self->{_last_head} = $1;
  873.             # check if there is an open list
  874.             if(@{$self->{_list_stack}}) {
  875.                 my $list;
  876.                 while(($list = $self->_close_list($line,$file)) &&
  877.                   $list->indent() ne 'auto') {
  878.                     $self->poderror({ -line => $line, -file => $file,
  879.                          -severity => 'ERROR', 
  880.                          -msg => "=over on line ". $list->start() .
  881.                          " without closing =back (at $cmd)" });
  882.                 }
  883.             }
  884.             # remember this node
  885.             $arg = $self->interpolate_and_check($paragraph, $line,$file);
  886.             $arg =~ s/[\s\n]+$//s;
  887.             $self->node($arg);
  888.             unless(length($arg)) {
  889.                 $self->poderror({ -line => $line, -file => $file,
  890.                      -severity => 'ERROR', 
  891.                      -msg => "empty =$cmd"});
  892.             }
  893.             if($cmd eq 'head1') {
  894.                 $self->{_current_head1} = $arg;
  895.             } else {
  896.                 $self->{_current_head1} = '';
  897.             }
  898.         }
  899.         elsif($cmd eq 'begin') {
  900.             if($self->{_have_begin}) {
  901.                 # already have a begin
  902.                 $self->poderror({ -line => $line, -file => $file,
  903.                      -severity => 'ERROR', 
  904.                      -msg => "Nested =begin's (first at line " .
  905.                      $self->{_have_begin} . ")"});
  906.             }
  907.             else {
  908.                 # check for argument
  909.                 $arg = $self->interpolate_and_check($paragraph, $line,$file);
  910.                 unless($arg && $arg =~ /(\S+)/) {
  911.                     $self->poderror({ -line => $line, -file => $file,
  912.                          -severity => 'ERROR', 
  913.                          -msg => "No argument for =begin"});
  914.                 }
  915.                 # remember the =begin
  916.                 $self->{_have_begin} = "$line:$1";
  917.             }
  918.         }
  919.         elsif($cmd eq 'end') {
  920.             if($self->{_have_begin}) {
  921.                 # close the existing =begin
  922.                 $self->{_have_begin} = '';
  923.                 # check for spurious characters
  924.                 $arg = $self->interpolate_and_check($paragraph, $line,$file);
  925.                 # the closing argument is optional
  926.                 #if($arg && $arg =~ /\S/) {
  927.                 #    $self->poderror({ -line => $line, -file => $file,
  928.                 #         -severity => 'WARNING', 
  929.                 #         -msg => "Spurious character(s) after =end" });
  930.                 #}
  931.             }
  932.             else {
  933.                 # don't have a matching =begin
  934.                 $self->poderror({ -line => $line, -file => $file,
  935.                      -severity => 'ERROR', 
  936.                      -msg => "=end without =begin" });
  937.             }
  938.         }
  939.         elsif($cmd eq 'for') {
  940.             unless($paragraph =~ /\s*(\S+)\s*/) {
  941.                 $self->poderror({ -line => $line, -file => $file,
  942.                      -severity => 'ERROR', 
  943.                      -msg => "=for without formatter specification" });
  944.             }
  945.             $arg = ''; # do not expand paragraph below
  946.         }
  947.         elsif($cmd =~ /^(pod|cut)$/) {
  948.             # check for argument
  949.             $arg = $self->interpolate_and_check($paragraph, $line,$file);
  950.             if($arg && $arg =~ /(\S+)/) {
  951.                 $self->poderror({ -line => $line, -file => $file,
  952.                       -severity => 'ERROR', 
  953.                       -msg => "Spurious text after =$cmd"});
  954.             }
  955.         }
  956.     $self->{_commands_in_head}++;
  957.     ## Check the interior sequences in the command-text
  958.     $self->interpolate_and_check($paragraph, $line,$file)
  959.         unless(defined $arg);
  960.     }
  961. }
  962.  
  963. sub _open_list
  964. {
  965.     my ($self,$indent,$line,$file) = @_;
  966.     my $list = Pod::List->new(
  967.            -indent => $indent,
  968.            -start => $line,
  969.            -file => $file);
  970.     unshift(@{$self->{_list_stack}}, $list);
  971.     undef $self->{_list_item_contents};
  972.     $list;
  973. }
  974.  
  975. sub _close_list
  976. {
  977.     my ($self,$line,$file) = @_;
  978.     my $list = shift(@{$self->{_list_stack}});
  979.     if(defined $self->{_list_item_contents} &&
  980.       $self->{_list_item_contents} == 0) {
  981.         $self->poderror({ -line => $line, -file => $file,
  982.             -severity => 'WARNING', 
  983.             -msg => "previous =item has no contents" });
  984.     }
  985.     undef $self->{_list_item_contents};
  986.     $list;
  987. }
  988.  
  989. # process a block of some text
  990. sub interpolate_and_check {
  991.     my ($self, $paragraph, $line, $file) = @_;
  992.     ## Check the interior sequences in the command-text
  993.     # and return the text
  994.     $self->_check_ptree(
  995.         $self->parse_text($paragraph,$line), $line, $file, '');
  996. }
  997.  
  998. sub _check_ptree {
  999.     my ($self,$ptree,$line,$file,$nestlist) = @_;
  1000.     local($_);
  1001.     my $text = '';
  1002.     # process each node in the parse tree
  1003.     foreach(@$ptree) {
  1004.         # regular text chunk
  1005.         unless(ref) {
  1006.             my $count;
  1007.             # count the unescaped angle brackets
  1008.             my $i = $_;
  1009.             if($count = $i =~ tr/<>/<>/) {
  1010.                 $self->poderror({ -line => $line, -file => $file,
  1011.                      -severity => 'WARNING', 
  1012.                      -msg => "$count unescaped <> in paragraph" })
  1013.                 if($self->{-warnings});
  1014.             }
  1015.             $text .= $i;
  1016.             next;
  1017.         }
  1018.         # have an interior sequence
  1019.         my $cmd = $_->cmd_name();
  1020.         my $contents = $_->parse_tree();
  1021.         ($file,$line) = $_->file_line();
  1022.         # check for valid tag
  1023.         if (! $VALID_SEQUENCES{$cmd}) {
  1024.             $self->poderror({ -line => $line, -file => $file,
  1025.                  -severity => 'ERROR', 
  1026.                  -msg => qq(Unknown interior-sequence '$cmd')});
  1027.             # expand it anyway
  1028.             $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
  1029.             next;
  1030.         }
  1031.         if($nestlist =~ /$cmd/) {
  1032.             $self->poderror({ -line => $line, -file => $file,
  1033.                  -severity => 'ERROR', 
  1034.                  -msg => "nested commands $cmd<...$cmd<...>...>"});
  1035.             # _TODO_ should we add the contents anyway?
  1036.             # expand it anyway, see below
  1037.         }
  1038.         if($cmd eq 'E') {
  1039.             # preserve entities
  1040.             if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {
  1041.                 $self->poderror({ -line => $line, -file => $file,
  1042.                     -severity => 'ERROR', 
  1043.                     -msg => "garbled entity " . $_->raw_text()});
  1044.                 next;
  1045.             }
  1046.             my $ent = $$contents[0];
  1047.             my $val;
  1048.             if($ent =~ /^0x[0-9a-f]+$/i) {
  1049.                 # hexadec entity
  1050.                 $val = hex($ent);
  1051.             }
  1052.             elsif($ent =~ /^0\d+$/) {
  1053.                 # octal
  1054.                 $val = oct($ent);
  1055.             }
  1056.             elsif($ent =~ /^\d+$/) {
  1057.                 # numeric entity
  1058.                 $val = $ent;
  1059.             }
  1060.             if(defined $val) {
  1061.                 if($val>0 && $val<256) {
  1062.                     $text .= chr($val);
  1063.                 }
  1064.                 else {
  1065.                     $self->poderror({ -line => $line, -file => $file,
  1066.                         -severity => 'ERROR', 
  1067.                         -msg => "Entity number out of range " . $_->raw_text()});
  1068.                 }
  1069.             }
  1070.             elsif($ENTITIES{$ent}) {
  1071.                 # known ISO entity
  1072.                 $text .= $ENTITIES{$ent};
  1073.             }
  1074.             else {
  1075.                 $self->poderror({ -line => $line, -file => $file,
  1076.                     -severity => 'WARNING', 
  1077.                     -msg => "Unknown entity " . $_->raw_text()});
  1078.                 $text .= "E<$ent>";
  1079.             }
  1080.         }
  1081.         elsif($cmd eq 'L') {
  1082.             # try to parse the hyperlink
  1083.             my $link = Pod::Hyperlink->new($contents->raw_text());
  1084.             unless(defined $link) {
  1085.                 $self->poderror({ -line => $line, -file => $file,
  1086.                     -severity => 'ERROR', 
  1087.                     -msg => "malformed link " . $_->raw_text() ." : $@"});
  1088.                 next;
  1089.             }
  1090.             $link->line($line); # remember line
  1091.             if($self->{-warnings}) {
  1092.                 foreach my $w ($link->warning()) {
  1093.                     $self->poderror({ -line => $line, -file => $file,
  1094.                         -severity => 'WARNING', 
  1095.                         -msg => $w });
  1096.                 }
  1097.             }
  1098.             # check the link text
  1099.             $text .= $self->_check_ptree($self->parse_text($link->text(),
  1100.                 $line), $line, $file, "$nestlist$cmd");
  1101.             # remember link
  1102.             $self->hyperlink([$line,$link]);
  1103.         }
  1104.         elsif($cmd =~ /[BCFIS]/) {
  1105.             # add the guts
  1106.             $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
  1107.         }
  1108.         elsif($cmd eq 'Z') {
  1109.             if(length($contents->raw_text())) {
  1110.                 $self->poderror({ -line => $line, -file => $file,
  1111.                     -severity => 'ERROR', 
  1112.                     -msg => "Nonempty Z<>"});
  1113.             }
  1114.         }
  1115.         elsif($cmd eq 'X') {
  1116.             my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
  1117.             if($idx =~ /^\s*$/s) {
  1118.                 $self->poderror({ -line => $line, -file => $file,
  1119.                     -severity => 'ERROR', 
  1120.                     -msg => "Empty X<>"});
  1121.             }
  1122.             else {
  1123.                 # remember this node
  1124.                 $self->idx($idx);
  1125.             }
  1126.         }
  1127.         else {
  1128.             # not reached
  1129.             die "internal error";
  1130.         }
  1131.     }
  1132.     $text;
  1133. }
  1134.  
  1135. # process a block of verbatim text
  1136. sub verbatim { 
  1137.     ## Nothing particular to check
  1138.     my ($self, $paragraph, $line_num, $pod_para) = @_;
  1139.  
  1140.     $self->_preproc_par($paragraph);
  1141.  
  1142.     if($self->{_current_head1} eq 'NAME') {
  1143.         my ($file, $line) = $pod_para->file_line;
  1144.         $self->poderror({ -line => $line, -file => $file,
  1145.             -severity => 'WARNING',
  1146.             -msg => 'Verbatim paragraph in NAME section' });
  1147.     }
  1148. }
  1149.  
  1150. # process a block of regular text
  1151. sub textblock { 
  1152.     my ($self, $paragraph, $line_num, $pod_para) = @_;
  1153.     my ($file, $line) = $pod_para->file_line;
  1154.  
  1155.     $self->_preproc_par($paragraph);
  1156.  
  1157.     # skip this paragraph if in a =begin block
  1158.     unless($self->{_have_begin}) {
  1159.         my $block = $self->interpolate_and_check($paragraph, $line,$file);
  1160.         if($self->{_current_head1} eq 'NAME') {
  1161.             if($block =~ /^\s*(\S+?)\s*[,-]/) {
  1162.                 # this is the canonical name
  1163.                 $self->{-name} = $1 unless(defined $self->{-name});
  1164.             }
  1165.         }
  1166.     }
  1167. }
  1168.  
  1169. sub _preproc_par
  1170. {
  1171.     my $self = shift;
  1172.     $_[0] =~ s/[\s\n]+$//;
  1173.     if($_[0]) {
  1174.         $self->{_commands_in_head}++;
  1175.         $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});
  1176.         if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {
  1177.             $self->{_list_stack}->[0]->{_has_par} = 1;
  1178.         }
  1179.     }
  1180. }
  1181.  
  1182. 1;
  1183.  
  1184. __END__
  1185.  
  1186. =head1 AUTHOR
  1187.  
  1188. Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),
  1189. Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>
  1190.  
  1191. Based on code for B<Pod::Text::pod2text()> written by
  1192. Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
  1193.  
  1194. =cut
  1195.  
  1196.