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