From 0c50187808c90649d93897951eb5d95c20c23588 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Tue, 5 Feb 2013 22:45:57 +0000 Subject: Update Pod-Parser to CPAN version 1.60 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [DELTA] [Pod-Parser]   31-Jan-2013           Marek Rouchal                          -----------------------------------------------------------------------------   Version 1.60   + removed Pod::Checker and Pod::Usage from this distribution - they are now     separate distros and are subjects to be refactored, to be based upon     Pod::Simple. Thanks to rjbs for reminding me of this. Add Pod-Checker and Pod-Usage to cpan/ These have been split out of Pod-Parser [Pod-Checker] 27-Jan-2013           Marek Rouchal                        ----------------------------------------------------------------------------- Version 1.60 + preparation of changing this module to use Pod::Simple    refactored the Pod-Parser distribution and moved all things Pod::Checker    to this new distribution package + CPAN RT#79535: Pod::Checker synopsis for podchecker is opposite    corrected the POD synopsis + factored this distribution out of Pod-Parser-1.51 [Pod-Usage] 1.61 (marekr) - fix empty META.yml (CPAN RT#83118: META.yml is empty) - update outdated test expected data (CPAN RT#83111: fails test)   1.60 (marekr) - moved POD behind __END__ for slighlty quicker loading - CPAN RT#81387: 2 suggestions for module Pod::Usage    added example of how to use FindBin to locate the script;    added $Pod::Usage::Formatter to allow a different base class - CPAN RT#75598: [PATCH] Don't use perldoc if it is missing    implemented as suggested in the RT ticket - factored Pod::Usageout of the Pod-Parser distribution into a separate one,    in order to prepare the rewrite based upon Pod::Simple - thanks to rjbs for driving this --- cpan/Pod-Checker/.gitignore | 1 + cpan/Pod-Checker/lib/Pod/Checker.pm | 1330 ++++++++ cpan/Pod-Checker/scripts/podchecker.PL | 186 ++ cpan/Pod-Checker/t/pod/contains_bad_pod.xr | 5 + cpan/Pod-Checker/t/pod/empty.xr | 0 cpan/Pod-Checker/t/pod/podchkenc.t | 29 + cpan/Pod-Checker/t/pod/podchkenc.xr | 1 + cpan/Pod-Checker/t/pod/poderrs.t | 241 ++ cpan/Pod-Checker/t/pod/poderrs.xr | 53 + cpan/Pod-Checker/t/pod/selfcheck.t | 45 + cpan/Pod-Checker/t/pod/testcmp.pl | 94 + cpan/Pod-Checker/t/pod/testpchk.pl | 130 + cpan/Pod-Parser/.gitignore | 2 - cpan/Pod-Parser/lib/Pod/Checker.pm | 1329 -------- cpan/Pod-Parser/lib/Pod/Find.pm | 1098 +++---- cpan/Pod-Parser/lib/Pod/InputObjects.pm | 1884 ++++++------ cpan/Pod-Parser/lib/Pod/ParseUtils.pm | 1714 +++++------ cpan/Pod-Parser/lib/Pod/Parser.pm | 3668 ++++++++++++----------- cpan/Pod-Parser/lib/Pod/PlainText.pm | 1484 ++++----- cpan/Pod-Parser/lib/Pod/Select.pm | 1496 ++++----- cpan/Pod-Parser/lib/Pod/Usage.pm | 747 ----- cpan/Pod-Parser/scripts/pod2usage.PL | 180 -- cpan/Pod-Parser/scripts/podchecker.PL | 186 -- cpan/Pod-Parser/scripts/podselect.PL | 286 +- cpan/Pod-Parser/t/pod/contains_bad_pod.xr | 10 +- cpan/Pod-Parser/t/pod/contains_pod.t | 38 +- cpan/Pod-Parser/t/pod/contains_pod.xr | 10 +- cpan/Pod-Parser/t/pod/emptycmd.t | 42 +- cpan/Pod-Parser/t/pod/emptycmd.xr | 4 +- cpan/Pod-Parser/t/pod/find.t | 204 +- cpan/Pod-Parser/t/pod/for.t | 118 +- cpan/Pod-Parser/t/pod/for.xr | 42 +- cpan/Pod-Parser/t/pod/headings.t | 280 +- cpan/Pod-Parser/t/pod/headings.xr | 52 +- cpan/Pod-Parser/t/pod/include.t | 72 +- cpan/Pod-Parser/t/pod/include.xr | 44 +- cpan/Pod-Parser/t/pod/included.t | 70 +- cpan/Pod-Parser/t/pod/included.xr | 6 +- cpan/Pod-Parser/t/pod/lref.t | 132 +- cpan/Pod-Parser/t/pod/lref.xr | 80 +- cpan/Pod-Parser/t/pod/multiline_items.t | 62 +- cpan/Pod-Parser/t/pod/multiline_items.xr | 12 +- cpan/Pod-Parser/t/pod/nested_items.t | 128 +- cpan/Pod-Parser/t/pod/nested_items.xr | 38 +- cpan/Pod-Parser/t/pod/nested_seqs.t | 46 +- cpan/Pod-Parser/t/pod/nested_seqs.xr | 6 +- cpan/Pod-Parser/t/pod/oneline_cmds.t | 92 +- cpan/Pod-Parser/t/pod/oneline_cmds.xr | 52 +- cpan/Pod-Parser/t/pod/p2u_data.pl | 18 - cpan/Pod-Parser/t/pod/pod2usage.t | 18 - cpan/Pod-Parser/t/pod/pod2usage.xr | 57 - cpan/Pod-Parser/t/pod/pod2usage2.t | 357 --- cpan/Pod-Parser/t/pod/podchkenc.t | 29 - cpan/Pod-Parser/t/pod/podchkenc.xr | 1 - cpan/Pod-Parser/t/pod/poderrs.t | 241 -- cpan/Pod-Parser/t/pod/poderrs.xr | 53 - cpan/Pod-Parser/t/pod/podselect.t | 36 +- cpan/Pod-Parser/t/pod/podselect.xr | 88 +- cpan/Pod-Parser/t/pod/selfcheck.t | 98 +- cpan/Pod-Parser/t/pod/special_seqs.t | 92 +- cpan/Pod-Parser/t/pod/special_seqs.xr | 50 +- cpan/Pod-Parser/t/pod/testcmp.pl | 188 +- cpan/Pod-Parser/t/pod/testp2pt.pl | 384 +-- cpan/Pod-Parser/t/pod/testpchk.pl | 260 +- cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm | 40 +- cpan/Pod-Parser/t/pod/twice.t | 72 +- cpan/Pod-Parser/t/pod/usage.pod | 18 - cpan/Pod-Parser/t/pod/usage2.pod | 56 - cpan/Pod-Usage/.gitignore | 1 + cpan/Pod-Usage/lib/Pod/Usage.pm | 767 +++++ cpan/Pod-Usage/scripts/pod2usage.PL | 190 ++ cpan/Pod-Usage/t/pod/p2u_data.pl | 18 + cpan/Pod-Usage/t/pod/pod2usage.t | 18 + cpan/Pod-Usage/t/pod/pod2usage.xr | 63 + cpan/Pod-Usage/t/pod/pod2usage2.t | 357 +++ cpan/Pod-Usage/t/pod/testcmp.pl | 94 + cpan/Pod-Usage/t/pod/testp2pt.pl | 192 ++ cpan/Pod-Usage/t/pod/usage.pod | 18 + cpan/Pod-Usage/t/pod/usage2.pod | 56 + 79 files changed, 11185 insertions(+), 10574 deletions(-) create mode 100644 cpan/Pod-Checker/.gitignore create mode 100644 cpan/Pod-Checker/lib/Pod/Checker.pm create mode 100644 cpan/Pod-Checker/scripts/podchecker.PL create mode 100644 cpan/Pod-Checker/t/pod/contains_bad_pod.xr create mode 100644 cpan/Pod-Checker/t/pod/empty.xr create mode 100644 cpan/Pod-Checker/t/pod/podchkenc.t create mode 100644 cpan/Pod-Checker/t/pod/podchkenc.xr create mode 100644 cpan/Pod-Checker/t/pod/poderrs.t create mode 100644 cpan/Pod-Checker/t/pod/poderrs.xr create mode 100644 cpan/Pod-Checker/t/pod/selfcheck.t create mode 100644 cpan/Pod-Checker/t/pod/testcmp.pl create mode 100644 cpan/Pod-Checker/t/pod/testpchk.pl delete mode 100644 cpan/Pod-Parser/lib/Pod/Checker.pm delete mode 100644 cpan/Pod-Parser/lib/Pod/Usage.pm delete mode 100644 cpan/Pod-Parser/scripts/pod2usage.PL delete mode 100644 cpan/Pod-Parser/scripts/podchecker.PL delete mode 100644 cpan/Pod-Parser/t/pod/p2u_data.pl delete mode 100644 cpan/Pod-Parser/t/pod/pod2usage.t delete mode 100644 cpan/Pod-Parser/t/pod/pod2usage.xr delete mode 100644 cpan/Pod-Parser/t/pod/pod2usage2.t delete mode 100644 cpan/Pod-Parser/t/pod/podchkenc.t delete mode 100644 cpan/Pod-Parser/t/pod/podchkenc.xr delete mode 100644 cpan/Pod-Parser/t/pod/poderrs.t delete mode 100644 cpan/Pod-Parser/t/pod/poderrs.xr delete mode 100644 cpan/Pod-Parser/t/pod/usage.pod delete mode 100644 cpan/Pod-Parser/t/pod/usage2.pod create mode 100644 cpan/Pod-Usage/.gitignore create mode 100644 cpan/Pod-Usage/lib/Pod/Usage.pm create mode 100644 cpan/Pod-Usage/scripts/pod2usage.PL create mode 100644 cpan/Pod-Usage/t/pod/p2u_data.pl create mode 100644 cpan/Pod-Usage/t/pod/pod2usage.t create mode 100644 cpan/Pod-Usage/t/pod/pod2usage.xr create mode 100644 cpan/Pod-Usage/t/pod/pod2usage2.t create mode 100644 cpan/Pod-Usage/t/pod/testcmp.pl create mode 100644 cpan/Pod-Usage/t/pod/testp2pt.pl create mode 100644 cpan/Pod-Usage/t/pod/usage.pod create mode 100644 cpan/Pod-Usage/t/pod/usage2.pod (limited to 'cpan') diff --git a/cpan/Pod-Checker/.gitignore b/cpan/Pod-Checker/.gitignore new file mode 100644 index 0000000000..48f56f3a35 --- /dev/null +++ b/cpan/Pod-Checker/.gitignore @@ -0,0 +1 @@ +/podchecker* diff --git a/cpan/Pod-Checker/lib/Pod/Checker.pm b/cpan/Pod-Checker/lib/Pod/Checker.pm new file mode 100644 index 0000000000..ba47e6fa71 --- /dev/null +++ b/cpan/Pod-Checker/lib/Pod/Checker.pm @@ -0,0 +1,1330 @@ +############################################################################# +# Pod/Checker.pm -- check pod documents for syntax errors +# +# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Checker; +use strict; + +use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES); +$VERSION = '1.60'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +use Pod::ParseUtils; ## for hyperlinks and lists + +=head1 NAME + +Pod::Checker, podchecker() - check pod documents for syntax errors + +=head1 SYNOPSIS + + use Pod::Checker; + + $num_errors = podchecker($filepath, $outputpath, %options); + + my $checker = new Pod::Checker %options; + $checker->parse_from_file($filepath, \*STDERR); + +=head1 OPTIONS/ARGUMENTS + +C<$filepath> is the input POD to read and C<$outputpath> is +where to write POD syntax error messages. Either argument may be a scalar +indicating a file-path, or else a reference to an open filehandle. +If unspecified, the input-file it defaults to C<\*STDIN>, and +the output-file defaults to C<\*STDERR>. + +=head2 podchecker() + +This function can take a hash of options: + +=over 4 + +=item B<-warnings> =E I + +Turn warnings on/off. I is usually 1 for on, but higher values +trigger additional warnings. See L<"Warnings">. + +=back + +=head1 DESCRIPTION + +B will perform syntax checking of Perl5 POD format documentation. + +Curious/ambitious users are welcome to propose additional features they wish +to see in B and B and verify that the checks are +consistent with L. + +The following checks are currently performed: + +=over 4 + +=item * + +Unknown '=xxxx' commands, unknown 'XE...E' interior-sequences, +and unterminated interior sequences. + +=item * + +Check for proper balancing of C<=begin> and C<=end>. The contents of such +a block are generally ignored, i.e. no syntax checks are performed. + +=item * + +Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. + +=item * + +Check for same nested interior-sequences (e.g. +C...LE...E...E>). + +=item * + +Check for malformed or non-existing entities C...E>. + +=item * + +Check for correct syntax of hyperlinks C...E>. See L +for details. + +=item * + +Check for unresolved document-internal links. This check may also reveal +misspelled links that seem to be internal links but should be links +to something else. + +=back + +=head1 DIAGNOSTICS + +=head2 Errors + +=over 4 + +=item * empty =headn + +A heading (C<=head1> or C<=head2>) without any text? That ain't no +heading! + +=item * =over on line I without closing =back + +The C<=over> command does not have a corresponding C<=back> before the +next heading (C<=head1> or C<=head2>) or the end of the file. + +=item * =item without previous =over + +=item * =back without previous =over + +An C<=item> or C<=back> command has been found outside a +C<=over>/C<=back> block. + +=item * No argument for =begin + +A C<=begin> command was found that is not followed by the formatter +specification. + +=item * =end without =begin + +A standalone C<=end> command was found. + +=item * Nested =begin's + +There were at least two consecutive C<=begin> commands without +the corresponding C<=end>. Only one C<=begin> may be active at +a time. + +=item * =for without formatter specification + +There is no specification of the formatter after the C<=for> command. + +=item * Apparent command =foo not preceded by blank line + +A command which has ended up in the middle of a paragraph or other command, +such as + + =item one + =item two <-- bad + +=item * unresolved internal link I + +The given link to I does not have a matching node in the current +POD. This also happened when a single word node name is not enclosed in +C<"">. + +=item * Unknown command "I" + +An invalid POD command has been found. Valid are C<=head1>, C<=head2>, +C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, +C<=for>, C<=pod>, C<=cut> + +=item * Unknown interior-sequence "I" + +An invalid markup command has been encountered. Valid are: +CE>, CE>, CE>, CE>, +CE>, CE>, CE>, CE>, +CE> + +=item * nested commands IE...IE...E...E + +Two nested identical markup commands have been found. Generally this +does not make sense. + +=item * garbled entity I + +The I found cannot be interpreted as a character entity. + +=item * Entity number out of range + +An entity specified by number (dec, hex, oct) is out of range (1-255). + +=item * malformed link LEE + +The link found cannot be parsed because it does not conform to the +syntax described in L. + +=item * nonempty ZEE + +The CE> sequence is supposed to be empty. + +=item * empty XEE + +The index entry specified contains nothing but whitespace. + +=item * Spurious text after =pod / =cut + +The commands C<=pod> and C<=cut> do not take any arguments. + +=item * Spurious =cut command + +A C<=cut> command was found without a preceding POD paragraph. + +=item * Spurious =pod command + +A C<=pod> command was found after a preceding POD paragraph. + +=item * Spurious character(s) after =back + +The C<=back> command does not take any arguments. + +=back + +=head2 Warnings + +These may not necessarily cause trouble, but indicate mediocre style. + +=over 4 + +=item * multiple occurrence of link target I + +The POD file has some C<=item> and/or C<=head> commands that have +the same text. Potential hyperlinks to such a text cannot be unique then. +This warning is printed only with warning level greater than one. + +=item * line containing nothing but whitespace in paragraph + +There is some whitespace on a seemingly empty line. POD is very sensitive +to such things, so this is flagged. B users switch on the B +option to avoid this problem. + +=begin _disabled_ + +=item * file does not start with =head + +The file starts with a different POD directive than head. +This is most probably something you do not want. + +=end _disabled_ + +=item * previous =item has no contents + +There is a list C<=item> right above the flagged line that has no +text contents. You probably want to delete empty items. + +=item * preceding non-item paragraph(s) + +A list introduced by C<=over> starts with a text or verbatim paragraph, +but continues with C<=item>s. Move the non-item paragraph out of the +C<=over>/C<=back> block. + +=item * =item type mismatch (I vs. I) + +A list started with e.g. a bullet-like C<=item> and continued with a +numbered one. This is obviously inconsistent. For most translators the +type of the I C<=item> determines the type of the list. + +=item * I unescaped CE> in paragraph + +Angle brackets not written as CltE> and CgtE> +can potentially cause errors as they could be misinterpreted as +markup commands. This is only printed when the -warnings level is +greater than 1. + +=item * Unknown entity + +A character entity was found that does not belong to the standard +ISO set or the POD specials C and C. + +=item * No items in =over + +The list opened with C<=over> does not contain any items. + +=item * No argument for =item + +C<=item> without any parameters is deprecated. It should either be followed +by C<*> to indicate an unordered list, by a number (optionally followed +by a dot) to indicate an ordered (numbered) list or simple text for a +definition list. + +=item * empty section in previous paragraph + +The previous section (introduced by a C<=head> command) does not contain +any text. This usually indicates that something is missing. Note: A +C<=head1> followed immediately by C<=head2> does not trigger this warning. + +=item * Verbatim paragraph in NAME section + +The NAME section (C<=head1 NAME>) should consist of a single paragraph +with the script/module name, followed by a dash `-' and a very short +description of what the thing is good for. + +=item * =headI without preceding higher level + +For example if there is a C<=head2> in the POD file prior to a +C<=head1>. + +=back + +=head2 Hyperlinks + +There are some warnings with respect to malformed hyperlinks: + +=over 4 + +=item * ignoring leading/trailing whitespace in link + +There is whitespace at the beginning or the end of the contents of +LE...E. + +=item * (section) in '$page' deprecated + +There is a section detected in the page name of LE...E, e.g. +Cpasswd(2)E>. POD hyperlinks may point to POD documents only. +Please write Cpasswd(2)E> instead. Some formatters are able +to expand this to appropriate code. For links to (builtin) functions, +please say Cperlfunc/mkdirE>, without (). + +=item * alternative text/node '%s' contains non-escaped | or / + +The characters C<|> and C are special in the LE...E context. +Although the hyperlink parser does its best to determine which "/" is +text and which is a delimiter in case of doubt, one ought to escape +these literal characters like this: + + / E + | E + +=back + +=head1 RETURN VALUE + +B returns the number of POD syntax errors found or -1 if +there were no POD commands at all found in the file. + +=head1 EXAMPLES + +See L + +=head1 INTERFACE + +While checking, this module collects document properties, e.g. the nodes +for hyperlinks (C<=headX>, C<=item>) and index entries (CE>). +POD translators can use this feature to syntax-check and get the nodes in +a first pass before actually starting to convert. This is expensive in terms +of execution time, but allows for very robust conversions. + +Since PodParser-1.24 the B module uses only the B +method to print errors and warnings. The summary output (e.g. +"Pod syntax OK") has been dropped from the module and has been included in +B (the script). This allows users of B to +control completely the output behavior. Users of B (the script) +get the well-known behavior. + +=cut + +############################################################################# + +#use diagnostics; +use Carp qw(croak); +use Exporter; +use Pod::Parser; + +@ISA = qw(Pod::Parser); +@EXPORT = qw(&podchecker); + +my %VALID_COMMANDS = ( + 'pod' => 1, + 'cut' => 1, + 'head1' => 1, + 'head2' => 1, + 'head3' => 1, + 'head4' => 1, + 'over' => 1, + 'back' => 1, + 'item' => 1, + 'for' => 1, + 'begin' => 1, + 'end' => 1, + 'encoding' => 1, +); + +my %VALID_SEQUENCES = ( + 'I' => 1, + 'B' => 1, + 'S' => 1, + 'C' => 1, + 'L' => 1, + 'F' => 1, + 'X' => 1, + 'Z' => 1, + 'E' => 1, +); + +# stolen from HTML::Entities +my %ENTITIES = ( + # Some normal chars that have special meaning in SGML context + amp => '&', # ampersand +'gt' => '>', # greater than +'lt' => '<', # less than + quot => '"', # double quote + + # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML + AElig => 'Æ', # capital AE diphthong (ligature) + Aacute => 'Á', # capital A, acute accent + Acirc => 'Â', # capital A, circumflex accent + Agrave => 'À', # capital A, grave accent + Aring => 'Å', # capital A, ring + Atilde => 'Ã', # capital A, tilde + Auml => 'Ä', # capital A, dieresis or umlaut mark + Ccedil => 'Ç', # capital C, cedilla + ETH => 'Ð', # capital Eth, Icelandic + Eacute => 'É', # capital E, acute accent + Ecirc => 'Ê', # capital E, circumflex accent + Egrave => 'È', # capital E, grave accent + Euml => 'Ë', # capital E, dieresis or umlaut mark + Iacute => 'Í', # capital I, acute accent + Icirc => 'Î', # capital I, circumflex accent + Igrave => 'Ì', # capital I, grave accent + Iuml => 'Ï', # capital I, dieresis or umlaut mark + Ntilde => 'Ñ', # capital N, tilde + Oacute => 'Ó', # capital O, acute accent + Ocirc => 'Ô', # capital O, circumflex accent + Ograve => 'Ò', # capital O, grave accent + Oslash => 'Ø', # capital O, slash + Otilde => 'Õ', # capital O, tilde + Ouml => 'Ö', # capital O, dieresis or umlaut mark + THORN => 'Þ', # capital THORN, Icelandic + Uacute => 'Ú', # capital U, acute accent + Ucirc => 'Û', # capital U, circumflex accent + Ugrave => 'Ù', # capital U, grave accent + Uuml => 'Ü', # capital U, dieresis or umlaut mark + Yacute => 'Ý', # capital Y, acute accent + aacute => 'á', # small a, acute accent + acirc => 'â', # small a, circumflex accent + aelig => 'æ', # small ae diphthong (ligature) + agrave => 'à', # small a, grave accent + aring => 'å', # small a, ring + atilde => 'ã', # small a, tilde + auml => 'ä', # small a, dieresis or umlaut mark + ccedil => 'ç', # small c, cedilla + eacute => 'é', # small e, acute accent + ecirc => 'ê', # small e, circumflex accent + egrave => 'è', # small e, grave accent + eth => 'ð', # small eth, Icelandic + euml => 'ë', # small e, dieresis or umlaut mark + iacute => 'í', # small i, acute accent + icirc => 'î', # small i, circumflex accent + igrave => 'ì', # small i, grave accent + iuml => 'ï', # small i, dieresis or umlaut mark + ntilde => 'ñ', # small n, tilde + oacute => 'ó', # small o, acute accent + ocirc => 'ô', # small o, circumflex accent + ograve => 'ò', # small o, grave accent + oslash => 'ø', # small o, slash + otilde => 'õ', # small o, tilde + ouml => 'ö', # small o, dieresis or umlaut mark + szlig => 'ß', # small sharp s, German (sz ligature) + thorn => 'þ', # small thorn, Icelandic + uacute => 'ú', # small u, acute accent + ucirc => 'û', # small u, circumflex accent + ugrave => 'ù', # small u, grave accent + uuml => 'ü', # small u, dieresis or umlaut mark + yacute => 'ý', # small y, acute accent + yuml => 'ÿ', # small y, dieresis or umlaut mark + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => '©', # copyright sign + reg => '®', # registered sign + nbsp => "\240", # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => '¡', + cent => '¢', + pound => '£', + curren => '¤', + yen => '¥', + brvbar => '¦', + sect => '§', + uml => '¨', + ordf => 'ª', + laquo => '«', +'not' => '¬', # not is a keyword in perl + shy => '­', + macr => '¯', + deg => '°', + plusmn => '±', + sup1 => '¹', + sup2 => '²', + sup3 => '³', + acute => '´', + micro => 'µ', + para => '¶', + middot => '·', + cedil => '¸', + ordm => 'º', + raquo => '»', + frac14 => '¼', + frac12 => '½', + frac34 => '¾', + iquest => '¿', +'times' => '×', # times is a keyword in perl + divide => '÷', + +# some POD special entities + verbar => '|', + sol => '/' +); + +##--------------------------------------------------------------------------- + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub podchecker { + my ($infile, $outfile, %options) = @_; + local $_; + + ## Set defaults + $infile ||= \*STDIN; + $outfile ||= \*STDERR; + + ## Now create a pod checker + my $checker = new Pod::Checker(%options); + + ## Now check the pod document for errors + $checker->parse_from_file($infile, $outfile); + + ## Return the number of errors found + return $checker->num_errors(); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +################################## + +=over 4 + +=item Cnew( %options )> + +Return a reference to a new Pod::Checker object that inherits from +Pod::Parser and is used for calling the required methods later. The +following options are recognized: + +C<-warnings =E num> + Print warnings if C is true. The higher the value of C, +the more warnings are printed. Currently there are only levels 1 and 2. + +C<-quiet =E num> + If C is true, do not print any errors/warnings. This is useful +when Pod::Checker is used to munge POD code into plain text from within +POD formatters. + +=cut + +## sub new { +## my $this = shift; +## my $class = ref($this) || $this; +## my %params = @_; +## my $self = {%params}; +## bless $self, $class; +## $self->initialize(); +## return $self; +## } + +sub initialize { + my $self = shift; + ## Initialize number of errors, and setup an error function to + ## increment this number and then print to the designated output. + $self->{_NUM_ERRORS} = 0; + $self->{_NUM_WARNINGS} = 0; + $self->{-quiet} ||= 0; + # set the error handling subroutine + $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror'); + $self->{_commands} = 0; # total number of POD commands encountered + $self->{_list_stack} = []; # stack for nested lists + $self->{_have_begin} = ''; # stores =begin + $self->{_links} = []; # stack for internal hyperlinks + $self->{_nodes} = []; # stack for =head/=item nodes + $self->{_index} = []; # text in X<> + # print warnings? + $self->{-warnings} = 1 unless(defined $self->{-warnings}); + $self->{_current_head1} = ''; # the current =head1 block + $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings}); +} + +################################## + +=item C<$checker-Epoderror( @args )> + +=item C<$checker-Epoderror( {%opts}, @args )> + +Internal method for printing errors and warnings. If no options are +given, simply prints "@_". The following options are recognized and used +to form the output: + + -msg + +A message to print prior to C<@args>. + + -line + +The line number the error occurred in. + + -file + +The file (name) the error occurred in. + + -severity + +The error level, should be 'WARNING' or 'ERROR'. + +=cut + +# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) +sub poderror { + my $self = shift; + my %opts = (ref $_[0]) ? %{shift()} : (); + + ## Retrieve options + chomp( my $msg = ($opts{-msg} || '')."@_" ); + my $line = (exists $opts{-line}) ? " at line $opts{-line}" : ''; + my $file = (exists $opts{-file}) ? " in file $opts{-file}" : ''; + unless (exists $opts{-severity}) { + ## See if can find severity in message prefix + $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// ); + } + my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : ''; + + ## Increment error count and print message " + ++($self->{_NUM_ERRORS}) + if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); + ++($self->{_NUM_WARNINGS}) + if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING')); + unless($self->{-quiet}) { + my $out_fh = $self->output_handle() || \*STDERR; + print $out_fh ($severity, $msg, $line, $file, "\n") + if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); + } +} + +################################## + +=item C<$checker-Enum_errors()> + +Set (if argument specified) and retrieve the number of errors found. + +=cut + +sub num_errors { + return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; +} + +################################## + +=item C<$checker-Enum_warnings()> + +Set (if argument specified) and retrieve the number of warnings found. + +=cut + +sub num_warnings { + return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS}; +} + +################################## + +=item C<$checker-Ename()> + +Set (if argument specified) and retrieve the canonical name of POD as +found in the C<=head1 NAME> section. + +=cut + +sub name { + return (@_ > 1 && $_[1]) ? + ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; +} + +################################## + +=item C<$checker-Enode()> + +Add (if argument specified) and retrieve the nodes (as defined by C<=headX> +and C<=item>) of the current POD. The nodes are returned in the order of +their occurrence. They consist of plain text, each piece of whitespace is +collapsed to a single blank. + +=cut + +sub node { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_nodes}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_nodes}}; +} + +################################## + +=item C<$checker-Eidx()> + +Add (if argument specified) and retrieve the index entries (as defined by +CE>) of the current POD. They consist of plain text, each piece +of whitespace is collapsed to a single blank. + +=cut + +# set/return index entries of current POD +sub idx { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_index}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_index}}; +} + +################################## + +=item C<$checker-Ehyperlink()> + +Add (if argument specified) and retrieve the hyperlinks (as defined by +CE>) of the current POD. They consist of a 2-item array: line +number and C object. + +=back + +=cut + +# set/return hyperlinks of the current POD +sub hyperlink { + my $self = shift; + if($_[0]) { + push(@{$self->{_links}}, $_[0]); + return $_[0]; + } + @{$self->{_links}}; +} + +## overrides for Pod::Parser + +sub end_pod { + ## Do some final checks and + ## print the number of errors found + my $self = shift; + my $infile = $self->input_file(); + + if(@{$self->{_list_stack}}) { + my $list; + while(($list = $self->_close_list('EOF',$infile)) && + $list->indent() ne 'auto') { + $self->poderror({ -line => 'EOF', -file => $infile, + -severity => 'ERROR', -msg => '=over on line ' . + $list->start() . ' without closing =back' }); + } + } + + # check validity of document internal hyperlinks + # first build the node names from the paragraph text + my %nodes; + foreach($self->node()) { + $nodes{$_} = 1; + if(/^(\S+)\s+\S/) { + # we have more than one word. Use the first as a node, too. + # This is used heavily in perlfunc.pod + $nodes{$1} ||= 2; # derived node + } + } + foreach($self->idx()) { + $nodes{$_} = 3; # index node + } + foreach($self->hyperlink()) { + my ($line,$link) = @$_; + # _TODO_ what if there is a link to the page itself by the name, + # e.g. in Tk::Pod : L + if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { + my $node = $self->_check_ptree($self->parse_text($link->node(), + $line), $line, $infile, 'L'); + if($node && !$nodes{$node}) { + $self->poderror({ -line => $line || '', -file => $infile, + -severity => 'ERROR', + -msg => "unresolved internal link '$node'"}); + } + } + } + + # check the internal nodes for uniqueness. This pertains to + # =headX, =item and X<...> + if($self->{-warnings} && $self->{-warnings}>1) { + foreach(grep($self->{_unique_nodes}->{$_} > 1, + keys %{$self->{_unique_nodes}})) { + $self->poderror({ -line => '-', -file => $infile, + -severity => 'WARNING', + -msg => "multiple occurrence of link target '$_'"}); + } + } + + # no POD found here + $self->num_errors(-1) if($self->{_commands} == 0); +} + +# check a POD command directive +sub command { + my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; + my ($file, $line) = $pod_para->file_line; + ## Check the command syntax + my $arg; # this will hold the command argument + if (! $VALID_COMMANDS{$cmd}) { + $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', + -msg => "Unknown command '$cmd'" }); + } + else { # found a valid command + $self->{_commands}++; # delete this line if below is enabled again + + $self->_commands_in_paragraphs($paragraph, $pod_para); + + ##### following check disabled due to strong request + #if(!$self->{_commands}++ && $cmd !~ /^head/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "file does not start with =head" }); + #} + + # check syntax of particular command + if($cmd eq 'over') { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + my $indent = 4; # default + if($arg && $arg =~ /^\s*(\d+)\s*$/) { + $indent = $1; + } + # start a new list + $self->_open_list($indent,$line,$file); + } + elsif($cmd eq 'item') { + # are we in a list? + unless(@{$self->{_list_stack}}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => '=item without previous =over' }); + # auto-open in case we encounter many more + $self->_open_list('auto',$line,$file); + } + my $list = $self->{_list_stack}->[0]; + # check whether the previous item had some contents + if(defined $self->{_list_item_contents} && + $self->{_list_item_contents} == 0) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'previous =item has no contents' }); + } + if($list->{_has_par}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'preceding non-item paragraph(s)' }); + delete $list->{_has_par}; + } + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line, $file); + if($arg && $arg =~ /(\S+)/) { + $arg =~ s/[\s\n]+$//; + my $type; + if($arg =~ /^[*]\s*(\S*.*)/) { + $type = 'bullet'; + $self->{_list_item_contents} = $1 ? 1 : 0; + $arg = $1; + } + elsif($arg =~ /^\d+\.?\s+(\S*)/) { + $type = 'number'; + $self->{_list_item_contents} = $1 ? 1 : 0; + $arg = $1; + } + else { + $type = 'definition'; + $self->{_list_item_contents} = 1; + } + my $first = $list->type(); + if($first && $first ne $type) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "=item type mismatch ('$first' vs. '$type')"}); + } + else { # first item + $list->type($type); + } + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'No argument for =item' }); + $arg = ' '; # empty + $self->{_list_item_contents} = 0; + } + # add this item + $list->item($arg); + # remember this node + $self->node($arg); + } + elsif($cmd eq 'back') { + # check if we have an open list + unless(@{$self->{_list_stack}}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => '=back without previous =over' }); + } + else { + # check for spurious characters + $arg = $self->interpolate_and_check($paragraph, $line,$file); + if($arg && $arg =~ /\S/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'Spurious character(s) after =back' }); + } + # close list + my $list = $self->_close_list($line,$file); + # check for empty lists + if(!$list->item() && $self->{-warnings}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'No items in =over (at line ' . + $list->start() . ') / =back list'}); + } + } + } + elsif($cmd =~ /^head(\d+)/) { + my $hnum = $1; + $self->{"_have_head_$hnum"}++; # count head types + if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "=head$hnum without preceding higher level"}); + } + # check whether the previous =head section had some contents + if(defined $self->{_commands_in_head} && + $self->{_commands_in_head} == 0 && + defined $self->{_last_head} && + $self->{_last_head} >= $hnum) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'empty section in previous paragraph'}); + } + $self->{_commands_in_head} = -1; + $self->{_last_head} = $hnum; + # check if there is an open list + if(@{$self->{_list_stack}}) { + my $list; + while(($list = $self->_close_list($line,$file)) && + $list->indent() ne 'auto') { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => '=over on line '. $list->start() . + " without closing =back (at $cmd)" }); + } + } + # remember this node + $arg = $self->interpolate_and_check($paragraph, $line,$file); + $arg =~ s/[\s\n]+$//s; + $self->node($arg); + unless(length($arg)) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "empty =$cmd"}); + } + if($cmd eq 'head1') { + $self->{_current_head1} = $arg; + } else { + $self->{_current_head1} = ''; + } + } + elsif($cmd eq 'begin') { + if($self->{_have_begin}) { + # already have a begin + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => q{Nested =begin's (first at line } . + $self->{_have_begin} . ')'}); + } + else { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + unless($arg && $arg =~ /(\S+)/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'No argument for =begin'}); + } + # remember the =begin + $self->{_have_begin} = "$line:$1"; + } + } + elsif($cmd eq 'end') { + if($self->{_have_begin}) { + # close the existing =begin + $self->{_have_begin} = ''; + # check for spurious characters + $arg = $self->interpolate_and_check($paragraph, $line,$file); + # the closing argument is optional + #if($arg && $arg =~ /\S/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "Spurious character(s) after =end" }); + #} + } + else { + # don't have a matching =begin + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => '=end without =begin' }); + } + } + elsif($cmd eq 'for') { + unless($paragraph =~ /\s*(\S+)\s*/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => '=for without formatter specification' }); + } + $arg = ''; # do not expand paragraph below + } + elsif($cmd =~ /^(pod|cut)$/) { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + if($arg && $arg =~ /(\S+)/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Spurious text after =$cmd"}); + } + if($cmd eq 'cut' && (!$self->{_PREVIOUS} || $self->{_PREVIOUS} eq 'cut')) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Spurious =cut command"}); + } + if($cmd eq 'pod' && $self->{_PREVIOUS} && $self->{_PREVIOUS} ne 'cut') { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Spurious =pod command"}); + } + } + $self->{_commands_in_head}++; + ## Check the interior sequences in the command-text + $self->interpolate_and_check($paragraph, $line,$file) + unless(defined $arg); + } +} + +sub _open_list +{ + my ($self,$indent,$line,$file) = @_; + my $list = Pod::List->new( + -indent => $indent, + -start => $line, + -file => $file); + unshift(@{$self->{_list_stack}}, $list); + undef $self->{_list_item_contents}; + $list; +} + +sub _close_list +{ + my ($self,$line,$file) = @_; + my $list = shift(@{$self->{_list_stack}}); + if(defined $self->{_list_item_contents} && + $self->{_list_item_contents} == 0) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'previous =item has no contents' }); + } + undef $self->{_list_item_contents}; + $list; +} + +# process a block of some text +sub interpolate_and_check { + my ($self, $paragraph, $line, $file) = @_; + ## Check the interior sequences in the command-text + # and return the text + $self->_check_ptree( + $self->parse_text($paragraph,$line), $line, $file, ''); +} + +sub _check_ptree { + my ($self,$ptree,$line,$file,$nestlist) = @_; + local($_); + my $text = ''; + # process each node in the parse tree + foreach(@$ptree) { + # regular text chunk + unless(ref) { + # count the unescaped angle brackets + # complain only when warning level is greater than 1 + if($self->{-warnings} && $self->{-warnings}>1) { + my $count; + if($count = tr/<>/<>/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "$count unescaped <> in paragraph" }); + } + } + $text .= $_; + next; + } + # have an interior sequence + my $cmd = $_->cmd_name(); + my $contents = $_->parse_tree(); + ($file,$line) = $_->file_line(); + # check for valid tag + if (! $VALID_SEQUENCES{$cmd}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => qq(Unknown interior-sequence '$cmd')}); + # expand it anyway + $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + next; + } + if(index($nestlist, $cmd) != -1) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "nested commands $cmd<...$cmd<...>...>"}); + # _TODO_ should we add the contents anyway? + # expand it anyway, see below + } + if($cmd eq 'E') { + # preserve entities + if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'garbled entity ' . $_->raw_text()}); + next; + } + my $ent = $$contents[0]; + my $val; + if($ent =~ /^0x[0-9a-f]+$/i) { + # hexadec entity + $val = hex($ent); + } + elsif($ent =~ /^0\d+$/) { + # octal + $val = oct($ent); + } + elsif($ent =~ /^\d+$/) { + # numeric entity + $val = $ent; + } + if(defined $val) { + if($val>0 && $val<256) { + $text .= chr($val); + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'Entity number out of range ' . $_->raw_text()}); + } + } + elsif($ENTITIES{$ent}) { + # known ISO entity + $text .= $ENTITIES{$ent}; + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'Unknown entity ' . $_->raw_text()}); + $text .= "E<$ent>"; + } + } + elsif($cmd eq 'L') { + # try to parse the hyperlink + my $link = Pod::Hyperlink->new($contents->raw_text()); + unless(defined $link) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'malformed link ' . $_->raw_text() ." : $@"}); + next; + } + $link->line($line); # remember line + if($self->{-warnings}) { + foreach my $w ($link->warning()) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => $w }); + } + } + # check the link text + $text .= $self->_check_ptree($self->parse_text($link->text(), + $line), $line, $file, "$nestlist$cmd"); + # remember link + $self->hyperlink([$line,$link]); + } + elsif($cmd =~ /[BCFIS]/) { + # add the guts + $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + } + elsif($cmd eq 'Z') { + if(length($contents->raw_text())) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'Nonempty Z<>'}); + } + } + elsif($cmd eq 'X') { + my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + if($idx =~ /^\s*$/s) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => 'Empty X<>'}); + } + else { + # remember this node + $self->idx($idx); + } + } + else { + # not reached + croak 'internal error'; + } + } + $text; +} + +# process a block of verbatim text +sub verbatim { + ## Nothing particular to check + my ($self, $paragraph, $line_num, $pod_para) = @_; + + $self->_preproc_par($paragraph); + $self->_commands_in_paragraphs($paragraph, $pod_para); + + if($self->{_current_head1} eq 'NAME') { + my ($file, $line) = $pod_para->file_line; + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'Verbatim paragraph in NAME section' }); + } +} + +# process a block of regular text +sub textblock { + my ($self, $paragraph, $line_num, $pod_para) = @_; + my ($file, $line) = $pod_para->file_line; + + $self->_preproc_par($paragraph); + $self->_commands_in_paragraphs($paragraph, $pod_para); + + # skip this paragraph if in a =begin block + unless($self->{_have_begin}) { + my $block = $self->interpolate_and_check($paragraph, $line,$file); + if($self->{_current_head1} eq 'NAME') { + if($block =~ /^\s*(\S+?)\s*[,-]/) { + # this is the canonical name + $self->{-name} = $1 unless(defined $self->{-name}); + } + } + } +} + +sub _preproc_par +{ + my $self = shift; + $_[0] =~ s/[\s\n]+$//; + if($_[0]) { + $self->{_commands_in_head}++; + $self->{_list_item_contents}++ if(defined $self->{_list_item_contents}); + if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) { + $self->{_list_stack}->[0]->{_has_par} = 1; + } + } +} + +# look for =foo commands at the start of a line within a paragraph, as for +# instance the following which prints as "* one =item two". +# +# =item one +# =item two +# +# Examples of =foo written in docs are expected to be indented in a verbatim +# or marked up C<=foo> so won't be caught. A double-angle C<< =foo >> could +# have the =foo at the start of a line, but that should be unlikely and is +# easily enough dealt with by not putting a newline after the C<<. +# +sub _commands_in_paragraphs { + my ($self, $str, $pod_para) = @_; + while ($str =~ /[^\n]\n=([a-z][a-z0-9]+)/sg) { + my $cmd = $1; + my $pos = pos($str); + if ($VALID_COMMANDS{$cmd}) { + my ($file, $line) = $pod_para->file_line; + my $part = substr($str, 0, $pos); + $line += ($part =~ tr/\n//); # count of newlines + + $self->poderror + ({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Apparent command =$cmd not preceded by blank line"}); + } + } +} + +1; + +__END__ + +=head1 AUTHOR + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE (initial version), +Marek Rouchal Emarekr@cpan.orgE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +B is part of the Pod-Checker distribution, and is based on +L. + +=cut + diff --git a/cpan/Pod-Checker/scripts/podchecker.PL b/cpan/Pod-Checker/scripts/podchecker.PL new file mode 100644 index 0000000000..2c33e8caad --- /dev/null +++ b/cpan/Pod-Checker/scripts/podchecker.PL @@ -0,0 +1,186 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2' or $^O eq 'dos'); # "case-forgiving" +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +############################################################################# +# podchecker -- command to invoke the podchecker function in Pod::Checker +# +# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +use strict; +#use diagnostics; + +=head1 NAME + +podchecker - check the syntax of POD format documentation files + +=head1 SYNOPSIS + +B [B<-help>] [B<-man>] [B<-(no)warnings>] [IS< >...] + +=head1 OPTIONS AND ARGUMENTS + +=over 8 + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print the manual page and exit. + +=item B<-warnings> B<-nowarnings> + +Turn on/off printing of warnings. Repeating B<-warnings> increases the +warning level, i.e. more warnings are printed. Currently increasing to +level two causes flagging of unescaped "E,E" characters. + +=item I + +The pathname of a POD file to syntax-check (defaults to standard input). + +=back + +=head1 DESCRIPTION + +B will read the given input files looking for POD +syntax errors in the POD documentation and will print any errors +it find to STDERR. At the end, it will print a status message +indicating the number of errors found. + +Directories are ignored, an appropriate warning message is printed. + +B invokes the B function exported by B +Please see L for more details. + +=head1 RETURN VALUE + +B returns a 0 (zero) exit status if all specified +POD files are ok. + +=head1 ERRORS + +B returns the exit status 1 if at least one of +the given POD files has syntax errors. + +The status 2 indicates that at least one of the specified +files does not contain I POD commands. + +Status 1 overrides status 2. If you want unambiguous +results, call B with one single argument only. + +=head1 SEE ALSO + +L and L + +=head1 AUTHORS + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE, +Marek Rouchal Emarekr@cpan.orgE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +=cut + + +use Pod::Checker; +use Pod::Usage; +use Getopt::Long; + +## Define options +my %options; + +## Parse options +GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2); +pod2usage(1) if ($options{help}); +pod2usage(-verbose => 2) if ($options{man}); + +if($options{nowarnings}) { + $options{warnings} = 0; +} +elsif(!defined $options{warnings}) { + $options{warnings} = 1; # default is warnings on +} + +## Dont default to STDIN if connected to a terminal +pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); + +## Invoke podchecker() +my $status = 0; +@ARGV = qw(-) unless(@ARGV); +for my $podfile (@ARGV) { + if($podfile eq '-') { + $podfile = '<&STDIN'; + } + elsif(-d $podfile) { + warn "podchecker: Warning: Ignoring directory '$podfile'\n"; + next; + } + my $errors = + podchecker($podfile, undef, '-warnings' => $options{warnings}); + if($errors > 0) { + # errors occurred + $status = 1; + printf STDERR ("%s has %d pod syntax %s.\n", + $podfile, $errors, + ($errors == 1) ? 'error' : 'errors'); + } + elsif($errors < 0) { + # no pod found + $status = 2 unless($status); + print STDERR "$podfile does not contain any pod commands.\n"; + } + else { + print STDERR "$podfile pod syntax OK.\n"; + } +} +exit $status; + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/cpan/Pod-Checker/t/pod/contains_bad_pod.xr b/cpan/Pod-Checker/t/pod/contains_bad_pod.xr new file mode 100644 index 0000000000..c7907963d9 --- /dev/null +++ b/cpan/Pod-Checker/t/pod/contains_bad_pod.xr @@ -0,0 +1,5 @@ +=head foo + +bar baz. + +=cut diff --git a/cpan/Pod-Checker/t/pod/empty.xr b/cpan/Pod-Checker/t/pod/empty.xr new file mode 100644 index 0000000000..e69de29bb2 diff --git a/cpan/Pod-Checker/t/pod/podchkenc.t b/cpan/Pod-Checker/t/pod/podchkenc.t new file mode 100644 index 0000000000..e7a5d7a14f --- /dev/null +++ b/cpan/Pod-Checker/t/pod/podchkenc.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testpchk.pl"; + import TestPodChecker; +} + +# this tests Pod::Checker accepts =encoding directive + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodchecker \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + +__END__ + +=encoding utf8 + +=encode utf8 + +dummy error + +=head1 An example. + +'Twas brillig, and the slithy toves did gyre and gimble in the wabe. + +=cut + diff --git a/cpan/Pod-Checker/t/pod/podchkenc.xr b/cpan/Pod-Checker/t/pod/podchkenc.xr new file mode 100644 index 0000000000..8a21a1272a --- /dev/null +++ b/cpan/Pod-Checker/t/pod/podchkenc.xr @@ -0,0 +1 @@ +*** ERROR: Unknown command 'encode' at line 20 in file t/pod/podchkenc.t diff --git a/cpan/Pod-Checker/t/pod/poderrs.t b/cpan/Pod-Checker/t/pod/poderrs.t new file mode 100644 index 0000000000..362cbb6575 --- /dev/null +++ b/cpan/Pod-Checker/t/pod/poderrs.t @@ -0,0 +1,241 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testpchk.pl"; + import TestPodChecker; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodchecker \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + +### Deliberately throw in some blank but non-empty lines + +### The above line should contain spaces + + +__END__ + +=head2 This should cause a warning + +=head1 NAME + +poderrors.t - test Pod::Checker on some pod syntax errors + +=unknown1 this is an unknown command with two N +and D interior sequences. + +This is some paragraph text with some unknown interior sequences, +such as Q, +A, +and Y>. + +Now try some unterminated sequences like +I>> + +=head2 Garbled entities + +E +E> +E> +E<0x100> +E<07777> +E<300> + +=head2 Unresolved internal links + +L +L<"end with begin"> +L + +=head2 Some links with problems + +L +L<> +L< aha> +L +L<"Warnings"> this one is ok +L ok too, this POD has an X of the same name +L this is OK +L this is also OK + +=head2 Warnings + +L +L should give warnings as hell + +=over 4 + +=item bla + +=back 200 + +the 200 is evil + +=begin html + +What? + +=end xml + +Xsee these unescaped < and > in the text? + +=head2 Misc + +Z should be empty + +X<> should not be empty + +=over four + +This paragrapgh is misplaced - it ought to be an item. + +=item four should be numeric! + +=item + +=item blah + +=item previous is all empty!!! + +=back + +All empty over/back: + +=over 4 + +=back + +item w/o name + +=cut + +=pod bla + +bla is evil + +=cut blub + +blub is evil + +=head2 reoccurence + +=over 4 + +=item Misc + +we already have a head Misc + +=back + +=head2 some heading + +=head2 another one + +=head2 the next line should be empty +=head2 ... but there is a command instead + +And here is some text +=head2 again followed by a command + + verbatim +=item line missing + +previous section is empty! + +=head1 LINK TESTS + +Due to bug reported by Rafael Garcia-Suarez "rgarciasuarez@free.fr": + +The following hyperlinks : +L<"I/O Operators"> +L +trigger a podchecker warning (using bleadperl) : + node 'I/O Operators' contains non-escaped | or / + +=cut + +=pod + +=head1 ON-OFF tests + +The above =pod is OK. The following =cut is ok, the one after not. + +=cut + +# some comment or code here, not POD + +=cut + +# more code + +=head2 This opens POD + +=pod + +And the =pod above is too much. + +=cut + diff --git a/cpan/Pod-Checker/t/pod/poderrs.xr b/cpan/Pod-Checker/t/pod/poderrs.xr new file mode 100644 index 0000000000..c1a80c6478 --- /dev/null +++ b/cpan/Pod-Checker/t/pod/poderrs.xr @@ -0,0 +1,53 @@ +*** WARNING: =head2 without preceding higher level at line 20 in file t/pod/poderrs.t +*** WARNING: empty section in previous paragraph at line 22 in file t/pod/poderrs.t +*** ERROR: Unknown command 'unknown1' at line 26 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Q' at line 30 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'A' at line 31 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Y' at line 32 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'V' at line 32 in file t/pod/poderrs.t +*** ERROR: unterminated B<...> at line 36 in file t/pod/poderrs.t +*** ERROR: unterminated I<...> at line 35 in file t/pod/poderrs.t +*** ERROR: unterminated C<...> at line 38 in file t/pod/poderrs.t +*** WARNING: line containing nothing but whitespace in paragraph at line 46 in file t/pod/poderrs.t +*** ERROR: =item without previous =over at line 53 in file t/pod/poderrs.t +*** ERROR: =back without previous =over at line 57 in file t/pod/poderrs.t +*** ERROR: =over on line 61 without closing =back (at head2) at line 65 in file t/pod/poderrs.t +*** ERROR: =end without =begin at line 67 in file t/pod/poderrs.t +*** ERROR: Nested =begin's (first at line 71:html) at line 73 in file t/pod/poderrs.t +*** ERROR: =end without =begin at line 77 in file t/pod/poderrs.t +*** ERROR: No argument for =begin at line 83 in file t/pod/poderrs.t +*** ERROR: =for without formatter specification at line 89 in file t/pod/poderrs.t +*** WARNING: nested commands C<...C<...>...> at line 95 in file t/pod/poderrs.t +*** ERROR: garbled entity E at line 99 in file t/pod/poderrs.t +*** ERROR: garbled entity E> at line 100 in file t/pod/poderrs.t +*** ERROR: garbled entity E> at line 101 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<0x100> at line 102 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<07777> at line 103 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<300> at line 104 in file t/pod/poderrs.t +*** ERROR: malformed link L<> : empty link at line 116 in file t/pod/poderrs.t +*** WARNING: ignoring leading whitespace in link at line 117 in file t/pod/poderrs.t +*** WARNING: ignoring trailing whitespace in link at line 118 in file t/pod/poderrs.t +*** WARNING: (section) in 'passwd(5)' deprecated at line 126 in file t/pod/poderrs.t +*** WARNING: node '$|' contains non-escaped | or / at line 127 in file t/pod/poderrs.t +*** WARNING: alternative text '$|' contains non-escaped | or / at line 127 in file t/pod/poderrs.t +*** ERROR: Spurious character(s) after =back at line 133 in file t/pod/poderrs.t +*** ERROR: Nonempty Z<> at line 147 in file t/pod/poderrs.t +*** ERROR: Empty X<> at line 149 in file t/pod/poderrs.t +*** WARNING: preceding non-item paragraph(s) at line 155 in file t/pod/poderrs.t +*** WARNING: No argument for =item at line 157 in file t/pod/poderrs.t +*** WARNING: previous =item has no contents at line 159 in file t/pod/poderrs.t +*** WARNING: No items in =over (at line 167) / =back list at line 169 in file t/pod/poderrs.t +*** ERROR: Spurious text after =pod at line 175 in file t/pod/poderrs.t +*** ERROR: Spurious text after =cut at line 179 in file t/pod/poderrs.t +*** WARNING: empty section in previous paragraph at line 195 in file t/pod/poderrs.t +*** ERROR: Apparent command =head2 not preceded by blank line at line 198 in file t/pod/poderrs.t +*** WARNING: empty section in previous paragraph at line 197 in file t/pod/poderrs.t +*** ERROR: Apparent command =head2 not preceded by blank line at line 201 in file t/pod/poderrs.t +*** ERROR: Apparent command =item not preceded by blank line at line 204 in file t/pod/poderrs.t +*** ERROR: Spurious =cut command at line 230 in file t/pod/poderrs.t +*** ERROR: Spurious =pod command at line 236 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'begin or begin' at line 108 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'end with begin' at line 109 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'OoPs' at line 110 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'abc def' at line 114 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'I/O Operators' at line 213 in file t/pod/poderrs.t diff --git a/cpan/Pod-Checker/t/pod/selfcheck.t b/cpan/Pod-Checker/t/pod/selfcheck.t new file mode 100644 index 0000000000..3b6e352d3a --- /dev/null +++ b/cpan/Pod-Checker/t/pod/selfcheck.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl +use File::Basename; +use File::Spec; +use strict; +my $THISDIR; +BEGIN { + $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testpchk.pl"; + import TestPodChecker qw(testpodcheck); +} + +# test that our POD is correct! +my $path = File::Spec->catfile($THISDIR,(File::Spec->updir()) x 2, 'lib', 'Pod', '*.pm'); +print "THISDIR=$THISDIR PATH=$path\n"; +my @pods = glob($path); +print "PODS=@pods\n"; + +print "1..",scalar(@pods),"\n"; + +my $errs = 0; +my $testnum = 1; +foreach my $pod (@pods) { + my $out = File::Spec->catfile($THISDIR, basename($pod)); + $out =~ s{\.pm}{.OUT}; + my %options = ( -Out => $out ); + my $failmsg = testpodcheck(-In => $pod, -Out => $out, -Cmp => "$THISDIR/empty.xr"); + if($failmsg) { + if(open(IN, "<$out")) { + while() { + warn "podchecker: $_"; + } + close(IN); + } else { + warn "Error: Cannot read output file $out: $!\n"; + } + print "not ok $testnum\n"; + $errs++; + } else { + print "ok $testnum\n"; + } + $testnum++; +} +exit( ($errs == 0) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + diff --git a/cpan/Pod-Checker/t/pod/testcmp.pl b/cpan/Pod-Checker/t/pod/testcmp.pl new file mode 100644 index 0000000000..b8592fcc2a --- /dev/null +++ b/cpan/Pod-Checker/t/pod/testcmp.pl @@ -0,0 +1,94 @@ +package TestCompare; + +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +use File::Basename; +use File::Spec; +use FileHandle; + +@ISA = qw(Exporter); +@EXPORT = qw(&testcmp); +$MYPKG = eval { (caller)[0] }; + +##-------------------------------------------------------------------------- + +=head1 NAME + +testcmp -- compare two files line-by-line + +=head1 SYNOPSIS + + $is_diff = testcmp($file1, $file2); + +or + + $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); + +=head2 DESCRIPTION + +Compare two text files line-by-line and return 0 if they are the +same, 1 if they differ. Each of $file1 and $file2 may be a filenames, +or a filehandles (in which case it must already be open for reading). + +If the first argument is a hashref, then the B<-cmplines> key in the +hash may have a subroutine reference as its corresponding value. +The referenced user-defined subroutine should be a line-comparator +function that takes two pre-chomped text-lines as its arguments +(the first is from $file1 and the second is from $file2). It should +return 0 if it considers the two lines equivalent, and non-zero +otherwise. + +=cut + +##-------------------------------------------------------------------------- + +sub testcmp( $ $ ; $) { + my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); + my ($file1, $file2) = @_; + my ($fh1, $fh2) = ($file1, $file2); + unless (ref $fh1) { + $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; + } + unless (ref $fh2) { + $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; + } + + my $cmplines = $opts{'-cmplines'} || undef; + my ($f1text, $f2text) = ("", ""); + my ($line, $diffs) = (0, 0); + + while ( defined($f1text) and defined($f2text) ) { + defined($f1text = <$fh1>) and chomp($f1text); + defined($f2text = <$fh2>) and chomp($f2text); + ++$line; + last unless ( defined($f1text) and defined($f2text) ); + # kill any extra line endings + $f1text =~ s/[\r\n]+$//s; + $f2text =~ s/[\r\n]+$//s; + $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) + : ($f1text ne $f2text); + last if $diffs; + } + close($fh1) unless (ref $file1); + close($fh2) unless (ref $file2); + + $diffs = 1 if (defined($f1text) or defined($f2text)); + if ( defined($f1text) and defined($f2text) ) { + ## these two lines must be different + warn "$file1 and $file2 differ at line $line\n"; + } + elsif (defined($f1text) and (! defined($f1text))) { + ## file1 must be shorter + warn "$file1 is shorter than $file2\n"; + } + elsif (defined $f2text) { + ## file2 must be longer + warn "$file1 is shorter than $file2\n"; + } + return $diffs; +} + +1; diff --git a/cpan/Pod-Checker/t/pod/testpchk.pl b/cpan/Pod-Checker/t/pod/testpchk.pl new file mode 100644 index 0000000000..0464a9a0fc --- /dev/null +++ b/cpan/Pod-Checker/t/pod/testpchk.pl @@ -0,0 +1,130 @@ +package TestPodChecker; + +BEGIN { + use File::Basename; + use File::Spec; + push @INC, '..'; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); + require VMS::Filespec if $^O eq 'VMS'; +} + +use Pod::Checker; +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; + +@ISA = qw(Exporter); +@EXPORT = qw(&testpodchecker); +@EXPORT_OK = qw(&testpodcheck); +$MYPKG = eval { (caller)[0] }; + +sub stripname( $ ) { + local $_ = shift; + return /(\w[.\w]*)\s*$/ ? $1 : $_; +} + +sub msgcmp( $ $ ) { + ## filter out platform-dependent aspects of error messages + my ($line1, $line2) = @_; + for ($line1, $line2) { + ## remove filenames from error messages to avoid any + ## filepath naming differences between OS platforms + s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/; + s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/; + } + return ($line1 ne $line2); +} + +sub testpodcheck( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $infile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "# Running podchecker for '$testname'...\n"; + ## Compare the output against the expected result + if ($^O eq 'VMS') { + for ($infile, $outfile, $cmpfile) { + $_ = VMS::Filespec::unixify($_) unless ref; + } + } + podchecker($infile, $outfile); + if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodchecker( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "# Creating expected result for \"$testname\"" . + " podchecker test ...\n"; + podchecker($podfile, $cmpfile); + } + else { + print "# File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodcheck + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "#\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "#\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/cpan/Pod-Parser/.gitignore b/cpan/Pod-Parser/.gitignore index 94e3999854..d3b4510c2e 100644 --- a/cpan/Pod-Parser/.gitignore +++ b/cpan/Pod-Parser/.gitignore @@ -1,3 +1 @@ -/pod2usage* -/podchecker* /podselect* diff --git a/cpan/Pod-Parser/lib/Pod/Checker.pm b/cpan/Pod-Parser/lib/Pod/Checker.pm deleted file mode 100644 index 25dab197b0..0000000000 --- a/cpan/Pod-Parser/lib/Pod/Checker.pm +++ /dev/null @@ -1,1329 +0,0 @@ -############################################################################# -# Pod/Checker.pm -- check pod documents for syntax errors -# -# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Checker; -use strict; - -use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -use Pod::ParseUtils; ## for hyperlinks and lists - -=head1 NAME - -Pod::Checker, podchecker() - check pod documents for syntax errors - -=head1 SYNOPSIS - - use Pod::Checker; - - $syntax_okay = podchecker($filepath, $outputpath, %options); - - my $checker = new Pod::Checker %options; - $checker->parse_from_file($filepath, \*STDERR); - -=head1 OPTIONS/ARGUMENTS - -C<$filepath> is the input POD to read and C<$outputpath> is -where to write POD syntax error messages. Either argument may be a scalar -indicating a file-path, or else a reference to an open filehandle. -If unspecified, the input-file it defaults to C<\*STDIN>, and -the output-file defaults to C<\*STDERR>. - -=head2 podchecker() - -This function can take a hash of options: - -=over 4 - -=item B<-warnings> =E I - -Turn warnings on/off. I is usually 1 for on, but higher values -trigger additional warnings. See L<"Warnings">. - -=back - -=head1 DESCRIPTION - -B will perform syntax checking of Perl5 POD format documentation. - -Curious/ambitious users are welcome to propose additional features they wish -to see in B and B and verify that the checks are -consistent with L. - -The following checks are currently performed: - -=over 4 - -=item * - -Unknown '=xxxx' commands, unknown 'XE...E' interior-sequences, -and unterminated interior sequences. - -=item * - -Check for proper balancing of C<=begin> and C<=end>. The contents of such -a block are generally ignored, i.e. no syntax checks are performed. - -=item * - -Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. - -=item * - -Check for same nested interior-sequences (e.g. -C...LE...E...E>). - -=item * - -Check for malformed or non-existing entities C...E>. - -=item * - -Check for correct syntax of hyperlinks C...E>. See L -for details. - -=item * - -Check for unresolved document-internal links. This check may also reveal -misspelled links that seem to be internal links but should be links -to something else. - -=back - -=head1 DIAGNOSTICS - -=head2 Errors - -=over 4 - -=item * empty =headn - -A heading (C<=head1> or C<=head2>) without any text? That ain't no -heading! - -=item * =over on line I without closing =back - -The C<=over> command does not have a corresponding C<=back> before the -next heading (C<=head1> or C<=head2>) or the end of the file. - -=item * =item without previous =over - -=item * =back without previous =over - -An C<=item> or C<=back> command has been found outside a -C<=over>/C<=back> block. - -=item * No argument for =begin - -A C<=begin> command was found that is not followed by the formatter -specification. - -=item * =end without =begin - -A standalone C<=end> command was found. - -=item * Nested =begin's - -There were at least two consecutive C<=begin> commands without -the corresponding C<=end>. Only one C<=begin> may be active at -a time. - -=item * =for without formatter specification - -There is no specification of the formatter after the C<=for> command. - -=item * Apparent command =foo not preceded by blank line - -A command which has ended up in the middle of a paragraph or other command, -such as - - =item one - =item two <-- bad - -=item * unresolved internal link I - -The given link to I does not have a matching node in the current -POD. This also happened when a single word node name is not enclosed in -C<"">. - -=item * Unknown command "I" - -An invalid POD command has been found. Valid are C<=head1>, C<=head2>, -C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, -C<=for>, C<=pod>, C<=cut> - -=item * Unknown interior-sequence "I" - -An invalid markup command has been encountered. Valid are: -CE>, CE>, CE>, CE>, -CE>, CE>, CE>, CE>, -CE> - -=item * nested commands IE...IE...E...E - -Two nested identical markup commands have been found. Generally this -does not make sense. - -=item * garbled entity I - -The I found cannot be interpreted as a character entity. - -=item * Entity number out of range - -An entity specified by number (dec, hex, oct) is out of range (1-255). - -=item * malformed link LEE - -The link found cannot be parsed because it does not conform to the -syntax described in L. - -=item * nonempty ZEE - -The CE> sequence is supposed to be empty. - -=item * empty XEE - -The index entry specified contains nothing but whitespace. - -=item * Spurious text after =pod / =cut - -The commands C<=pod> and C<=cut> do not take any arguments. - -=item * Spurious =cut command - -A C<=cut> command was found without a preceding POD paragraph. - -=item * Spurious =pod command - -A C<=pod> command was found after a preceding POD paragraph. - -=item * Spurious character(s) after =back - -The C<=back> command does not take any arguments. - -=back - -=head2 Warnings - -These may not necessarily cause trouble, but indicate mediocre style. - -=over 4 - -=item * multiple occurrence of link target I - -The POD file has some C<=item> and/or C<=head> commands that have -the same text. Potential hyperlinks to such a text cannot be unique then. -This warning is printed only with warning level greater than one. - -=item * line containing nothing but whitespace in paragraph - -There is some whitespace on a seemingly empty line. POD is very sensitive -to such things, so this is flagged. B users switch on the B -option to avoid this problem. - -=begin _disabled_ - -=item * file does not start with =head - -The file starts with a different POD directive than head. -This is most probably something you do not want. - -=end _disabled_ - -=item * previous =item has no contents - -There is a list C<=item> right above the flagged line that has no -text contents. You probably want to delete empty items. - -=item * preceding non-item paragraph(s) - -A list introduced by C<=over> starts with a text or verbatim paragraph, -but continues with C<=item>s. Move the non-item paragraph out of the -C<=over>/C<=back> block. - -=item * =item type mismatch (I vs. I) - -A list started with e.g. a bullet-like C<=item> and continued with a -numbered one. This is obviously inconsistent. For most translators the -type of the I C<=item> determines the type of the list. - -=item * I unescaped CE> in paragraph - -Angle brackets not written as CltE> and CgtE> -can potentially cause errors as they could be misinterpreted as -markup commands. This is only printed when the -warnings level is -greater than 1. - -=item * Unknown entity - -A character entity was found that does not belong to the standard -ISO set or the POD specials C and C. - -=item * No items in =over - -The list opened with C<=over> does not contain any items. - -=item * No argument for =item - -C<=item> without any parameters is deprecated. It should either be followed -by C<*> to indicate an unordered list, by a number (optionally followed -by a dot) to indicate an ordered (numbered) list or simple text for a -definition list. - -=item * empty section in previous paragraph - -The previous section (introduced by a C<=head> command) does not contain -any text. This usually indicates that something is missing. Note: A -C<=head1> followed immediately by C<=head2> does not trigger this warning. - -=item * Verbatim paragraph in NAME section - -The NAME section (C<=head1 NAME>) should consist of a single paragraph -with the script/module name, followed by a dash `-' and a very short -description of what the thing is good for. - -=item * =headI without preceding higher level - -For example if there is a C<=head2> in the POD file prior to a -C<=head1>. - -=back - -=head2 Hyperlinks - -There are some warnings with respect to malformed hyperlinks: - -=over 4 - -=item * ignoring leading/trailing whitespace in link - -There is whitespace at the beginning or the end of the contents of -LE...E. - -=item * (section) in '$page' deprecated - -There is a section detected in the page name of LE...E, e.g. -Cpasswd(2)E>. POD hyperlinks may point to POD documents only. -Please write Cpasswd(2)E> instead. Some formatters are able -to expand this to appropriate code. For links to (builtin) functions, -please say Cperlfunc/mkdirE>, without (). - -=item * alternative text/node '%s' contains non-escaped | or / - -The characters C<|> and C are special in the LE...E context. -Although the hyperlink parser does its best to determine which "/" is -text and which is a delimiter in case of doubt, one ought to escape -these literal characters like this: - - / E - | E - -=back - -=head1 RETURN VALUE - -B returns the number of POD syntax errors found or -1 if -there were no POD commands at all found in the file. - -=head1 EXAMPLES - -See L - -=head1 INTERFACE - -While checking, this module collects document properties, e.g. the nodes -for hyperlinks (C<=headX>, C<=item>) and index entries (CE>). -POD translators can use this feature to syntax-check and get the nodes in -a first pass before actually starting to convert. This is expensive in terms -of execution time, but allows for very robust conversions. - -Since PodParser-1.24 the B module uses only the B -method to print errors and warnings. The summary output (e.g. -"Pod syntax OK") has been dropped from the module and has been included in -B (the script). This allows users of B to -control completely the output behavior. Users of B (the script) -get the well-known behavior. - -=cut - -############################################################################# - -#use diagnostics; -use Carp qw(croak); -use Exporter; -use Pod::Parser; - -@ISA = qw(Pod::Parser); -@EXPORT = qw(&podchecker); - -my %VALID_COMMANDS = ( - 'pod' => 1, - 'cut' => 1, - 'head1' => 1, - 'head2' => 1, - 'head3' => 1, - 'head4' => 1, - 'over' => 1, - 'back' => 1, - 'item' => 1, - 'for' => 1, - 'begin' => 1, - 'end' => 1, - 'encoding' => 1, -); - -my %VALID_SEQUENCES = ( - 'I' => 1, - 'B' => 1, - 'S' => 1, - 'C' => 1, - 'L' => 1, - 'F' => 1, - 'X' => 1, - 'Z' => 1, - 'E' => 1, -); - -# stolen from HTML::Entities -my %ENTITIES = ( - # Some normal chars that have special meaning in SGML context - amp => '&', # ampersand -'gt' => '>', # greater than -'lt' => '<', # less than - quot => '"', # double quote - - # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML - AElig => 'Æ', # capital AE diphthong (ligature) - Aacute => 'Á', # capital A, acute accent - Acirc => 'Â', # capital A, circumflex accent - Agrave => 'À', # capital A, grave accent - Aring => 'Å', # capital A, ring - Atilde => 'Ã', # capital A, tilde - Auml => 'Ä', # capital A, dieresis or umlaut mark - Ccedil => 'Ç', # capital C, cedilla - ETH => 'Ð', # capital Eth, Icelandic - Eacute => 'É', # capital E, acute accent - Ecirc => 'Ê', # capital E, circumflex accent - Egrave => 'È', # capital E, grave accent - Euml => 'Ë', # capital E, dieresis or umlaut mark - Iacute => 'Í', # capital I, acute accent - Icirc => 'Î', # capital I, circumflex accent - Igrave => 'Ì', # capital I, grave accent - Iuml => 'Ï', # capital I, dieresis or umlaut mark - Ntilde => 'Ñ', # capital N, tilde - Oacute => 'Ó', # capital O, acute accent - Ocirc => 'Ô', # capital O, circumflex accent - Ograve => 'Ò', # capital O, grave accent - Oslash => 'Ø', # capital O, slash - Otilde => 'Õ', # capital O, tilde - Ouml => 'Ö', # capital O, dieresis or umlaut mark - THORN => 'Þ', # capital THORN, Icelandic - Uacute => 'Ú', # capital U, acute accent - Ucirc => 'Û', # capital U, circumflex accent - Ugrave => 'Ù', # capital U, grave accent - Uuml => 'Ü', # capital U, dieresis or umlaut mark - Yacute => 'Ý', # capital Y, acute accent - aacute => 'á', # small a, acute accent - acirc => 'â', # small a, circumflex accent - aelig => 'æ', # small ae diphthong (ligature) - agrave => 'à', # small a, grave accent - aring => 'å', # small a, ring - atilde => 'ã', # small a, tilde - auml => 'ä', # small a, dieresis or umlaut mark - ccedil => 'ç', # small c, cedilla - eacute => 'é', # small e, acute accent - ecirc => 'ê', # small e, circumflex accent - egrave => 'è', # small e, grave accent - eth => 'ð', # small eth, Icelandic - euml => 'ë', # small e, dieresis or umlaut mark - iacute => 'í', # small i, acute accent - icirc => 'î', # small i, circumflex accent - igrave => 'ì', # small i, grave accent - iuml => 'ï', # small i, dieresis or umlaut mark - ntilde => 'ñ', # small n, tilde - oacute => 'ó', # small o, acute accent - ocirc => 'ô', # small o, circumflex accent - ograve => 'ò', # small o, grave accent - oslash => 'ø', # small o, slash - otilde => 'õ', # small o, tilde - ouml => 'ö', # small o, dieresis or umlaut mark - szlig => 'ß', # small sharp s, German (sz ligature) - thorn => 'þ', # small thorn, Icelandic - uacute => 'ú', # small u, acute accent - ucirc => 'û', # small u, circumflex accent - ugrave => 'ù', # small u, grave accent - uuml => 'ü', # small u, dieresis or umlaut mark - yacute => 'ý', # small y, acute accent - yuml => 'ÿ', # small y, dieresis or umlaut mark - - # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) - copy => '©', # copyright sign - reg => '®', # registered sign - nbsp => "\240", # non breaking space - - # Additional ISO-8859/1 entities listed in rfc1866 (section 14) - iexcl => '¡', - cent => '¢', - pound => '£', - curren => '¤', - yen => '¥', - brvbar => '¦', - sect => '§', - uml => '¨', - ordf => 'ª', - laquo => '«', -'not' => '¬', # not is a keyword in perl - shy => '­', - macr => '¯', - deg => '°', - plusmn => '±', - sup1 => '¹', - sup2 => '²', - sup3 => '³', - acute => '´', - micro => 'µ', - para => '¶', - middot => '·', - cedil => '¸', - ordm => 'º', - raquo => '»', - frac14 => '¼', - frac12 => '½', - frac34 => '¾', - iquest => '¿', -'times' => '×', # times is a keyword in perl - divide => '÷', - -# some POD special entities - verbar => '|', - sol => '/' -); - -##--------------------------------------------------------------------------- - -##--------------------------------- -## Function definitions begin here -##--------------------------------- - -sub podchecker { - my ($infile, $outfile, %options) = @_; - local $_; - - ## Set defaults - $infile ||= \*STDIN; - $outfile ||= \*STDERR; - - ## Now create a pod checker - my $checker = new Pod::Checker(%options); - - ## Now check the pod document for errors - $checker->parse_from_file($infile, $outfile); - - ## Return the number of errors found - return $checker->num_errors(); -} - -##--------------------------------------------------------------------------- - -##------------------------------- -## Method definitions begin here -##------------------------------- - -################################## - -=over 4 - -=item Cnew( %options )> - -Return a reference to a new Pod::Checker object that inherits from -Pod::Parser and is used for calling the required methods later. The -following options are recognized: - -C<-warnings =E num> - Print warnings if C is true. The higher the value of C, -the more warnings are printed. Currently there are only levels 1 and 2. - -C<-quiet =E num> - If C is true, do not print any errors/warnings. This is useful -when Pod::Checker is used to munge POD code into plain text from within -POD formatters. - -=cut - -## sub new { -## my $this = shift; -## my $class = ref($this) || $this; -## my %params = @_; -## my $self = {%params}; -## bless $self, $class; -## $self->initialize(); -## return $self; -## } - -sub initialize { - my $self = shift; - ## Initialize number of errors, and setup an error function to - ## increment this number and then print to the designated output. - $self->{_NUM_ERRORS} = 0; - $self->{_NUM_WARNINGS} = 0; - $self->{-quiet} ||= 0; - # set the error handling subroutine - $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror'); - $self->{_commands} = 0; # total number of POD commands encountered - $self->{_list_stack} = []; # stack for nested lists - $self->{_have_begin} = ''; # stores =begin - $self->{_links} = []; # stack for internal hyperlinks - $self->{_nodes} = []; # stack for =head/=item nodes - $self->{_index} = []; # text in X<> - # print warnings? - $self->{-warnings} = 1 unless(defined $self->{-warnings}); - $self->{_current_head1} = ''; # the current =head1 block - $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings}); -} - -################################## - -=item C<$checker-Epoderror( @args )> - -=item C<$checker-Epoderror( {%opts}, @args )> - -Internal method for printing errors and warnings. If no options are -given, simply prints "@_". The following options are recognized and used -to form the output: - - -msg - -A message to print prior to C<@args>. - - -line - -The line number the error occurred in. - - -file - -The file (name) the error occurred in. - - -severity - -The error level, should be 'WARNING' or 'ERROR'. - -=cut - -# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) -sub poderror { - my $self = shift; - my %opts = (ref $_[0]) ? %{shift()} : (); - - ## Retrieve options - chomp( my $msg = ($opts{-msg} || '')."@_" ); - my $line = (exists $opts{-line}) ? " at line $opts{-line}" : ''; - my $file = (exists $opts{-file}) ? " in file $opts{-file}" : ''; - unless (exists $opts{-severity}) { - ## See if can find severity in message prefix - $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// ); - } - my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : ''; - - ## Increment error count and print message " - ++($self->{_NUM_ERRORS}) - if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); - ++($self->{_NUM_WARNINGS}) - if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING')); - unless($self->{-quiet}) { - my $out_fh = $self->output_handle() || \*STDERR; - print $out_fh ($severity, $msg, $line, $file, "\n") - if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); - } -} - -################################## - -=item C<$checker-Enum_errors()> - -Set (if argument specified) and retrieve the number of errors found. - -=cut - -sub num_errors { - return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; -} - -################################## - -=item C<$checker-Enum_warnings()> - -Set (if argument specified) and retrieve the number of warnings found. - -=cut - -sub num_warnings { - return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS}; -} - -################################## - -=item C<$checker-Ename()> - -Set (if argument specified) and retrieve the canonical name of POD as -found in the C<=head1 NAME> section. - -=cut - -sub name { - return (@_ > 1 && $_[1]) ? - ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; -} - -################################## - -=item C<$checker-Enode()> - -Add (if argument specified) and retrieve the nodes (as defined by C<=headX> -and C<=item>) of the current POD. The nodes are returned in the order of -their occurrence. They consist of plain text, each piece of whitespace is -collapsed to a single blank. - -=cut - -sub node { - my ($self,$text) = @_; - if(defined $text) { - $text =~ s/\s+$//s; # strip trailing whitespace - $text =~ s/\s+/ /gs; # collapse whitespace - # add node, order important! - push(@{$self->{_nodes}}, $text); - # keep also a uniqueness counter - $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); - return $text; - } - @{$self->{_nodes}}; -} - -################################## - -=item C<$checker-Eidx()> - -Add (if argument specified) and retrieve the index entries (as defined by -CE>) of the current POD. They consist of plain text, each piece -of whitespace is collapsed to a single blank. - -=cut - -# set/return index entries of current POD -sub idx { - my ($self,$text) = @_; - if(defined $text) { - $text =~ s/\s+$//s; # strip trailing whitespace - $text =~ s/\s+/ /gs; # collapse whitespace - # add node, order important! - push(@{$self->{_index}}, $text); - # keep also a uniqueness counter - $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); - return $text; - } - @{$self->{_index}}; -} - -################################## - -=item C<$checker-Ehyperlink()> - -Add (if argument specified) and retrieve the hyperlinks (as defined by -CE>) of the current POD. They consist of a 2-item array: line -number and C object. - -=back - -=cut - -# set/return hyperlinks of the current POD -sub hyperlink { - my $self = shift; - if($_[0]) { - push(@{$self->{_links}}, $_[0]); - return $_[0]; - } - @{$self->{_links}}; -} - -## overrides for Pod::Parser - -sub end_pod { - ## Do some final checks and - ## print the number of errors found - my $self = shift; - my $infile = $self->input_file(); - - if(@{$self->{_list_stack}}) { - my $list; - while(($list = $self->_close_list('EOF',$infile)) && - $list->indent() ne 'auto') { - $self->poderror({ -line => 'EOF', -file => $infile, - -severity => 'ERROR', -msg => '=over on line ' . - $list->start() . ' without closing =back' }); - } - } - - # check validity of document internal hyperlinks - # first build the node names from the paragraph text - my %nodes; - foreach($self->node()) { - $nodes{$_} = 1; - if(/^(\S+)\s+\S/) { - # we have more than one word. Use the first as a node, too. - # This is used heavily in perlfunc.pod - $nodes{$1} ||= 2; # derived node - } - } - foreach($self->idx()) { - $nodes{$_} = 3; # index node - } - foreach($self->hyperlink()) { - my ($line,$link) = @$_; - # _TODO_ what if there is a link to the page itself by the name, - # e.g. in Tk::Pod : L - if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { - my $node = $self->_check_ptree($self->parse_text($link->node(), - $line), $line, $infile, 'L'); - if($node && !$nodes{$node}) { - $self->poderror({ -line => $line || '', -file => $infile, - -severity => 'ERROR', - -msg => "unresolved internal link '$node'"}); - } - } - } - - # check the internal nodes for uniqueness. This pertains to - # =headX, =item and X<...> - if($self->{-warnings} && $self->{-warnings}>1) { - foreach(grep($self->{_unique_nodes}->{$_} > 1, - keys %{$self->{_unique_nodes}})) { - $self->poderror({ -line => '-', -file => $infile, - -severity => 'WARNING', - -msg => "multiple occurrence of link target '$_'"}); - } - } - - # no POD found here - $self->num_errors(-1) if($self->{_commands} == 0); -} - -# check a POD command directive -sub command { - my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; - my ($file, $line) = $pod_para->file_line; - ## Check the command syntax - my $arg; # this will hold the command argument - if (! $VALID_COMMANDS{$cmd}) { - $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', - -msg => "Unknown command '$cmd'" }); - } - else { # found a valid command - $self->{_commands}++; # delete this line if below is enabled again - - $self->_commands_in_paragraphs($paragraph, $pod_para); - - ##### following check disabled due to strong request - #if(!$self->{_commands}++ && $cmd !~ /^head/) { - # $self->poderror({ -line => $line, -file => $file, - # -severity => 'WARNING', - # -msg => "file does not start with =head" }); - #} - - # check syntax of particular command - if($cmd eq 'over') { - # check for argument - $arg = $self->interpolate_and_check($paragraph, $line,$file); - my $indent = 4; # default - if($arg && $arg =~ /^\s*(\d+)\s*$/) { - $indent = $1; - } - # start a new list - $self->_open_list($indent,$line,$file); - } - elsif($cmd eq 'item') { - # are we in a list? - unless(@{$self->{_list_stack}}) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => '=item without previous =over' }); - # auto-open in case we encounter many more - $self->_open_list('auto',$line,$file); - } - my $list = $self->{_list_stack}->[0]; - # check whether the previous item had some contents - if(defined $self->{_list_item_contents} && - $self->{_list_item_contents} == 0) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'previous =item has no contents' }); - } - if($list->{_has_par}) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'preceding non-item paragraph(s)' }); - delete $list->{_has_par}; - } - # check for argument - $arg = $self->interpolate_and_check($paragraph, $line, $file); - if($arg && $arg =~ /(\S+)/) { - $arg =~ s/[\s\n]+$//; - my $type; - if($arg =~ /^[*]\s*(\S*.*)/) { - $type = 'bullet'; - $self->{_list_item_contents} = $1 ? 1 : 0; - $arg = $1; - } - elsif($arg =~ /^\d+\.?\s+(\S*)/) { - $type = 'number'; - $self->{_list_item_contents} = $1 ? 1 : 0; - $arg = $1; - } - else { - $type = 'definition'; - $self->{_list_item_contents} = 1; - } - my $first = $list->type(); - if($first && $first ne $type) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "=item type mismatch ('$first' vs. '$type')"}); - } - else { # first item - $list->type($type); - } - } - else { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'No argument for =item' }); - $arg = ' '; # empty - $self->{_list_item_contents} = 0; - } - # add this item - $list->item($arg); - # remember this node - $self->node($arg); - } - elsif($cmd eq 'back') { - # check if we have an open list - unless(@{$self->{_list_stack}}) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => '=back without previous =over' }); - } - else { - # check for spurious characters - $arg = $self->interpolate_and_check($paragraph, $line,$file); - if($arg && $arg =~ /\S/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'Spurious character(s) after =back' }); - } - # close list - my $list = $self->_close_list($line,$file); - # check for empty lists - if(!$list->item() && $self->{-warnings}) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'No items in =over (at line ' . - $list->start() . ') / =back list'}); - } - } - } - elsif($cmd =~ /^head(\d+)/) { - my $hnum = $1; - $self->{"_have_head_$hnum"}++; # count head types - if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "=head$hnum without preceding higher level"}); - } - # check whether the previous =head section had some contents - if(defined $self->{_commands_in_head} && - $self->{_commands_in_head} == 0 && - defined $self->{_last_head} && - $self->{_last_head} >= $hnum) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'empty section in previous paragraph'}); - } - $self->{_commands_in_head} = -1; - $self->{_last_head} = $hnum; - # check if there is an open list - if(@{$self->{_list_stack}}) { - my $list; - while(($list = $self->_close_list($line,$file)) && - $list->indent() ne 'auto') { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => '=over on line '. $list->start() . - " without closing =back (at $cmd)" }); - } - } - # remember this node - $arg = $self->interpolate_and_check($paragraph, $line,$file); - $arg =~ s/[\s\n]+$//s; - $self->node($arg); - unless(length($arg)) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "empty =$cmd"}); - } - if($cmd eq 'head1') { - $self->{_current_head1} = $arg; - } else { - $self->{_current_head1} = ''; - } - } - elsif($cmd eq 'begin') { - if($self->{_have_begin}) { - # already have a begin - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => q{Nested =begin's (first at line } . - $self->{_have_begin} . ')'}); - } - else { - # check for argument - $arg = $self->interpolate_and_check($paragraph, $line,$file); - unless($arg && $arg =~ /(\S+)/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'No argument for =begin'}); - } - # remember the =begin - $self->{_have_begin} = "$line:$1"; - } - } - elsif($cmd eq 'end') { - if($self->{_have_begin}) { - # close the existing =begin - $self->{_have_begin} = ''; - # check for spurious characters - $arg = $self->interpolate_and_check($paragraph, $line,$file); - # the closing argument is optional - #if($arg && $arg =~ /\S/) { - # $self->poderror({ -line => $line, -file => $file, - # -severity => 'WARNING', - # -msg => "Spurious character(s) after =end" }); - #} - } - else { - # don't have a matching =begin - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => '=end without =begin' }); - } - } - elsif($cmd eq 'for') { - unless($paragraph =~ /\s*(\S+)\s*/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => '=for without formatter specification' }); - } - $arg = ''; # do not expand paragraph below - } - elsif($cmd =~ /^(pod|cut)$/) { - # check for argument - $arg = $self->interpolate_and_check($paragraph, $line,$file); - if($arg && $arg =~ /(\S+)/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Spurious text after =$cmd"}); - } - if($cmd eq 'cut' && (!$self->{_PREVIOUS} || $self->{_PREVIOUS} eq 'cut')) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Spurious =cut command"}); - } - if($cmd eq 'pod' && $self->{_PREVIOUS} && $self->{_PREVIOUS} ne 'cut') { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Spurious =pod command"}); - } - } - $self->{_commands_in_head}++; - ## Check the interior sequences in the command-text - $self->interpolate_and_check($paragraph, $line,$file) - unless(defined $arg); - } -} - -sub _open_list -{ - my ($self,$indent,$line,$file) = @_; - my $list = Pod::List->new( - -indent => $indent, - -start => $line, - -file => $file); - unshift(@{$self->{_list_stack}}, $list); - undef $self->{_list_item_contents}; - $list; -} - -sub _close_list -{ - my ($self,$line,$file) = @_; - my $list = shift(@{$self->{_list_stack}}); - if(defined $self->{_list_item_contents} && - $self->{_list_item_contents} == 0) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'previous =item has no contents' }); - } - undef $self->{_list_item_contents}; - $list; -} - -# process a block of some text -sub interpolate_and_check { - my ($self, $paragraph, $line, $file) = @_; - ## Check the interior sequences in the command-text - # and return the text - $self->_check_ptree( - $self->parse_text($paragraph,$line), $line, $file, ''); -} - -sub _check_ptree { - my ($self,$ptree,$line,$file,$nestlist) = @_; - local($_); - my $text = ''; - # process each node in the parse tree - foreach(@$ptree) { - # regular text chunk - unless(ref) { - # count the unescaped angle brackets - # complain only when warning level is greater than 1 - if($self->{-warnings} && $self->{-warnings}>1) { - my $count; - if($count = tr/<>/<>/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "$count unescaped <> in paragraph" }); - } - } - $text .= $_; - next; - } - # have an interior sequence - my $cmd = $_->cmd_name(); - my $contents = $_->parse_tree(); - ($file,$line) = $_->file_line(); - # check for valid tag - if (! $VALID_SEQUENCES{$cmd}) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => qq(Unknown interior-sequence '$cmd')}); - # expand it anyway - $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); - next; - } - if(index($nestlist, $cmd) != -1) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "nested commands $cmd<...$cmd<...>...>"}); - # _TODO_ should we add the contents anyway? - # expand it anyway, see below - } - if($cmd eq 'E') { - # preserve entities - if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'garbled entity ' . $_->raw_text()}); - next; - } - my $ent = $$contents[0]; - my $val; - if($ent =~ /^0x[0-9a-f]+$/i) { - # hexadec entity - $val = hex($ent); - } - elsif($ent =~ /^0\d+$/) { - # octal - $val = oct($ent); - } - elsif($ent =~ /^\d+$/) { - # numeric entity - $val = $ent; - } - if(defined $val) { - if($val>0 && $val<256) { - $text .= chr($val); - } - else { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'Entity number out of range ' . $_->raw_text()}); - } - } - elsif($ENTITIES{$ent}) { - # known ISO entity - $text .= $ENTITIES{$ent}; - } - else { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'Unknown entity ' . $_->raw_text()}); - $text .= "E<$ent>"; - } - } - elsif($cmd eq 'L') { - # try to parse the hyperlink - my $link = Pod::Hyperlink->new($contents->raw_text()); - unless(defined $link) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'malformed link ' . $_->raw_text() ." : $@"}); - next; - } - $link->line($line); # remember line - if($self->{-warnings}) { - foreach my $w ($link->warning()) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => $w }); - } - } - # check the link text - $text .= $self->_check_ptree($self->parse_text($link->text(), - $line), $line, $file, "$nestlist$cmd"); - # remember link - $self->hyperlink([$line,$link]); - } - elsif($cmd =~ /[BCFIS]/) { - # add the guts - $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); - } - elsif($cmd eq 'Z') { - if(length($contents->raw_text())) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'Nonempty Z<>'}); - } - } - elsif($cmd eq 'X') { - my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); - if($idx =~ /^\s*$/s) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => 'Empty X<>'}); - } - else { - # remember this node - $self->idx($idx); - } - } - else { - # not reached - croak 'internal error'; - } - } - $text; -} - -# process a block of verbatim text -sub verbatim { - ## Nothing particular to check - my ($self, $paragraph, $line_num, $pod_para) = @_; - - $self->_preproc_par($paragraph); - $self->_commands_in_paragraphs($paragraph, $pod_para); - - if($self->{_current_head1} eq 'NAME') { - my ($file, $line) = $pod_para->file_line; - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => 'Verbatim paragraph in NAME section' }); - } -} - -# process a block of regular text -sub textblock { - my ($self, $paragraph, $line_num, $pod_para) = @_; - my ($file, $line) = $pod_para->file_line; - - $self->_preproc_par($paragraph); - $self->_commands_in_paragraphs($paragraph, $pod_para); - - # skip this paragraph if in a =begin block - unless($self->{_have_begin}) { - my $block = $self->interpolate_and_check($paragraph, $line,$file); - if($self->{_current_head1} eq 'NAME') { - if($block =~ /^\s*(\S+?)\s*[,-]/) { - # this is the canonical name - $self->{-name} = $1 unless(defined $self->{-name}); - } - } - } -} - -sub _preproc_par -{ - my $self = shift; - $_[0] =~ s/[\s\n]+$//; - if($_[0]) { - $self->{_commands_in_head}++; - $self->{_list_item_contents}++ if(defined $self->{_list_item_contents}); - if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) { - $self->{_list_stack}->[0]->{_has_par} = 1; - } - } -} - -# look for =foo commands at the start of a line within a paragraph, as for -# instance the following which prints as "* one =item two". -# -# =item one -# =item two -# -# Examples of =foo written in docs are expected to be indented in a verbatim -# or marked up C<=foo> so won't be caught. A double-angle C<< =foo >> could -# have the =foo at the start of a line, but that should be unlikely and is -# easily enough dealt with by not putting a newline after the C<<. -# -sub _commands_in_paragraphs { - my ($self, $str, $pod_para) = @_; - while ($str =~ /[^\n]\n=([a-z][a-z0-9]+)/sg) { - my $cmd = $1; - my $pos = pos($str); - if ($VALID_COMMANDS{$cmd}) { - my ($file, $line) = $pod_para->file_line; - my $part = substr($str, 0, $pos); - $line += ($part =~ tr/\n//); # count of newlines - - $self->poderror - ({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Apparent command =$cmd not preceded by blank line"}); - } - } -} - -1; - -__END__ - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE (initial version), -Marek Rouchal Emarekr@cpan.orgE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -B is part of the L distribution. - -=cut - diff --git a/cpan/Pod-Parser/lib/Pod/Find.pm b/cpan/Pod-Parser/lib/Pod/Find.pm index 028a405c79..884062ff3a 100644 --- a/cpan/Pod-Parser/lib/Pod/Find.pm +++ b/cpan/Pod-Parser/lib/Pod/Find.pm @@ -1,549 +1,549 @@ -############################################################################# -# Pod/Find.pm -- finds files containing POD documentation -# -# Author: Marek Rouchal -# -# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code -# from Nick Ing-Simmon's PodToHtml). All rights reserved. -# This file is part of "PodParser". Pod::Find is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Find; -use strict; - -use vars qw($VERSION); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later -use Carp; - -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} - -############################################################################# - -=head1 NAME - -Pod::Find - find POD documents in directory trees - -=head1 SYNOPSIS - - use Pod::Find qw(pod_find simplify_name); - my %pods = pod_find({ -verbose => 1, -inc => 1 }); - foreach(keys %pods) { - print "found library POD `$pods{$_}' in $_\n"; - } - - print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; - - $location = pod_where( { -inc => 1 }, "Pod::Find" ); - -=head1 DESCRIPTION - -B provides a set of functions to locate POD files. Note that -no function is exported by default to avoid pollution of your namespace, -so be sure to specify them in the B statement if you need them: - - use Pod::Find qw(pod_find); - -From this version on the typical SCM (software configuration management) -files/directories like RCS, CVS, SCCS, .svn are ignored. - -=cut - -#use diagnostics; -use Exporter; -use File::Spec; -use File::Find; -use Cwd qw(abs_path cwd); - -use vars qw(@ISA @EXPORT_OK $VERSION); -@ISA = qw(Exporter); -@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); - -# package global variables -my $SIMPLIFY_RX; - -=head2 C - -The function B searches for POD documents in a given set of -files and/or directories. It returns a hash with the file names as keys -and the POD name as value. The POD name is derived from the file name -and its position in the directory tree. - -E.g. when searching in F<$HOME/perl5lib>, the file -F<$HOME/perl5lib/MyModule.pm> would get the POD name I, -whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be -I. The name information can be used for POD -translators. - -Only text files containing at least one valid POD command are found. - -A warning is printed if more than one POD file with the same POD name -is found, e.g. F in different directories. This usually -indicates duplicate occurrences of modules in the I<@INC> search path. - -B The first argument for B may be a hash reference -with options. The rest are either directories that are searched -recursively or files. The POD names of files are the plain basenames -with any Perl-like extension (.pm, .pl, .pod) stripped. - -=over 4 - -=item C<-verbose =E 1> - -Print progress information while scanning. - -=item C<-perl =E 1> - -Apply Perl-specific heuristics to find the correct PODs. This includes -stripping Perl-like extensions, omitting subdirectories that are numeric -but do I match the current Perl interpreter's version id, suppressing -F as a module hierarchy name etc. - -=item C<-script =E 1> - -Search for PODs in the current Perl interpreter's installation -B. This is taken from the local L module. - -=item C<-inc =E 1> - -Search for PODs in the current Perl interpreter's I<@INC> paths. This -automatically considers paths specified in the C environment -as this is included in I<@INC> by the Perl interpreter itself. - -=back - -=cut - -# return a hash of the POD files found -# first argument may be a hashref (options), -# rest is a list of directories to search recursively -sub pod_find -{ - my %opts; - if(ref $_[0]) { - %opts = %{shift()}; - } - - $opts{-verbose} ||= 0; - $opts{-perl} ||= 0; - - my (@search) = @_; - - if($opts{-script}) { - require Config; - push(@search, $Config::Config{scriptdir}) - if -d $Config::Config{scriptdir}; - $opts{-perl} = 1; - } - - if($opts{-inc}) { - if ($^O eq 'MacOS') { - # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS - my @new_INC = @INC; - for (@new_INC) { - if ( $_ eq '.' ) { - $_ = ':'; - } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { - $_ = ':'. $_; - } else { - $_ =~ s{^\./}{:}; - } - } - push(@search, grep($_ ne File::Spec->curdir, @new_INC)); - } else { - my %seen; - my $curdir = File::Spec->curdir; - foreach(@INC) { - next if $_ eq $curdir; - my $path = abs_path($_); - push(@search, $path) unless $seen{$path}++; - } - } - - $opts{-perl} = 1; - } - - if($opts{-perl}) { - require Config; - # this code simplifies the POD name for Perl modules: - # * remove "site_perl" - # * remove e.g. "i586-linux" (from 'archname') - # * remove e.g. 5.00503 - # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) - - # Mac OS: - # * remove ":?site_perl:" - # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod) - - if ($^O eq 'MacOS') { - $SIMPLIFY_RX = - qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!; - } else { - $SIMPLIFY_RX = - qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; - } - } - - my %dirs_visited; - my %pods; - my %names; - my $pwd = cwd(); - - foreach my $try (@search) { - unless(File::Spec->file_name_is_absolute($try)) { - # make path absolute - $try = File::Spec->catfile($pwd,$try); - } - # simplify path - # on VMS canonpath will vmsify:[the.path], but File::Find::find - # wants /unixy/paths - if ($^O eq 'VMS') { - $try = VMS::Filespec::unixify($try); - } - else { - $try = File::Spec->canonpath($try); - } - my $name; - if(-f $try) { - if($name = _check_and_extract_name($try, $opts{-verbose})) { - _check_for_duplicates($try, $name, \%names, \%pods); - } - next; - } - my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!; - $root_rx=~ s|//$|/|; # remove trailing double slash - File::Find::find( sub { - my $item = $File::Find::name; - if(-d) { - if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) { - $File::Find::prune = 1; - return; - } - elsif($dirs_visited{$item}) { - warn "Directory '$item' already seen, skipping.\n" - if($opts{-verbose}); - $File::Find::prune = 1; - return; - } - else { - $dirs_visited{$item} = 1; - } - if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { - $File::Find::prune = 1; - warn "Perl $] version mismatch on $_, skipping.\n" - if($opts{-verbose}); - } - return; - } - if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { - _check_for_duplicates($item, $name, \%names, \%pods); - } - }, $try); # end of File::Find::find - } - chdir $pwd; - return %pods; -} - -sub _check_for_duplicates { - my ($file, $name, $names_ref, $pods_ref) = @_; - if($$names_ref{$name}) { - warn "Duplicate POD found (shadowing?): $name ($file)\n"; - warn ' Already seen in ', - join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; - } - else { - $$names_ref{$name} = 1; - } - return $$pods_ref{$file} = $name; -} - -sub _check_and_extract_name { - my ($file, $verbose, $root_rx) = @_; - - # check extension or executable flag - # this involves testing the .bat extension on Win32! - unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { - return; - } - - return unless contains_pod($file,$verbose); - - # strip non-significant path components - # TODO what happens on e.g. Win32? - my $name = $file; - if(defined $root_rx) { - $name =~ s/$root_rx//is; - $name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX); - } - else { - if ($^O eq 'MacOS') { - $name =~ s/^.*://s; - } else { - $name =~ s{^.*/}{}s; - } - } - _simplify($name); - $name =~ s{/+}{::}g; - if ($^O eq 'MacOS') { - $name =~ s{:+}{::}g; # : -> :: - } else { - $name =~ s{/+}{::}g; # / -> :: - } - return $name; -} - -=head2 C - -The function B is equivalent to B, but also -strips Perl-like extensions (.pm, .pl, .pod) and extensions like -F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. - -=cut - -# basic simplification of the POD name: -# basename & strip extension -sub simplify_name { - my ($str) = @_; - # remove all path components - if ($^O eq 'MacOS') { - $str =~ s/^.*://s; - } else { - $str =~ s{^.*/}{}s; - } - _simplify($str); - return $str; -} - -# internal sub only -sub _simplify { - # strip Perl's own extensions - $_[0] =~ s/\.(pod|pm|plx?)\z//i; - # strip meaningless extensions on Win32 and OS/2 - $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); - # strip meaningless extensions on VMS - $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); -} - -# contribution from Tim Jenness - -=head2 C - -Returns the location of a pod document given a search directory -and a module (e.g. C) or script (e.g. C) name. - -Options: - -=over 4 - -=item C<-inc =E 1> - -Search @INC for the pod and also the C defined in the -L module. - -=item C<-dirs =E [ $dir1, $dir2, ... ]> - -Reference to an array of search directories. These are searched in order -before looking in C<@INC> (if B<-inc>). Current directory is used if -none are specified. - -=item C<-verbose =E 1> - -List directories as they are searched - -=back - -Returns the full path of the first occurrence to the file. -Package names (eg 'A::B') are automatically converted to directory -names in the selected directory. (eg on unix 'A::B' is converted to -'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the -search automatically if required. - -A subdirectory F is also checked if it exists in any of the given -search directories. This ensures that e.g. L is -found. - -It is assumed that if a module name is supplied, that that name -matches the file name. Pods are not opened to check for the 'NAME' -entry. - -A check is made to make sure that the file that is found does -contain some pod documentation. - -=cut - -sub pod_where { - - # default options - my %options = ( - '-inc' => 0, - '-verbose' => 0, - '-dirs' => [ File::Spec->curdir ], - ); - - # Check for an options hash as first argument - if (defined $_[0] && ref($_[0]) eq 'HASH') { - my $opt = shift; - - # Merge default options with supplied options - %options = (%options, %$opt); - } - - # Check usage - carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); - - # Read argument - my $pod = shift; - - # Split on :: and then join the name together using File::Spec - my @parts = split (/::/, $pod); - - # Get full directory list - my @search_dirs = @{ $options{'-dirs'} }; - - if ($options{'-inc'}) { - - require Config; - - # Add @INC - if ($^O eq 'MacOS' && $options{'-inc'}) { - # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS - my @new_INC = @INC; - for (@new_INC) { - if ( $_ eq '.' ) { - $_ = ':'; - } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { - $_ = ':'. $_; - } else { - $_ =~ s{^\./}{:}; - } - } - push (@search_dirs, @new_INC); - } elsif ($options{'-inc'}) { - push (@search_dirs, @INC); - } - - # Add location of pod documentation for perl man pages (eg perlfunc) - # This is a pod directory in the private install tree - #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, - # 'pod'); - #push (@search_dirs, $perlpoddir) - # if -d $perlpoddir; - - # Add location of binaries such as pod2text - push (@search_dirs, $Config::Config{'scriptdir'}) - if -d $Config::Config{'scriptdir'}; - } - - warn 'Search path is: '.join(' ', @search_dirs)."\n" - if $options{'-verbose'}; - - # Loop over directories - Dir: foreach my $dir ( @search_dirs ) { - - # Don't bother if can't find the directory - if (-d $dir) { - warn "Looking in directory $dir\n" - if $options{'-verbose'}; - - # Now concatenate this directory with the pod we are searching for - my $fullname = File::Spec->catfile($dir, @parts); - $fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS'; - warn "Filename is now $fullname\n" - if $options{'-verbose'}; - - # Loop over possible extensions - foreach my $ext ('', '.pod', '.pm', '.pl') { - my $fullext = $fullname . $ext; - if (-f $fullext && - contains_pod($fullext, $options{'-verbose'}) ) { - warn "FOUND: $fullext\n" if $options{'-verbose'}; - return $fullext; - } - } - } else { - warn "Directory $dir does not exist\n" - if $options{'-verbose'}; - next Dir; - } - # for some strange reason the path on MacOS/darwin/cygwin is - # 'pods' not 'pod' - # this could be the case also for other systems that - # have a case-tolerant file system, but File::Spec - # does not recognize 'darwin' yet. And cygwin also has "pods", - # but is not case tolerant. Oh well... - if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i) - && -d File::Spec->catdir($dir,'pods')) { - $dir = File::Spec->catdir($dir,'pods'); - redo Dir; - } - if(-d File::Spec->catdir($dir,'pod')) { - $dir = File::Spec->catdir($dir,'pod'); - redo Dir; - } - } - # No match; - return; -} - -=head2 C - -Returns true if the supplied filename (not POD module) contains some pod -information. - -=cut - -sub contains_pod { - my $file = shift; - my $verbose = 0; - $verbose = shift if @_; - - # check for one line of POD - my $podfh; - if ($] < 5.006) { - $podfh = gensym(); - } - - unless(open($podfh,"<$file")) { - warn "Error: $file is unreadable: $!\n"; - return; - } - - local $/ = undef; - my $pod = <$podfh>; - close($podfh) || die "Error closing $file: $!\n"; - unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) { - warn "No POD in $file, skipping.\n" - if($verbose); - return 0; - } - - return 1; -} - -=head1 AUTHOR - -Please report bugs using L. - -Marek Rouchal Emarekr@cpan.orgE, -heavily borrowing code from Nick Ing-Simmons' PodToHtml. - -Tim Jenness Et.jenness@jach.hawaii.eduE provided -C and C. - -B is part of the L distribution. - -=head1 SEE ALSO - -L, L, L - -=cut - -1; - +############################################################################# +# Pod/Find.pm -- finds files containing POD documentation +# +# Author: Marek Rouchal +# +# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code +# from Nick Ing-Simmon's PodToHtml). All rights reserved. +# This file is part of "PodParser". Pod::Find is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Find; +use strict; + +use vars qw($VERSION); +$VERSION = '1.60'; ## Current version of this package +require 5.005; ## requires this Perl version or later +use Carp; + +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} + +############################################################################# + +=head1 NAME + +Pod::Find - find POD documents in directory trees + +=head1 SYNOPSIS + + use Pod::Find qw(pod_find simplify_name); + my %pods = pod_find({ -verbose => 1, -inc => 1 }); + foreach(keys %pods) { + print "found library POD `$pods{$_}' in $_\n"; + } + + print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; + + $location = pod_where( { -inc => 1 }, "Pod::Find" ); + +=head1 DESCRIPTION + +B provides a set of functions to locate POD files. Note that +no function is exported by default to avoid pollution of your namespace, +so be sure to specify them in the B statement if you need them: + + use Pod::Find qw(pod_find); + +From this version on the typical SCM (software configuration management) +files/directories like RCS, CVS, SCCS, .svn are ignored. + +=cut + +#use diagnostics; +use Exporter; +use File::Spec; +use File::Find; +use Cwd qw(abs_path cwd); + +use vars qw(@ISA @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); + +# package global variables +my $SIMPLIFY_RX; + +=head2 C + +The function B searches for POD documents in a given set of +files and/or directories. It returns a hash with the file names as keys +and the POD name as value. The POD name is derived from the file name +and its position in the directory tree. + +E.g. when searching in F<$HOME/perl5lib>, the file +F<$HOME/perl5lib/MyModule.pm> would get the POD name I, +whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be +I. The name information can be used for POD +translators. + +Only text files containing at least one valid POD command are found. + +A warning is printed if more than one POD file with the same POD name +is found, e.g. F in different directories. This usually +indicates duplicate occurrences of modules in the I<@INC> search path. + +B The first argument for B may be a hash reference +with options. The rest are either directories that are searched +recursively or files. The POD names of files are the plain basenames +with any Perl-like extension (.pm, .pl, .pod) stripped. + +=over 4 + +=item C<-verbose =E 1> + +Print progress information while scanning. + +=item C<-perl =E 1> + +Apply Perl-specific heuristics to find the correct PODs. This includes +stripping Perl-like extensions, omitting subdirectories that are numeric +but do I match the current Perl interpreter's version id, suppressing +F as a module hierarchy name etc. + +=item C<-script =E 1> + +Search for PODs in the current Perl interpreter's installation +B. This is taken from the local L module. + +=item C<-inc =E 1> + +Search for PODs in the current Perl interpreter's I<@INC> paths. This +automatically considers paths specified in the C environment +as this is included in I<@INC> by the Perl interpreter itself. + +=back + +=cut + +# return a hash of the POD files found +# first argument may be a hashref (options), +# rest is a list of directories to search recursively +sub pod_find +{ + my %opts; + if(ref $_[0]) { + %opts = %{shift()}; + } + + $opts{-verbose} ||= 0; + $opts{-perl} ||= 0; + + my (@search) = @_; + + if($opts{-script}) { + require Config; + push(@search, $Config::Config{scriptdir}) + if -d $Config::Config{scriptdir}; + $opts{-perl} = 1; + } + + if($opts{-inc}) { + if ($^O eq 'MacOS') { + # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @new_INC = @INC; + for (@new_INC) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { + $_ = ':'. $_; + } else { + $_ =~ s{^\./}{:}; + } + } + push(@search, grep($_ ne File::Spec->curdir, @new_INC)); + } else { + my %seen; + my $curdir = File::Spec->curdir; + foreach(@INC) { + next if $_ eq $curdir; + my $path = abs_path($_); + push(@search, $path) unless $seen{$path}++; + } + } + + $opts{-perl} = 1; + } + + if($opts{-perl}) { + require Config; + # this code simplifies the POD name for Perl modules: + # * remove "site_perl" + # * remove e.g. "i586-linux" (from 'archname') + # * remove e.g. 5.00503 + # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) + + # Mac OS: + # * remove ":?site_perl:" + # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod) + + if ($^O eq 'MacOS') { + $SIMPLIFY_RX = + qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!; + } else { + $SIMPLIFY_RX = + qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; + } + } + + my %dirs_visited; + my %pods; + my %names; + my $pwd = cwd(); + + foreach my $try (@search) { + unless(File::Spec->file_name_is_absolute($try)) { + # make path absolute + $try = File::Spec->catfile($pwd,$try); + } + # simplify path + # on VMS canonpath will vmsify:[the.path], but File::Find::find + # wants /unixy/paths + if ($^O eq 'VMS') { + $try = VMS::Filespec::unixify($try); + } + else { + $try = File::Spec->canonpath($try); + } + my $name; + if(-f $try) { + if($name = _check_and_extract_name($try, $opts{-verbose})) { + _check_for_duplicates($try, $name, \%names, \%pods); + } + next; + } + my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!; + $root_rx=~ s|//$|/|; # remove trailing double slash + File::Find::find( sub { + my $item = $File::Find::name; + if(-d) { + if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) { + $File::Find::prune = 1; + return; + } + elsif($dirs_visited{$item}) { + warn "Directory '$item' already seen, skipping.\n" + if($opts{-verbose}); + $File::Find::prune = 1; + return; + } + else { + $dirs_visited{$item} = 1; + } + if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { + $File::Find::prune = 1; + warn "Perl $] version mismatch on $_, skipping.\n" + if($opts{-verbose}); + } + return; + } + if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { + _check_for_duplicates($item, $name, \%names, \%pods); + } + }, $try); # end of File::Find::find + } + chdir $pwd; + return %pods; +} + +sub _check_for_duplicates { + my ($file, $name, $names_ref, $pods_ref) = @_; + if($$names_ref{$name}) { + warn "Duplicate POD found (shadowing?): $name ($file)\n"; + warn ' Already seen in ', + join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; + } + else { + $$names_ref{$name} = 1; + } + return $$pods_ref{$file} = $name; +} + +sub _check_and_extract_name { + my ($file, $verbose, $root_rx) = @_; + + # check extension or executable flag + # this involves testing the .bat extension on Win32! + unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { + return; + } + + return unless contains_pod($file,$verbose); + + # strip non-significant path components + # TODO what happens on e.g. Win32? + my $name = $file; + if(defined $root_rx) { + $name =~ s/$root_rx//is; + $name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX); + } + else { + if ($^O eq 'MacOS') { + $name =~ s/^.*://s; + } else { + $name =~ s{^.*/}{}s; + } + } + _simplify($name); + $name =~ s{/+}{::}g; + if ($^O eq 'MacOS') { + $name =~ s{:+}{::}g; # : -> :: + } else { + $name =~ s{/+}{::}g; # / -> :: + } + return $name; +} + +=head2 C + +The function B is equivalent to B, but also +strips Perl-like extensions (.pm, .pl, .pod) and extensions like +F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. + +=cut + +# basic simplification of the POD name: +# basename & strip extension +sub simplify_name { + my ($str) = @_; + # remove all path components + if ($^O eq 'MacOS') { + $str =~ s/^.*://s; + } else { + $str =~ s{^.*/}{}s; + } + _simplify($str); + return $str; +} + +# internal sub only +sub _simplify { + # strip Perl's own extensions + $_[0] =~ s/\.(pod|pm|plx?)\z//i; + # strip meaningless extensions on Win32 and OS/2 + $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); + # strip meaningless extensions on VMS + $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); +} + +# contribution from Tim Jenness + +=head2 C + +Returns the location of a pod document given a search directory +and a module (e.g. C) or script (e.g. C) name. + +Options: + +=over 4 + +=item C<-inc =E 1> + +Search @INC for the pod and also the C defined in the +L module. + +=item C<-dirs =E [ $dir1, $dir2, ... ]> + +Reference to an array of search directories. These are searched in order +before looking in C<@INC> (if B<-inc>). Current directory is used if +none are specified. + +=item C<-verbose =E 1> + +List directories as they are searched + +=back + +Returns the full path of the first occurrence to the file. +Package names (eg 'A::B') are automatically converted to directory +names in the selected directory. (eg on unix 'A::B' is converted to +'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the +search automatically if required. + +A subdirectory F is also checked if it exists in any of the given +search directories. This ensures that e.g. L is +found. + +It is assumed that if a module name is supplied, that that name +matches the file name. Pods are not opened to check for the 'NAME' +entry. + +A check is made to make sure that the file that is found does +contain some pod documentation. + +=cut + +sub pod_where { + + # default options + my %options = ( + '-inc' => 0, + '-verbose' => 0, + '-dirs' => [ File::Spec->curdir ], + ); + + # Check for an options hash as first argument + if (defined $_[0] && ref($_[0]) eq 'HASH') { + my $opt = shift; + + # Merge default options with supplied options + %options = (%options, %$opt); + } + + # Check usage + carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); + + # Read argument + my $pod = shift; + + # Split on :: and then join the name together using File::Spec + my @parts = split (/::/, $pod); + + # Get full directory list + my @search_dirs = @{ $options{'-dirs'} }; + + if ($options{'-inc'}) { + + require Config; + + # Add @INC + if ($^O eq 'MacOS' && $options{'-inc'}) { + # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @new_INC = @INC; + for (@new_INC) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { + $_ = ':'. $_; + } else { + $_ =~ s{^\./}{:}; + } + } + push (@search_dirs, @new_INC); + } elsif ($options{'-inc'}) { + push (@search_dirs, @INC); + } + + # Add location of pod documentation for perl man pages (eg perlfunc) + # This is a pod directory in the private install tree + #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, + # 'pod'); + #push (@search_dirs, $perlpoddir) + # if -d $perlpoddir; + + # Add location of binaries such as pod2text + push (@search_dirs, $Config::Config{'scriptdir'}) + if -d $Config::Config{'scriptdir'}; + } + + warn 'Search path is: '.join(' ', @search_dirs)."\n" + if $options{'-verbose'}; + + # Loop over directories + Dir: foreach my $dir ( @search_dirs ) { + + # Don't bother if can't find the directory + if (-d $dir) { + warn "Looking in directory $dir\n" + if $options{'-verbose'}; + + # Now concatenate this directory with the pod we are searching for + my $fullname = File::Spec->catfile($dir, @parts); + $fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS'; + warn "Filename is now $fullname\n" + if $options{'-verbose'}; + + # Loop over possible extensions + foreach my $ext ('', '.pod', '.pm', '.pl') { + my $fullext = $fullname . $ext; + if (-f $fullext && + contains_pod($fullext, $options{'-verbose'}) ) { + warn "FOUND: $fullext\n" if $options{'-verbose'}; + return $fullext; + } + } + } else { + warn "Directory $dir does not exist\n" + if $options{'-verbose'}; + next Dir; + } + # for some strange reason the path on MacOS/darwin/cygwin is + # 'pods' not 'pod' + # this could be the case also for other systems that + # have a case-tolerant file system, but File::Spec + # does not recognize 'darwin' yet. And cygwin also has "pods", + # but is not case tolerant. Oh well... + if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i) + && -d File::Spec->catdir($dir,'pods')) { + $dir = File::Spec->catdir($dir,'pods'); + redo Dir; + } + if(-d File::Spec->catdir($dir,'pod')) { + $dir = File::Spec->catdir($dir,'pod'); + redo Dir; + } + } + # No match; + return; +} + +=head2 C + +Returns true if the supplied filename (not POD module) contains some pod +information. + +=cut + +sub contains_pod { + my $file = shift; + my $verbose = 0; + $verbose = shift if @_; + + # check for one line of POD + my $podfh; + if ($] < 5.006) { + $podfh = gensym(); + } + + unless(open($podfh,"<$file")) { + warn "Error: $file is unreadable: $!\n"; + return; + } + + local $/ = undef; + my $pod = <$podfh>; + close($podfh) || die "Error closing $file: $!\n"; + unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) { + warn "No POD in $file, skipping.\n" + if($verbose); + return 0; + } + + return 1; +} + +=head1 AUTHOR + +Please report bugs using L. + +Marek Rouchal Emarekr@cpan.orgE, +heavily borrowing code from Nick Ing-Simmons' PodToHtml. + +Tim Jenness Et.jenness@jach.hawaii.eduE provided +C and C. + +B is part of the L distribution. + +=head1 SEE ALSO + +L, L, L + +=cut + +1; + diff --git a/cpan/Pod-Parser/lib/Pod/InputObjects.pm b/cpan/Pod-Parser/lib/Pod/InputObjects.pm index 2ed71fa255..c19d4c550b 100644 --- a/cpan/Pod-Parser/lib/Pod/InputObjects.pm +++ b/cpan/Pod-Parser/lib/Pod/InputObjects.pm @@ -1,942 +1,942 @@ -############################################################################# -# Pod/InputObjects.pm -- package which defines objects for input streams -# and paragraphs and commands when parsing POD docs. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::InputObjects; -use strict; - -use vars qw($VERSION); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::InputObjects - objects representing POD input paragraphs, commands, etc. - -=head1 SYNOPSIS - - use Pod::InputObjects; - -=head1 REQUIRES - -perl5.004, Carp - -=head1 EXPORTS - -Nothing. - -=head1 DESCRIPTION - -This module defines some basic input objects used by B when -reading and parsing POD text from an input source. The following objects -are defined: - -=begin __PRIVATE__ - -=over 4 - -=item package B - -An object corresponding to a source of POD input text. It is mostly a -wrapper around a filehandle or C-type object (or anything -that implements the C method) which keeps track of some -additional information relevant to the parsing of PODs. - -=back - -=end __PRIVATE__ - -=over 4 - -=item package B - -An object corresponding to a paragraph of POD input text. It may be a -plain paragraph, a verbatim paragraph, or a command paragraph (see -L). - -=item package B - -An object corresponding to an interior sequence command from the POD -input text (see L). - -=item package B - -An object corresponding to a tree of parsed POD text. Each "node" in -a parse-tree (or I) is either a text-string or a reference to -a B object. The nodes appear in the parse-tree -in the order in which they were parsed from left-to-right. - -=back - -Each of these input objects are described in further detail in the -sections which follow. - -=cut - -############################################################################# - -package Pod::InputSource; - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B - -This object corresponds to an input source or stream of POD -documentation. When parsing PODs, it is necessary to associate and store -certain context information with each input source. All of this -information is kept together with the stream itself in one of these -C objects. Each such object is merely a wrapper around -an C object of some kind (or at least something that -implements the C method). They have the following -methods/attributes: - -=end __PRIVATE__ - -=cut - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B - - my $pod_input1 = Pod::InputSource->new(-handle => $filehandle); - my $pod_input2 = new Pod::InputSource(-handle => $filehandle, - -name => $name); - my $pod_input3 = new Pod::InputSource(-handle => \*STDIN); - my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN, - -name => "(STDIN)"); - -This is a class method that constructs a C object and -returns a reference to the new input source object. It takes one or more -keyword arguments in the form of a hash. The keyword C<-handle> is -required and designates the corresponding input handle. The keyword -C<-name> is optional and specifies the name associated with the input -handle (typically a file name). - -=end __PRIVATE__ - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { -name => '(unknown)', - -handle => undef, - -was_cutting => 0, - @_ }; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B - - my $filename = $pod_input->name(); - $pod_input->name($new_filename_to_use); - -This method gets/sets the name of the input source (usually a filename). -If no argument is given, it returns a string containing the name of -the input source; otherwise it sets the name of the input source to the -contents of the given argument. - -=end __PRIVATE__ - -=cut - -sub name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## allow 'filename' as an alias for 'name' -*filename = \&name; - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B - - my $handle = $pod_input->handle(); - -Returns a reference to the handle object from which input is read (the -one used to contructed this input source object). - -=end __PRIVATE__ - -=cut - -sub handle { - return $_[0]->{'-handle'}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B - - print "Yes.\n" if ($pod_input->was_cutting()); - -The value of the C state (that the B method would -have returned) immediately before any input was read from this input -stream. After all input from this stream has been read, the C -state is restored to this value. - -=end __PRIVATE__ - -=cut - -sub was_cutting { - (@_ > 1) and $_[0]->{-was_cutting} = $_[1]; - return $_[0]->{-was_cutting}; -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::Paragraph; - -##--------------------------------------------------------------------------- - -=head1 B - -An object representing a paragraph of POD input text. -It has the following methods/attributes: - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::Paragraph-EB - - my $pod_para1 = Pod::Paragraph->new(-text => $text); - my $pod_para2 = Pod::Paragraph->new(-name => $cmd, - -text => $text); - my $pod_para3 = new Pod::Paragraph(-text => $text); - my $pod_para4 = new Pod::Paragraph(-name => $cmd, - -text => $text); - my $pod_para5 = Pod::Paragraph->new(-name => $cmd, - -text => $text, - -file => $filename, - -line => $line_number); - -This is a class method that constructs a C object and -returns a reference to the new paragraph object. It may be given one or -two keyword arguments. The C<-text> keyword indicates the corresponding -text of the POD paragraph. The C<-name> keyword indicates the name of -the corresponding POD command, such as C or C (it should -I contain the C<=> prefix); this is needed only if the POD -paragraph corresponds to a command paragraph. The C<-file> and C<-line> -keywords indicate the filename and line number corresponding to the -beginning of the paragraph - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { - -name => undef, - -text => (@_ == 1) ? shift : undef, - -file => '', - -line => 0, - -prefix => '=', - -separator => ' ', - -ptree => [], - @_ - }; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my $para_cmd = $pod_para->cmd_name(); - -If this paragraph is a command paragraph, then this method will return -the name of the command (I any leading C<=> prefix). - -=cut - -sub cmd_name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## let name() be an alias for cmd_name() -*name = \&cmd_name; - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my $para_text = $pod_para->text(); - -This method will return the corresponding text of the paragraph. - -=cut - -sub text { - (@_ > 1) and $_[0]->{'-text'} = $_[1]; - return $_[0]->{'-text'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my $raw_pod_para = $pod_para->raw_text(); - -This method will return the I text of the POD paragraph, exactly -as it appeared in the input. - -=cut - -sub raw_text { - return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); - return $_[0]->{'-prefix'} . $_[0]->{'-name'} . - $_[0]->{'-separator'} . $_[0]->{'-text'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my $prefix = $pod_para->cmd_prefix(); - -If this paragraph is a command paragraph, then this method will return -the prefix used to denote the command (which should be the string "=" -or "=="). - -=cut - -sub cmd_prefix { - return $_[0]->{'-prefix'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my $separator = $pod_para->cmd_separator(); - -If this paragraph is a command paragraph, then this method will return -the text used to separate the command name from the rest of the -paragraph (if any). - -=cut - -sub cmd_separator { - return $_[0]->{'-separator'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my $ptree = $pod_parser->parse_text( $pod_para->text() ); - $pod_para->parse_tree( $ptree ); - $ptree = $pod_para->parse_tree(); - -This method will get/set the corresponding parse-tree of the paragraph's text. - -=cut - -sub parse_tree { - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; -} - -## let ptree() be an alias for parse_tree() -*ptree = \&parse_tree; - -##--------------------------------------------------------------------------- - -=head2 $pod_para-EB - - my ($filename, $line_number) = $pod_para->file_line(); - my $position = $pod_para->file_line(); - -Returns the current filename and line number for the paragraph -object. If called in a list context, it returns a list of two -elements: first the filename, then the line number. If called in -a scalar context, it returns a string containing the filename, followed -by a colon (':'), followed by the line number. - -=cut - -sub file_line { - my @loc = ($_[0]->{'-file'} || '', - $_[0]->{'-line'} || 0); - return (wantarray) ? @loc : join(':', @loc); -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::InteriorSequence; - -##--------------------------------------------------------------------------- - -=head1 B - -An object representing a POD interior sequence command. -It has the following methods/attributes: - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::InteriorSequence-EB - - my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd - -ldelim => $delimiter); - my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd, - -ldelim => $delimiter); - my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd, - -ldelim => $delimiter, - -file => $filename, - -line => $line_number); - - my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree); - my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree); - -This is a class method that constructs a C object -and returns a reference to the new interior sequence object. It should -be given two keyword arguments. The C<-ldelim> keyword indicates the -corresponding left-delimiter of the interior sequence (e.g. 'E'). -The C<-name> keyword indicates the name of the corresponding interior -sequence command, such as C or C or C. The C<-file> and -C<-line> keywords indicate the filename and line number corresponding -to the beginning of the interior sequence. If the C<$ptree> argument is -given, it must be the last argument, and it must be either string, or -else an array-ref suitable for passing to B (or -it may be a reference to a Pod::ParseTree object). - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## See if first argument has no keyword - if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) { - ## Yup - need an implicit '-name' before first parameter - unshift @_, '-name'; - } - - ## See if odd number of args - if ((@_ % 2) != 0) { - ## Yup - need an implicit '-ptree' before the last parameter - splice @_, $#_, 0, '-ptree'; - } - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { - -name => (@_ == 1) ? $_[0] : undef, - -file => '', - -line => 0, - -ldelim => '<', - -rdelim => '>', - @_ - }; - - ## Initialize contents if they havent been already - my $ptree = $self->{'-ptree'} || new Pod::ParseTree(); - if ( ref $ptree =~ /^(ARRAY)?$/ ) { - ## We have an array-ref, or a normal scalar. Pass it as an - ## an argument to the ptree-constructor - $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree); - } - $self->{'-ptree'} = $ptree; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - my $seq_cmd = $pod_seq->cmd_name(); - -The name of the interior sequence command. - -=cut - -sub cmd_name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## let name() be an alias for cmd_name() -*name = \&cmd_name; - -##--------------------------------------------------------------------------- - -## Private subroutine to set the parent pointer of all the given -## children that are interior-sequences to be $self - -sub _set_child2parent_links { - my ($self, @children) = @_; - ## Make sure any sequences know who their parent is - for (@children) { - next unless (length and ref and ref ne 'SCALAR'); - if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or - UNIVERSAL::can($_, 'nested')) - { - $_->nested($self); - } - } -} - -## Private subroutine to unset child->parent links - -sub _unset_child2parent_links { - my $self = shift; - $self->{'-parent_sequence'} = undef; - my $ptree = $self->{'-ptree'}; - for (@$ptree) { - next unless (length and ref and ref ne 'SCALAR'); - $_->_unset_child2parent_links() - if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); - } -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - $pod_seq->prepend($text); - $pod_seq1->prepend($pod_seq2); - -Prepends the given string or parse-tree or sequence object to the parse-tree -of this interior sequence. - -=cut - -sub prepend { - my $self = shift; - $self->{'-ptree'}->prepend(@_); - _set_child2parent_links($self, @_); - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - $pod_seq->append($text); - $pod_seq1->append($pod_seq2); - -Appends the given string or parse-tree or sequence object to the parse-tree -of this interior sequence. - -=cut - -sub append { - my $self = shift; - $self->{'-ptree'}->append(@_); - _set_child2parent_links($self, @_); - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - $outer_seq = $pod_seq->nested || print "not nested"; - -If this interior sequence is nested inside of another interior -sequence, then the outer/parent sequence that contains it is -returned. Otherwise C is returned. - -=cut - -sub nested { - my $self = shift; - (@_ == 1) and $self->{'-parent_sequence'} = shift; - return $self->{'-parent_sequence'} || undef; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - my $seq_raw_text = $pod_seq->raw_text(); - -This method will return the I text of the POD interior sequence, -exactly as it appeared in the input. - -=cut - -sub raw_text { - my $self = shift; - my $text = $self->{'-name'} . $self->{'-ldelim'}; - for ( $self->{'-ptree'}->children ) { - $text .= (ref $_) ? $_->raw_text : $_; - } - $text .= $self->{'-rdelim'}; - return $text; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - my $ldelim = $pod_seq->left_delimiter(); - -The leftmost delimiter beginning the argument text to the interior -sequence (should be "<"). - -=cut - -sub left_delimiter { - (@_ > 1) and $_[0]->{'-ldelim'} = $_[1]; - return $_[0]->{'-ldelim'}; -} - -## let ldelim() be an alias for left_delimiter() -*ldelim = \&left_delimiter; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - -The rightmost delimiter beginning the argument text to the interior -sequence (should be ">"). - -=cut - -sub right_delimiter { - (@_ > 1) and $_[0]->{'-rdelim'} = $_[1]; - return $_[0]->{'-rdelim'}; -} - -## let rdelim() be an alias for right_delimiter() -*rdelim = \&right_delimiter; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - my $ptree = $pod_parser->parse_text($paragraph_text); - $pod_seq->parse_tree( $ptree ); - $ptree = $pod_seq->parse_tree(); - -This method will get/set the corresponding parse-tree of the interior -sequence's text. - -=cut - -sub parse_tree { - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; -} - -## let ptree() be an alias for parse_tree() -*ptree = \&parse_tree; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-EB - - my ($filename, $line_number) = $pod_seq->file_line(); - my $position = $pod_seq->file_line(); - -Returns the current filename and line number for the interior sequence -object. If called in a list context, it returns a list of two -elements: first the filename, then the line number. If called in -a scalar context, it returns a string containing the filename, followed -by a colon (':'), followed by the line number. - -=cut - -sub file_line { - my @loc = ($_[0]->{'-file'} || '', - $_[0]->{'-line'} || 0); - return (wantarray) ? @loc : join(':', @loc); -} - -##--------------------------------------------------------------------------- - -=head2 Pod::InteriorSequence::B - -This method performs any necessary cleanup for the interior-sequence. -If you override this method then it is B that you invoke -the parent method from within your own method, otherwise -I - -=cut - -sub DESTROY { - ## We need to get rid of all child->parent pointers throughout the - ## tree so their reference counts will go to zero and they can be - ## garbage-collected - _unset_child2parent_links(@_); -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::ParseTree; - -##--------------------------------------------------------------------------- - -=head1 B - -This object corresponds to a tree of parsed POD text. As POD text is -scanned from left to right, it is parsed into an ordered list of -text-strings and B objects (in order of -appearance). A B object corresponds to this list of -strings and sequences. Each interior sequence in the parse-tree may -itself contain a parse-tree (since interior sequences may be nested). - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::ParseTree-EB - - my $ptree1 = Pod::ParseTree->new; - my $ptree2 = new Pod::ParseTree; - my $ptree4 = Pod::ParseTree->new($array_ref); - my $ptree3 = new Pod::ParseTree($array_ref); - -This is a class method that constructs a C object and -returns a reference to the new parse-tree. If a single-argument is given, -it must be a reference to an array, and is used to initialize the root -(top) of the parse tree. - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - my $self = (@_ == 1 and ref $_[0]) ? $_[0] : []; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-EB - - my $top_node = $ptree->top(); - $ptree->top( $top_node ); - $ptree->top( @children ); - -This method gets/sets the top node of the parse-tree. If no arguments are -given, it returns the topmost node in the tree (the root), which is also -a B. If it is given a single argument that is a reference, -then the reference is assumed to a parse-tree and becomes the new top node. -Otherwise, if arguments are given, they are treated as the new list of -children for the top node. - -=cut - -sub top { - my $self = shift; - if (@_ > 0) { - @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; - } - return $self; -} - -## let parse_tree() & ptree() be aliases for the 'top' method -*parse_tree = *ptree = \⊤ - -##--------------------------------------------------------------------------- - -=head2 $ptree-EB - -This method gets/sets the children of the top node in the parse-tree. -If no arguments are given, it returns the list (array) of children -(each of which should be either a string or a B. -Otherwise, if arguments are given, they are treated as the new list of -children for the top node. - -=cut - -sub children { - my $self = shift; - if (@_ > 0) { - @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; - } - return @{ $self }; -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-EB - -This method prepends the given text or parse-tree to the current parse-tree. -If the first item on the parse-tree is text and the argument is also text, -then the text is prepended to the first item (not added as a separate string). -Otherwise the argument is added as a new string or parse-tree I -the current one. - -=cut - -use vars qw(@ptree); ## an alias used for performance reasons - -sub prepend { - my $self = shift; - local *ptree = $self; - for (@_) { - next unless length; - if (@ptree && !(ref $ptree[0]) && !(ref $_)) { - $ptree[0] = $_ . $ptree[0]; - } - else { - unshift @ptree, $_; - } - } -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-EB - -This method appends the given text or parse-tree to the current parse-tree. -If the last item on the parse-tree is text and the argument is also text, -then the text is appended to the last item (not added as a separate string). -Otherwise the argument is added as a new string or parse-tree I -the current one. - -=cut - -sub append { - my $self = shift; - local *ptree = $self; - my $can_append = @ptree && !(ref $ptree[-1]); - for (@_) { - if (ref) { - push @ptree, $_; - } - elsif(!length) { - next; - } - elsif ($can_append) { - $ptree[-1] .= $_; - } - else { - push @ptree, $_; - } - } -} - -=head2 $ptree-EB - - my $ptree_raw_text = $ptree->raw_text(); - -This method will return the I text of the POD parse-tree -exactly as it appeared in the input. - -=cut - -sub raw_text { - my $self = shift; - my $text = ''; - for ( @$self ) { - $text .= (ref $_) ? $_->raw_text : $_; - } - return $text; -} - -##--------------------------------------------------------------------------- - -## Private routines to set/unset child->parent links - -sub _unset_child2parent_links { - my $self = shift; - local *ptree = $self; - for (@ptree) { - next unless (defined and length and ref and ref ne 'SCALAR'); - $_->_unset_child2parent_links() - if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); - } -} - -sub _set_child2parent_links { - ## nothing to do, Pod::ParseTrees cant have parent pointers -} - -=head2 Pod::ParseTree::B - -This method performs any necessary cleanup for the parse-tree. -If you override this method then it is B -that you invoke the parent method from within your own method, -otherwise I - -=cut - -sub DESTROY { - ## We need to get rid of all child->parent pointers throughout the - ## tree so their reference counts will go to zero and they can be - ## garbage-collected - _unset_child2parent_links(@_); -} - -############################################################################# - -=head1 SEE ALSO - -B is part of the L distribution. - -See L, L - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -=cut - -1; +############################################################################# +# Pod/InputObjects.pm -- package which defines objects for input streams +# and paragraphs and commands when parsing POD docs. +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::InputObjects; +use strict; + +use vars qw($VERSION); +$VERSION = '1.60'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::InputObjects - objects representing POD input paragraphs, commands, etc. + +=head1 SYNOPSIS + + use Pod::InputObjects; + +=head1 REQUIRES + +perl5.004, Carp + +=head1 EXPORTS + +Nothing. + +=head1 DESCRIPTION + +This module defines some basic input objects used by B when +reading and parsing POD text from an input source. The following objects +are defined: + +=begin __PRIVATE__ + +=over 4 + +=item package B + +An object corresponding to a source of POD input text. It is mostly a +wrapper around a filehandle or C-type object (or anything +that implements the C method) which keeps track of some +additional information relevant to the parsing of PODs. + +=back + +=end __PRIVATE__ + +=over 4 + +=item package B + +An object corresponding to a paragraph of POD input text. It may be a +plain paragraph, a verbatim paragraph, or a command paragraph (see +L). + +=item package B + +An object corresponding to an interior sequence command from the POD +input text (see L). + +=item package B + +An object corresponding to a tree of parsed POD text. Each "node" in +a parse-tree (or I) is either a text-string or a reference to +a B object. The nodes appear in the parse-tree +in the order in which they were parsed from left-to-right. + +=back + +Each of these input objects are described in further detail in the +sections which follow. + +=cut + +############################################################################# + +package Pod::InputSource; + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B + +This object corresponds to an input source or stream of POD +documentation. When parsing PODs, it is necessary to associate and store +certain context information with each input source. All of this +information is kept together with the stream itself in one of these +C objects. Each such object is merely a wrapper around +an C object of some kind (or at least something that +implements the C method). They have the following +methods/attributes: + +=end __PRIVATE__ + +=cut + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B + + my $pod_input1 = Pod::InputSource->new(-handle => $filehandle); + my $pod_input2 = new Pod::InputSource(-handle => $filehandle, + -name => $name); + my $pod_input3 = new Pod::InputSource(-handle => \*STDIN); + my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN, + -name => "(STDIN)"); + +This is a class method that constructs a C object and +returns a reference to the new input source object. It takes one or more +keyword arguments in the form of a hash. The keyword C<-handle> is +required and designates the corresponding input handle. The keyword +C<-name> is optional and specifies the name associated with the input +handle (typically a file name). + +=end __PRIVATE__ + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { -name => '(unknown)', + -handle => undef, + -was_cutting => 0, + @_ }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B + + my $filename = $pod_input->name(); + $pod_input->name($new_filename_to_use); + +This method gets/sets the name of the input source (usually a filename). +If no argument is given, it returns a string containing the name of +the input source; otherwise it sets the name of the input source to the +contents of the given argument. + +=end __PRIVATE__ + +=cut + +sub name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## allow 'filename' as an alias for 'name' +*filename = \&name; + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B + + my $handle = $pod_input->handle(); + +Returns a reference to the handle object from which input is read (the +one used to contructed this input source object). + +=end __PRIVATE__ + +=cut + +sub handle { + return $_[0]->{'-handle'}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B + + print "Yes.\n" if ($pod_input->was_cutting()); + +The value of the C state (that the B method would +have returned) immediately before any input was read from this input +stream. After all input from this stream has been read, the C +state is restored to this value. + +=end __PRIVATE__ + +=cut + +sub was_cutting { + (@_ > 1) and $_[0]->{-was_cutting} = $_[1]; + return $_[0]->{-was_cutting}; +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::Paragraph; + +##--------------------------------------------------------------------------- + +=head1 B + +An object representing a paragraph of POD input text. +It has the following methods/attributes: + +=cut + +##--------------------------------------------------------------------------- + +=head2 Pod::Paragraph-EB + + my $pod_para1 = Pod::Paragraph->new(-text => $text); + my $pod_para2 = Pod::Paragraph->new(-name => $cmd, + -text => $text); + my $pod_para3 = new Pod::Paragraph(-text => $text); + my $pod_para4 = new Pod::Paragraph(-name => $cmd, + -text => $text); + my $pod_para5 = Pod::Paragraph->new(-name => $cmd, + -text => $text, + -file => $filename, + -line => $line_number); + +This is a class method that constructs a C object and +returns a reference to the new paragraph object. It may be given one or +two keyword arguments. The C<-text> keyword indicates the corresponding +text of the POD paragraph. The C<-name> keyword indicates the name of +the corresponding POD command, such as C or C (it should +I contain the C<=> prefix); this is needed only if the POD +paragraph corresponds to a command paragraph. The C<-file> and C<-line> +keywords indicate the filename and line number corresponding to the +beginning of the paragraph + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { + -name => undef, + -text => (@_ == 1) ? shift : undef, + -file => '', + -line => 0, + -prefix => '=', + -separator => ' ', + -ptree => [], + @_ + }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my $para_cmd = $pod_para->cmd_name(); + +If this paragraph is a command paragraph, then this method will return +the name of the command (I any leading C<=> prefix). + +=cut + +sub cmd_name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## let name() be an alias for cmd_name() +*name = \&cmd_name; + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my $para_text = $pod_para->text(); + +This method will return the corresponding text of the paragraph. + +=cut + +sub text { + (@_ > 1) and $_[0]->{'-text'} = $_[1]; + return $_[0]->{'-text'}; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my $raw_pod_para = $pod_para->raw_text(); + +This method will return the I text of the POD paragraph, exactly +as it appeared in the input. + +=cut + +sub raw_text { + return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); + return $_[0]->{'-prefix'} . $_[0]->{'-name'} . + $_[0]->{'-separator'} . $_[0]->{'-text'}; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my $prefix = $pod_para->cmd_prefix(); + +If this paragraph is a command paragraph, then this method will return +the prefix used to denote the command (which should be the string "=" +or "=="). + +=cut + +sub cmd_prefix { + return $_[0]->{'-prefix'}; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my $separator = $pod_para->cmd_separator(); + +If this paragraph is a command paragraph, then this method will return +the text used to separate the command name from the rest of the +paragraph (if any). + +=cut + +sub cmd_separator { + return $_[0]->{'-separator'}; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my $ptree = $pod_parser->parse_text( $pod_para->text() ); + $pod_para->parse_tree( $ptree ); + $ptree = $pod_para->parse_tree(); + +This method will get/set the corresponding parse-tree of the paragraph's text. + +=cut + +sub parse_tree { + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; +} + +## let ptree() be an alias for parse_tree() +*ptree = \&parse_tree; + +##--------------------------------------------------------------------------- + +=head2 $pod_para-EB + + my ($filename, $line_number) = $pod_para->file_line(); + my $position = $pod_para->file_line(); + +Returns the current filename and line number for the paragraph +object. If called in a list context, it returns a list of two +elements: first the filename, then the line number. If called in +a scalar context, it returns a string containing the filename, followed +by a colon (':'), followed by the line number. + +=cut + +sub file_line { + my @loc = ($_[0]->{'-file'} || '', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::InteriorSequence; + +##--------------------------------------------------------------------------- + +=head1 B + +An object representing a POD interior sequence command. +It has the following methods/attributes: + +=cut + +##--------------------------------------------------------------------------- + +=head2 Pod::InteriorSequence-EB + + my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd + -ldelim => $delimiter); + my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd, + -ldelim => $delimiter); + my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd, + -ldelim => $delimiter, + -file => $filename, + -line => $line_number); + + my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree); + my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree); + +This is a class method that constructs a C object +and returns a reference to the new interior sequence object. It should +be given two keyword arguments. The C<-ldelim> keyword indicates the +corresponding left-delimiter of the interior sequence (e.g. 'E'). +The C<-name> keyword indicates the name of the corresponding interior +sequence command, such as C or C or C. The C<-file> and +C<-line> keywords indicate the filename and line number corresponding +to the beginning of the interior sequence. If the C<$ptree> argument is +given, it must be the last argument, and it must be either string, or +else an array-ref suitable for passing to B (or +it may be a reference to a Pod::ParseTree object). + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## See if first argument has no keyword + if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) { + ## Yup - need an implicit '-name' before first parameter + unshift @_, '-name'; + } + + ## See if odd number of args + if ((@_ % 2) != 0) { + ## Yup - need an implicit '-ptree' before the last parameter + splice @_, $#_, 0, '-ptree'; + } + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { + -name => (@_ == 1) ? $_[0] : undef, + -file => '', + -line => 0, + -ldelim => '<', + -rdelim => '>', + @_ + }; + + ## Initialize contents if they havent been already + my $ptree = $self->{'-ptree'} || new Pod::ParseTree(); + if ( ref $ptree =~ /^(ARRAY)?$/ ) { + ## We have an array-ref, or a normal scalar. Pass it as an + ## an argument to the ptree-constructor + $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree); + } + $self->{'-ptree'} = $ptree; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + my $seq_cmd = $pod_seq->cmd_name(); + +The name of the interior sequence command. + +=cut + +sub cmd_name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## let name() be an alias for cmd_name() +*name = \&cmd_name; + +##--------------------------------------------------------------------------- + +## Private subroutine to set the parent pointer of all the given +## children that are interior-sequences to be $self + +sub _set_child2parent_links { + my ($self, @children) = @_; + ## Make sure any sequences know who their parent is + for (@children) { + next unless (length and ref and ref ne 'SCALAR'); + if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or + UNIVERSAL::can($_, 'nested')) + { + $_->nested($self); + } + } +} + +## Private subroutine to unset child->parent links + +sub _unset_child2parent_links { + my $self = shift; + $self->{'-parent_sequence'} = undef; + my $ptree = $self->{'-ptree'}; + for (@$ptree) { + next unless (length and ref and ref ne 'SCALAR'); + $_->_unset_child2parent_links() + if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); + } +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + $pod_seq->prepend($text); + $pod_seq1->prepend($pod_seq2); + +Prepends the given string or parse-tree or sequence object to the parse-tree +of this interior sequence. + +=cut + +sub prepend { + my $self = shift; + $self->{'-ptree'}->prepend(@_); + _set_child2parent_links($self, @_); + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + $pod_seq->append($text); + $pod_seq1->append($pod_seq2); + +Appends the given string or parse-tree or sequence object to the parse-tree +of this interior sequence. + +=cut + +sub append { + my $self = shift; + $self->{'-ptree'}->append(@_); + _set_child2parent_links($self, @_); + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + $outer_seq = $pod_seq->nested || print "not nested"; + +If this interior sequence is nested inside of another interior +sequence, then the outer/parent sequence that contains it is +returned. Otherwise C is returned. + +=cut + +sub nested { + my $self = shift; + (@_ == 1) and $self->{'-parent_sequence'} = shift; + return $self->{'-parent_sequence'} || undef; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + my $seq_raw_text = $pod_seq->raw_text(); + +This method will return the I text of the POD interior sequence, +exactly as it appeared in the input. + +=cut + +sub raw_text { + my $self = shift; + my $text = $self->{'-name'} . $self->{'-ldelim'}; + for ( $self->{'-ptree'}->children ) { + $text .= (ref $_) ? $_->raw_text : $_; + } + $text .= $self->{'-rdelim'}; + return $text; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + my $ldelim = $pod_seq->left_delimiter(); + +The leftmost delimiter beginning the argument text to the interior +sequence (should be "<"). + +=cut + +sub left_delimiter { + (@_ > 1) and $_[0]->{'-ldelim'} = $_[1]; + return $_[0]->{'-ldelim'}; +} + +## let ldelim() be an alias for left_delimiter() +*ldelim = \&left_delimiter; + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + +The rightmost delimiter beginning the argument text to the interior +sequence (should be ">"). + +=cut + +sub right_delimiter { + (@_ > 1) and $_[0]->{'-rdelim'} = $_[1]; + return $_[0]->{'-rdelim'}; +} + +## let rdelim() be an alias for right_delimiter() +*rdelim = \&right_delimiter; + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + my $ptree = $pod_parser->parse_text($paragraph_text); + $pod_seq->parse_tree( $ptree ); + $ptree = $pod_seq->parse_tree(); + +This method will get/set the corresponding parse-tree of the interior +sequence's text. + +=cut + +sub parse_tree { + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; +} + +## let ptree() be an alias for parse_tree() +*ptree = \&parse_tree; + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-EB + + my ($filename, $line_number) = $pod_seq->file_line(); + my $position = $pod_seq->file_line(); + +Returns the current filename and line number for the interior sequence +object. If called in a list context, it returns a list of two +elements: first the filename, then the line number. If called in +a scalar context, it returns a string containing the filename, followed +by a colon (':'), followed by the line number. + +=cut + +sub file_line { + my @loc = ($_[0]->{'-file'} || '', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +=head2 Pod::InteriorSequence::B + +This method performs any necessary cleanup for the interior-sequence. +If you override this method then it is B that you invoke +the parent method from within your own method, otherwise +I + +=cut + +sub DESTROY { + ## We need to get rid of all child->parent pointers throughout the + ## tree so their reference counts will go to zero and they can be + ## garbage-collected + _unset_child2parent_links(@_); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::ParseTree; + +##--------------------------------------------------------------------------- + +=head1 B + +This object corresponds to a tree of parsed POD text. As POD text is +scanned from left to right, it is parsed into an ordered list of +text-strings and B objects (in order of +appearance). A B object corresponds to this list of +strings and sequences. Each interior sequence in the parse-tree may +itself contain a parse-tree (since interior sequences may be nested). + +=cut + +##--------------------------------------------------------------------------- + +=head2 Pod::ParseTree-EB + + my $ptree1 = Pod::ParseTree->new; + my $ptree2 = new Pod::ParseTree; + my $ptree4 = Pod::ParseTree->new($array_ref); + my $ptree3 = new Pod::ParseTree($array_ref); + +This is a class method that constructs a C object and +returns a reference to the new parse-tree. If a single-argument is given, +it must be a reference to an array, and is used to initialize the root +(top) of the parse tree. + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + my $self = (@_ == 1 and ref $_[0]) ? $_[0] : []; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 $ptree-EB + + my $top_node = $ptree->top(); + $ptree->top( $top_node ); + $ptree->top( @children ); + +This method gets/sets the top node of the parse-tree. If no arguments are +given, it returns the topmost node in the tree (the root), which is also +a B. If it is given a single argument that is a reference, +then the reference is assumed to a parse-tree and becomes the new top node. +Otherwise, if arguments are given, they are treated as the new list of +children for the top node. + +=cut + +sub top { + my $self = shift; + if (@_ > 0) { + @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; + } + return $self; +} + +## let parse_tree() & ptree() be aliases for the 'top' method +*parse_tree = *ptree = \⊤ + +##--------------------------------------------------------------------------- + +=head2 $ptree-EB + +This method gets/sets the children of the top node in the parse-tree. +If no arguments are given, it returns the list (array) of children +(each of which should be either a string or a B. +Otherwise, if arguments are given, they are treated as the new list of +children for the top node. + +=cut + +sub children { + my $self = shift; + if (@_ > 0) { + @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; + } + return @{ $self }; +} + +##--------------------------------------------------------------------------- + +=head2 $ptree-EB + +This method prepends the given text or parse-tree to the current parse-tree. +If the first item on the parse-tree is text and the argument is also text, +then the text is prepended to the first item (not added as a separate string). +Otherwise the argument is added as a new string or parse-tree I +the current one. + +=cut + +use vars qw(@ptree); ## an alias used for performance reasons + +sub prepend { + my $self = shift; + local *ptree = $self; + for (@_) { + next unless length; + if (@ptree && !(ref $ptree[0]) && !(ref $_)) { + $ptree[0] = $_ . $ptree[0]; + } + else { + unshift @ptree, $_; + } + } +} + +##--------------------------------------------------------------------------- + +=head2 $ptree-EB + +This method appends the given text or parse-tree to the current parse-tree. +If the last item on the parse-tree is text and the argument is also text, +then the text is appended to the last item (not added as a separate string). +Otherwise the argument is added as a new string or parse-tree I +the current one. + +=cut + +sub append { + my $self = shift; + local *ptree = $self; + my $can_append = @ptree && !(ref $ptree[-1]); + for (@_) { + if (ref) { + push @ptree, $_; + } + elsif(!length) { + next; + } + elsif ($can_append) { + $ptree[-1] .= $_; + } + else { + push @ptree, $_; + } + } +} + +=head2 $ptree-EB + + my $ptree_raw_text = $ptree->raw_text(); + +This method will return the I text of the POD parse-tree +exactly as it appeared in the input. + +=cut + +sub raw_text { + my $self = shift; + my $text = ''; + for ( @$self ) { + $text .= (ref $_) ? $_->raw_text : $_; + } + return $text; +} + +##--------------------------------------------------------------------------- + +## Private routines to set/unset child->parent links + +sub _unset_child2parent_links { + my $self = shift; + local *ptree = $self; + for (@ptree) { + next unless (defined and length and ref and ref ne 'SCALAR'); + $_->_unset_child2parent_links() + if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); + } +} + +sub _set_child2parent_links { + ## nothing to do, Pod::ParseTrees cant have parent pointers +} + +=head2 Pod::ParseTree::B + +This method performs any necessary cleanup for the parse-tree. +If you override this method then it is B +that you invoke the parent method from within your own method, +otherwise I + +=cut + +sub DESTROY { + ## We need to get rid of all child->parent pointers throughout the + ## tree so their reference counts will go to zero and they can be + ## garbage-collected + _unset_child2parent_links(@_); +} + +############################################################################# + +=head1 SEE ALSO + +B is part of the L distribution. + +See L, L + +=head1 AUTHOR + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE + +=cut + +1; diff --git a/cpan/Pod-Parser/lib/Pod/ParseUtils.pm b/cpan/Pod-Parser/lib/Pod/ParseUtils.pm index 3c74d78680..fc9f3a73f2 100644 --- a/cpan/Pod-Parser/lib/Pod/ParseUtils.pm +++ b/cpan/Pod-Parser/lib/Pod/ParseUtils.pm @@ -1,857 +1,857 @@ -############################################################################# -# Pod/ParseUtils.pm -- helpers for POD parsing and conversion -# -# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::ParseUtils; -use strict; - -use vars qw($VERSION); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -=head1 NAME - -Pod::ParseUtils - helpers for POD parsing and conversion - -=head1 SYNOPSIS - - use Pod::ParseUtils; - - my $list = new Pod::List; - my $link = Pod::Hyperlink->new('Pod::Parser'); - -=head1 DESCRIPTION - -B contains a few object-oriented helper packages for -POD parsing and processing (i.e. in POD formatters and translators). - -=cut - -#----------------------------------------------------------------------------- -# Pod::List -# -# class to hold POD list info (=over, =item, =back) -#----------------------------------------------------------------------------- - -package Pod::List; - -use Carp; - -=head2 Pod::List - -B can be used to hold information about POD lists -(written as =over ... =item ... =back) for further processing. -The following methods are available: - -=over 4 - -=item Pod::List-Enew() - -Create a new list object. Properties may be specified through a hash -reference like this: - - my $list = Pod::List->new({ -start => $., -indent => 4 }); - -See the individual methods/properties for details. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-file} ||= 'unknown'; - $self->{-start} ||= 'unknown'; - $self->{-indent} ||= 4; # perlpod: "should be the default" - $self->{_items} = []; - $self->{-type} ||= ''; -} - -=item $list-Efile() - -Without argument, retrieves the file name the list is in. This must -have been set before by either specifying B<-file> in the B -method or by calling the B method with a scalar argument. - -=cut - -# The POD file name the list appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $list-Estart() - -Without argument, retrieves the line number where the list started. -This must have been set before by either specifying B<-start> in the -B method or by calling the B method with a scalar -argument. - -=cut - -# The line in the file the node appears -sub start { - return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; -} - -=item $list-Eindent() - -Without argument, retrieves the indent level of the list as specified -in C<=over n>. This must have been set before by either specifying -B<-indent> in the B method or by calling the B method -with a scalar argument. - -=cut - -# indent level -sub indent { - return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; -} - -=item $list-Etype() - -Without argument, retrieves the list type, which can be an arbitrary value, -e.g. C
    , C
      , ... when thinking the HTML way. -This must have been set before by either specifying -B<-type> in the B method or by calling the B method -with a scalar argument. - -=cut - -# The type of the list (UL, OL, ...) -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -=item $list-Erx() - -Without argument, retrieves a regular expression for simplifying the -individual item strings once the list type has been determined. Usage: -E.g. when converting to HTML, one might strip the leading number in -an ordered list as COLE> already prints numbers itself. -This must have been set before by either specifying -B<-rx> in the B method or by calling the B method -with a scalar argument. - -=cut - -# The regular expression to simplify the items -sub rx { - return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; -} - -=item $list-Eitem() - -Without argument, retrieves the array of the items in this list. -The items may be represented by any scalar. -If an argument has been given, it is pushed on the list of items. - -=cut - -# The individual =items of this list -sub item { - my ($self,$item) = @_; - if(defined $item) { - push(@{$self->{_items}}, $item); - return $item; - } - else { - return @{$self->{_items}}; - } -} - -=item $list-Eparent() - -Without argument, retrieves information about the parent holding this -list, which is represented as an arbitrary scalar. -This must have been set before by either specifying -B<-parent> in the B method or by calling the B method -with a scalar argument. - -=cut - -# possibility for parsers/translators to store information about the -# lists's parent object -sub parent { - return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; -} - -=item $list-Etag() - -Without argument, retrieves information about the list tag, which can be -any scalar. -This must have been set before by either specifying -B<-tag> in the B method or by calling the B method -with a scalar argument. - -=back - -=cut - -# possibility for parsers/translators to store information about the -# list's object -sub tag { - return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; -} - -#----------------------------------------------------------------------------- -# Pod::Hyperlink -# -# class to manipulate POD hyperlinks (L<>) -#----------------------------------------------------------------------------- - -package Pod::Hyperlink; - -=head2 Pod::Hyperlink - -B is a class for manipulation of POD hyperlinks. Usage: - - my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); - -The B class is mainly designed to parse the contents of the -C...E> sequence, providing a simple interface for accessing the -different parts of a POD hyperlink for further processing. It can also be -used to construct hyperlinks. - -=over 4 - -=item Pod::Hyperlink-Enew() - -The B method can either be passed a set of key/value pairs or a single -scalar value, namely the contents of a C...E> sequence. An object -of the class C is returned. The value C indicates a -failure, the error message is stored in C<$@>. - -=cut - -use Carp; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = +{}; - bless $self, $class; - $self->initialize(); - if(defined $_[0]) { - if(ref($_[0])) { - # called with a list of parameters - %$self = %{$_[0]}; - $self->_construct_text(); - } - else { - # called with L<> contents - return unless($self->parse($_[0])); - } - } - return $self; -} - -sub initialize { - my $self = shift; - $self->{-line} ||= 'undef'; - $self->{-file} ||= 'undef'; - $self->{-page} ||= ''; - $self->{-node} ||= ''; - $self->{-alttext} ||= ''; - $self->{-type} ||= 'undef'; - $self->{_warnings} = []; -} - -=item $link-Eparse($string) - -This method can be used to (re)parse a (new) hyperlink, i.e. the contents -of a C...E> sequence. The result is stored in the current object. -Warnings are stored in the B property. -E.g. sections like Copen(2)E> are deprecated, as they do not point -to Perl documents. CDBI::foo(3p)E> is wrong as well, the manpage -section can simply be dropped. - -=cut - -sub parse { - my $self = shift; - local($_) = $_[0]; - # syntax check the link and extract destination - my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0); - - $self->{_warnings} = []; - - # collapse newlines with whitespace - s/\s*\n+\s*/ /g; - - # strip leading/trailing whitespace - if(s/^[\s\n]+//) { - $self->warning('ignoring leading whitespace in link'); - } - if(s/[\s\n]+$//) { - $self->warning('ignoring trailing whitespace in link'); - } - unless(length($_)) { - _invalid_link('empty link'); - return; - } - - ## Check for different possibilities. This is tedious and error-prone - # we match all possibilities (alttext, page, section/item) - #warn "DEBUG: link=$_\n"; - - # only page - # problem: a lot of people use (), or (1) or the like to indicate - # man page sections. But this collides with L that is supposed - # to point to an internal funtion... - my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; - # page name only - if(/^($page_rx)$/o) { - $page = $1; - $type = 'page'; - } - # alttext, page and "section" - elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) { - ($alttext, $page, $node) = ($1, $2, $3); - $type = 'section'; - $quoted = 1; #... therefore | and / are allowed - } - # alttext and page - elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) { - ($alttext, $page) = ($1, $2); - $type = 'page'; - } - # alttext and "section" - elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) { - ($alttext, $node) = ($1,$2); - $type = 'section'; - $quoted = 1; - } - # page and "section" - elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) { - ($page, $node) = ($1, $2); - $type = 'section'; - $quoted = 1; - } - # page and item - elsif(m{^($page_rx)\s*/\s*(.+)$}o) { - ($page, $node) = ($1, $2); - $type = 'item'; - } - # only "section" - elsif(m{^/?"(.+)"$}) { - $node = $1; - $type = 'section'; - $quoted = 1; - } - # only item - elsif(m{^\s*/(.+)$}) { - $node = $1; - $type = 'item'; - } - - # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should? - elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) { - ($alttext,$node) = ($1,$2); - $type = 'hyperlink'; - } - - # non-standard: Hyperlink - elsif(/^(\w+:[^:\s]\S*)$/i) { - $node = $1; - $type = 'hyperlink'; - } - # alttext, page and item - elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) { - ($alttext, $page, $node) = ($1, $2, $3); - $type = 'item'; - } - # alttext and item - elsif(m{^(.*?)\s*[|]\s*/(.+)$}) { - ($alttext, $node) = ($1,$2); - } - # must be an item or a "malformed" section (without "") - else { - $node = $_; - $type = 'item'; - } - # collapse whitespace in nodes - $node =~ s/\s+/ /gs; - - # empty alternative text expands to node name - if(defined $alttext) { - if(!length($alttext)) { - $alttext = $node || $page; - } - } - else { - $alttext = ''; - } - - if($page =~ /[(]\w*[)]$/) { - $self->warning("(section) in '$page' deprecated"); - } - if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') { - $self->warning("node '$node' contains non-escaped | or /"); - } - if($alttext =~ m{[|/]}) { - $self->warning("alternative text '$node' contains non-escaped | or /"); - } - $self->{-page} = $page; - $self->{-node} = $node; - $self->{-alttext} = $alttext; - #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; - $self->{-type} = $type; - $self->_construct_text(); - 1; -} - -sub _construct_text { - my $self = shift; - my $alttext = $self->alttext(); - my $type = $self->type(); - my $section = $self->node(); - my $page = $self->page(); - my $page_ext = ''; - $page =~ s/([(]\w*[)])$// && ($page_ext = $1); - if($alttext) { - $self->{_text} = $alttext; - } - elsif($type eq 'hyperlink') { - $self->{_text} = $section; - } - else { - $self->{_text} = ($section || '') . - (($page && $section) ? ' in ' : '') . - "$page$page_ext"; - } - # for being marked up later - # use the non-standard markers P<> and Q<>, so that the resulting - # text can be parsed by the translators. It's their job to put - # the correct hypertext around the linktext - if($alttext) { - $self->{_markup} = "Q<$alttext>"; - } - elsif($type eq 'hyperlink') { - $self->{_markup} = "Q<$section>"; - } - else { - $self->{_markup} = (!$section ? '' : "Q<$section>") . - ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : ''); - } -} - -=item $link-Emarkup($string) - -Set/retrieve the textual value of the link. This string contains special -markers CE> and CE> that should be expanded by the -translator's interior sequence expansion engine to the -formatter-specific code to highlight/activate the hyperlink. The details -have to be implemented in the translator. - -=cut - -#' retrieve/set markuped text -sub markup { - return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; -} - -=item $link-Etext() - -This method returns the textual representation of the hyperlink as above, -but without markers (read only). Depending on the link type this is one of -the following alternatives (the + and * denote the portions of the text -that are marked up): - - +perl+ L - *$|* in +perlvar+ L - *OPTIONS* in +perldoc+ L - *DESCRIPTION* L<"DESCRIPTION"> - -=cut - -# The complete link's text -sub text { - return $_[0]->{_text}; -} - -=item $link-Ewarning() - -After parsing, this method returns any warnings encountered during the -parsing process. - -=cut - -# Set/retrieve warnings -sub warning { - my $self = shift; - if(@_) { - push(@{$self->{_warnings}}, @_); - return @_; - } - return @{$self->{_warnings}}; -} - -=item $link-Efile() - -=item $link-Eline() - -Just simple slots for storing information about the line and the file -the link was encountered in. Has to be filled in manually. - -=cut - -# The line in the file the link appears -sub line { - return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; -} - -# The POD file name the link appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $link-Epage() - -This method sets or returns the POD page this link points to. - -=cut - -# The POD page the link appears on -sub page { - if (@_ > 1) { - $_[0]->{-page} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-page}; -} - -=item $link-Enode() - -As above, but the destination node text of the link. - -=cut - -# The link destination -sub node { - if (@_ > 1) { - $_[0]->{-node} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-node}; -} - -=item $link-Ealttext() - -Sets or returns an alternative text specified in the link. - -=cut - -# Potential alternative text -sub alttext { - if (@_ > 1) { - $_[0]->{-alttext} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-alttext}; -} - -=item $link-Etype() - -The node type, either C
      or C. As an unofficial type, -there is also C, derived from e.g. Chttp://perl.comE> - -=cut - -# The type: item or headn -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -=item $link-Elink() - -Returns the link as contents of CE>. Reciprocal to B. - -=back - -=cut - -# The link itself -sub link { - my $self = shift; - my $link = $self->page() || ''; - if($self->node()) { - my $node = $self->node(); - $node =~ s/\|/E/g; - $node =~ s{/}{E}g; - if($self->type() eq 'section') { - $link .= ($link ? '/' : '') . '"' . $node . '"'; - } - elsif($self->type() eq 'hyperlink') { - $link = $self->node(); - } - else { # item - $link .= '/' . $node; - } - } - if($self->alttext()) { - my $text = $self->alttext(); - $text =~ s/\|/E/g; - $text =~ s{/}{E}g; - $link = "$text|$link"; - } - return $link; -} - -sub _invalid_link { - my ($msg) = @_; - # this sets @_ - #eval { die "$msg\n" }; - #chomp $@; - $@ = $msg; # this seems to work, too! - return; -} - -#----------------------------------------------------------------------------- -# Pod::Cache -# -# class to hold POD page details -#----------------------------------------------------------------------------- - -package Pod::Cache; - -=head2 Pod::Cache - -B holds information about a set of POD documents, -especially the nodes for hyperlinks. -The following methods are available: - -=over 4 - -=item Pod::Cache-Enew() - -Create a new cache object. This object can hold an arbitrary number of -POD documents of class Pod::Cache::Item. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = []; - bless $self, $class; - return $self; -} - -=item $cache-Eitem() - -Add a new item to the cache. Without arguments, this method returns a -list of all cache elements. - -=cut - -sub item { - my ($self,%param) = @_; - if(%param) { - my $item = Pod::Cache::Item->new(%param); - push(@$self, $item); - return $item; - } - else { - return @{$self}; - } -} - -=item $cache-Efind_page($name) - -Look for a POD document named C<$name> in the cache. Returns the -reference to the corresponding Pod::Cache::Item object or undef if -not found. - -=back - -=cut - -sub find_page { - my ($self,$page) = @_; - foreach(@$self) { - if($_->page() eq $page) { - return $_; - } - } - return; -} - -package Pod::Cache::Item; - -=head2 Pod::Cache::Item - -B holds information about individual POD documents, -that can be grouped in a Pod::Cache object. -It is intended to hold information about the hyperlink nodes of POD -documents. -The following methods are available: - -=over 4 - -=item Pod::Cache::Item-Enew() - -Create a new object. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-nodes} = [] unless(defined $self->{-nodes}); -} - -=item $cacheitem-Epage() - -Set/retrieve the POD document name (e.g. "Pod::Parser"). - -=cut - -# The POD page -sub page { - return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; -} - -=item $cacheitem-Edescription() - -Set/retrieve the POD short description as found in the C<=head1 NAME> -section. - -=cut - -# The POD description, taken out of NAME if present -sub description { - return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; -} - -=item $cacheitem-Epath() - -Set/retrieve the POD file storage path. - -=cut - -# The file path -sub path { - return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; -} - -=item $cacheitem-Efile() - -Set/retrieve the POD file name. - -=cut - -# The POD file name -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $cacheitem-Enodes() - -Add a node (or a list of nodes) to the document's node list. Note that -the order is kept, i.e. start with the first node and end with the last. -If no argument is given, the current list of nodes is returned in the -same order the nodes have been added. -A node can be any scalar, but usually is a pair of node string and -unique id for the C method to work correctly. - -=cut - -# The POD nodes -sub nodes { - my ($self,@nodes) = @_; - if(@nodes) { - push(@{$self->{-nodes}}, @nodes); - return @nodes; - } - else { - return @{$self->{-nodes}}; - } -} - -=item $cacheitem-Efind_node($name) - -Look for a node or index entry named C<$name> in the object. -Returns the unique id of the node (i.e. the second element of the array -stored in the node array) or undef if not found. - -=cut - -sub find_node { - my ($self,$node) = @_; - my @search; - push(@search, @{$self->{-nodes}}) if($self->{-nodes}); - push(@search, @{$self->{-idx}}) if($self->{-idx}); - foreach(@search) { - if($_->[0] eq $node) { - return $_->[1]; # id - } - } - return; -} - -=item $cacheitem-Eidx() - -Add an index entry (or a list of them) to the document's index list. Note that -the order is kept, i.e. start with the first node and end with the last. -If no argument is given, the current list of index entries is returned in the -same order the entries have been added. -An index entry can be any scalar, but usually is a pair of string and -unique id. - -=back - -=cut - -# The POD index entries -sub idx { - my ($self,@idx) = @_; - if(@idx) { - push(@{$self->{-idx}}, @idx); - return @idx; - } - else { - return @{$self->{-idx}}; - } -} - -=head1 AUTHOR - -Please report bugs using L. - -Marek Rouchal Emarekr@cpan.orgE, borrowing -a lot of things from L and L as well as other POD -processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. - -B is part of the L distribution. - -=head1 SEE ALSO - -L, L, L, L, -L - -=cut - -1; +############################################################################# +# Pod/ParseUtils.pm -- helpers for POD parsing and conversion +# +# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::ParseUtils; +use strict; + +use vars qw($VERSION); +$VERSION = '1.60'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +=head1 NAME + +Pod::ParseUtils - helpers for POD parsing and conversion + +=head1 SYNOPSIS + + use Pod::ParseUtils; + + my $list = new Pod::List; + my $link = Pod::Hyperlink->new('Pod::Parser'); + +=head1 DESCRIPTION + +B contains a few object-oriented helper packages for +POD parsing and processing (i.e. in POD formatters and translators). + +=cut + +#----------------------------------------------------------------------------- +# Pod::List +# +# class to hold POD list info (=over, =item, =back) +#----------------------------------------------------------------------------- + +package Pod::List; + +use Carp; + +=head2 Pod::List + +B can be used to hold information about POD lists +(written as =over ... =item ... =back) for further processing. +The following methods are available: + +=over 4 + +=item Pod::List-Enew() + +Create a new list object. Properties may be specified through a hash +reference like this: + + my $list = Pod::List->new({ -start => $., -indent => 4 }); + +See the individual methods/properties for details. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-file} ||= 'unknown'; + $self->{-start} ||= 'unknown'; + $self->{-indent} ||= 4; # perlpod: "should be the default" + $self->{_items} = []; + $self->{-type} ||= ''; +} + +=item $list-Efile() + +Without argument, retrieves the file name the list is in. This must +have been set before by either specifying B<-file> in the B +method or by calling the B method with a scalar argument. + +=cut + +# The POD file name the list appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $list-Estart() + +Without argument, retrieves the line number where the list started. +This must have been set before by either specifying B<-start> in the +B method or by calling the B method with a scalar +argument. + +=cut + +# The line in the file the node appears +sub start { + return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; +} + +=item $list-Eindent() + +Without argument, retrieves the indent level of the list as specified +in C<=over n>. This must have been set before by either specifying +B<-indent> in the B method or by calling the B method +with a scalar argument. + +=cut + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + +=item $list-Etype() + +Without argument, retrieves the list type, which can be an arbitrary value, +e.g. C
        , C
          , ... when thinking the HTML way. +This must have been set before by either specifying +B<-type> in the B method or by calling the B method +with a scalar argument. + +=cut + +# The type of the list (UL, OL, ...) +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item $list-Erx() + +Without argument, retrieves a regular expression for simplifying the +individual item strings once the list type has been determined. Usage: +E.g. when converting to HTML, one might strip the leading number in +an ordered list as COLE> already prints numbers itself. +This must have been set before by either specifying +B<-rx> in the B method or by calling the B method +with a scalar argument. + +=cut + +# The regular expression to simplify the items +sub rx { + return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; +} + +=item $list-Eitem() + +Without argument, retrieves the array of the items in this list. +The items may be represented by any scalar. +If an argument has been given, it is pushed on the list of items. + +=cut + +# The individual =items of this list +sub item { + my ($self,$item) = @_; + if(defined $item) { + push(@{$self->{_items}}, $item); + return $item; + } + else { + return @{$self->{_items}}; + } +} + +=item $list-Eparent() + +Without argument, retrieves information about the parent holding this +list, which is represented as an arbitrary scalar. +This must have been set before by either specifying +B<-parent> in the B method or by calling the B method +with a scalar argument. + +=cut + +# possibility for parsers/translators to store information about the +# lists's parent object +sub parent { + return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; +} + +=item $list-Etag() + +Without argument, retrieves information about the list tag, which can be +any scalar. +This must have been set before by either specifying +B<-tag> in the B method or by calling the B method +with a scalar argument. + +=back + +=cut + +# possibility for parsers/translators to store information about the +# list's object +sub tag { + return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; +} + +#----------------------------------------------------------------------------- +# Pod::Hyperlink +# +# class to manipulate POD hyperlinks (L<>) +#----------------------------------------------------------------------------- + +package Pod::Hyperlink; + +=head2 Pod::Hyperlink + +B is a class for manipulation of POD hyperlinks. Usage: + + my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); + +The B class is mainly designed to parse the contents of the +C...E> sequence, providing a simple interface for accessing the +different parts of a POD hyperlink for further processing. It can also be +used to construct hyperlinks. + +=over 4 + +=item Pod::Hyperlink-Enew() + +The B method can either be passed a set of key/value pairs or a single +scalar value, namely the contents of a C...E> sequence. An object +of the class C is returned. The value C indicates a +failure, the error message is stored in C<$@>. + +=cut + +use Carp; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = +{}; + bless $self, $class; + $self->initialize(); + if(defined $_[0]) { + if(ref($_[0])) { + # called with a list of parameters + %$self = %{$_[0]}; + $self->_construct_text(); + } + else { + # called with L<> contents + return unless($self->parse($_[0])); + } + } + return $self; +} + +sub initialize { + my $self = shift; + $self->{-line} ||= 'undef'; + $self->{-file} ||= 'undef'; + $self->{-page} ||= ''; + $self->{-node} ||= ''; + $self->{-alttext} ||= ''; + $self->{-type} ||= 'undef'; + $self->{_warnings} = []; +} + +=item $link-Eparse($string) + +This method can be used to (re)parse a (new) hyperlink, i.e. the contents +of a C...E> sequence. The result is stored in the current object. +Warnings are stored in the B property. +E.g. sections like Copen(2)E> are deprecated, as they do not point +to Perl documents. CDBI::foo(3p)E> is wrong as well, the manpage +section can simply be dropped. + +=cut + +sub parse { + my $self = shift; + local($_) = $_[0]; + # syntax check the link and extract destination + my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0); + + $self->{_warnings} = []; + + # collapse newlines with whitespace + s/\s*\n+\s*/ /g; + + # strip leading/trailing whitespace + if(s/^[\s\n]+//) { + $self->warning('ignoring leading whitespace in link'); + } + if(s/[\s\n]+$//) { + $self->warning('ignoring trailing whitespace in link'); + } + unless(length($_)) { + _invalid_link('empty link'); + return; + } + + ## Check for different possibilities. This is tedious and error-prone + # we match all possibilities (alttext, page, section/item) + #warn "DEBUG: link=$_\n"; + + # only page + # problem: a lot of people use (), or (1) or the like to indicate + # man page sections. But this collides with L that is supposed + # to point to an internal funtion... + my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; + # page name only + if(/^($page_rx)$/o) { + $page = $1; + $type = 'page'; + } + # alttext, page and "section" + elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) { + ($alttext, $page, $node) = ($1, $2, $3); + $type = 'section'; + $quoted = 1; #... therefore | and / are allowed + } + # alttext and page + elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) { + ($alttext, $page) = ($1, $2); + $type = 'page'; + } + # alttext and "section" + elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) { + ($alttext, $node) = ($1,$2); + $type = 'section'; + $quoted = 1; + } + # page and "section" + elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) { + ($page, $node) = ($1, $2); + $type = 'section'; + $quoted = 1; + } + # page and item + elsif(m{^($page_rx)\s*/\s*(.+)$}o) { + ($page, $node) = ($1, $2); + $type = 'item'; + } + # only "section" + elsif(m{^/?"(.+)"$}) { + $node = $1; + $type = 'section'; + $quoted = 1; + } + # only item + elsif(m{^\s*/(.+)$}) { + $node = $1; + $type = 'item'; + } + + # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should? + elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) { + ($alttext,$node) = ($1,$2); + $type = 'hyperlink'; + } + + # non-standard: Hyperlink + elsif(/^(\w+:[^:\s]\S*)$/i) { + $node = $1; + $type = 'hyperlink'; + } + # alttext, page and item + elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) { + ($alttext, $page, $node) = ($1, $2, $3); + $type = 'item'; + } + # alttext and item + elsif(m{^(.*?)\s*[|]\s*/(.+)$}) { + ($alttext, $node) = ($1,$2); + } + # must be an item or a "malformed" section (without "") + else { + $node = $_; + $type = 'item'; + } + # collapse whitespace in nodes + $node =~ s/\s+/ /gs; + + # empty alternative text expands to node name + if(defined $alttext) { + if(!length($alttext)) { + $alttext = $node || $page; + } + } + else { + $alttext = ''; + } + + if($page =~ /[(]\w*[)]$/) { + $self->warning("(section) in '$page' deprecated"); + } + if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') { + $self->warning("node '$node' contains non-escaped | or /"); + } + if($alttext =~ m{[|/]}) { + $self->warning("alternative text '$node' contains non-escaped | or /"); + } + $self->{-page} = $page; + $self->{-node} = $node; + $self->{-alttext} = $alttext; + #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; + $self->{-type} = $type; + $self->_construct_text(); + 1; +} + +sub _construct_text { + my $self = shift; + my $alttext = $self->alttext(); + my $type = $self->type(); + my $section = $self->node(); + my $page = $self->page(); + my $page_ext = ''; + $page =~ s/([(]\w*[)])$// && ($page_ext = $1); + if($alttext) { + $self->{_text} = $alttext; + } + elsif($type eq 'hyperlink') { + $self->{_text} = $section; + } + else { + $self->{_text} = ($section || '') . + (($page && $section) ? ' in ' : '') . + "$page$page_ext"; + } + # for being marked up later + # use the non-standard markers P<> and Q<>, so that the resulting + # text can be parsed by the translators. It's their job to put + # the correct hypertext around the linktext + if($alttext) { + $self->{_markup} = "Q<$alttext>"; + } + elsif($type eq 'hyperlink') { + $self->{_markup} = "Q<$section>"; + } + else { + $self->{_markup} = (!$section ? '' : "Q<$section>") . + ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : ''); + } +} + +=item $link-Emarkup($string) + +Set/retrieve the textual value of the link. This string contains special +markers CE> and CE> that should be expanded by the +translator's interior sequence expansion engine to the +formatter-specific code to highlight/activate the hyperlink. The details +have to be implemented in the translator. + +=cut + +#' retrieve/set markuped text +sub markup { + return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; +} + +=item $link-Etext() + +This method returns the textual representation of the hyperlink as above, +but without markers (read only). Depending on the link type this is one of +the following alternatives (the + and * denote the portions of the text +that are marked up): + + +perl+ L + *$|* in +perlvar+ L + *OPTIONS* in +perldoc+ L + *DESCRIPTION* L<"DESCRIPTION"> + +=cut + +# The complete link's text +sub text { + return $_[0]->{_text}; +} + +=item $link-Ewarning() + +After parsing, this method returns any warnings encountered during the +parsing process. + +=cut + +# Set/retrieve warnings +sub warning { + my $self = shift; + if(@_) { + push(@{$self->{_warnings}}, @_); + return @_; + } + return @{$self->{_warnings}}; +} + +=item $link-Efile() + +=item $link-Eline() + +Just simple slots for storing information about the line and the file +the link was encountered in. Has to be filled in manually. + +=cut + +# The line in the file the link appears +sub line { + return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; +} + +# The POD file name the link appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $link-Epage() + +This method sets or returns the POD page this link points to. + +=cut + +# The POD page the link appears on +sub page { + if (@_ > 1) { + $_[0]->{-page} = $_[1]; + $_[0]->_construct_text(); + } + return $_[0]->{-page}; +} + +=item $link-Enode() + +As above, but the destination node text of the link. + +=cut + +# The link destination +sub node { + if (@_ > 1) { + $_[0]->{-node} = $_[1]; + $_[0]->_construct_text(); + } + return $_[0]->{-node}; +} + +=item $link-Ealttext() + +Sets or returns an alternative text specified in the link. + +=cut + +# Potential alternative text +sub alttext { + if (@_ > 1) { + $_[0]->{-alttext} = $_[1]; + $_[0]->_construct_text(); + } + return $_[0]->{-alttext}; +} + +=item $link-Etype() + +The node type, either C
          or C. As an unofficial type, +there is also C, derived from e.g. Chttp://perl.comE> + +=cut + +# The type: item or headn +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item $link-Elink() + +Returns the link as contents of CE>. Reciprocal to B. + +=back + +=cut + +# The link itself +sub link { + my $self = shift; + my $link = $self->page() || ''; + if($self->node()) { + my $node = $self->node(); + $node =~ s/\|/E/g; + $node =~ s{/}{E}g; + if($self->type() eq 'section') { + $link .= ($link ? '/' : '') . '"' . $node . '"'; + } + elsif($self->type() eq 'hyperlink') { + $link = $self->node(); + } + else { # item + $link .= '/' . $node; + } + } + if($self->alttext()) { + my $text = $self->alttext(); + $text =~ s/\|/E/g; + $text =~ s{/}{E}g; + $link = "$text|$link"; + } + return $link; +} + +sub _invalid_link { + my ($msg) = @_; + # this sets @_ + #eval { die "$msg\n" }; + #chomp $@; + $@ = $msg; # this seems to work, too! + return; +} + +#----------------------------------------------------------------------------- +# Pod::Cache +# +# class to hold POD page details +#----------------------------------------------------------------------------- + +package Pod::Cache; + +=head2 Pod::Cache + +B holds information about a set of POD documents, +especially the nodes for hyperlinks. +The following methods are available: + +=over 4 + +=item Pod::Cache-Enew() + +Create a new cache object. This object can hold an arbitrary number of +POD documents of class Pod::Cache::Item. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = []; + bless $self, $class; + return $self; +} + +=item $cache-Eitem() + +Add a new item to the cache. Without arguments, this method returns a +list of all cache elements. + +=cut + +sub item { + my ($self,%param) = @_; + if(%param) { + my $item = Pod::Cache::Item->new(%param); + push(@$self, $item); + return $item; + } + else { + return @{$self}; + } +} + +=item $cache-Efind_page($name) + +Look for a POD document named C<$name> in the cache. Returns the +reference to the corresponding Pod::Cache::Item object or undef if +not found. + +=back + +=cut + +sub find_page { + my ($self,$page) = @_; + foreach(@$self) { + if($_->page() eq $page) { + return $_; + } + } + return; +} + +package Pod::Cache::Item; + +=head2 Pod::Cache::Item + +B holds information about individual POD documents, +that can be grouped in a Pod::Cache object. +It is intended to hold information about the hyperlink nodes of POD +documents. +The following methods are available: + +=over 4 + +=item Pod::Cache::Item-Enew() + +Create a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-nodes} = [] unless(defined $self->{-nodes}); +} + +=item $cacheitem-Epage() + +Set/retrieve the POD document name (e.g. "Pod::Parser"). + +=cut + +# The POD page +sub page { + return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; +} + +=item $cacheitem-Edescription() + +Set/retrieve the POD short description as found in the C<=head1 NAME> +section. + +=cut + +# The POD description, taken out of NAME if present +sub description { + return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; +} + +=item $cacheitem-Epath() + +Set/retrieve the POD file storage path. + +=cut + +# The file path +sub path { + return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; +} + +=item $cacheitem-Efile() + +Set/retrieve the POD file name. + +=cut + +# The POD file name +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $cacheitem-Enodes() + +Add a node (or a list of nodes) to the document's node list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of nodes is returned in the +same order the nodes have been added. +A node can be any scalar, but usually is a pair of node string and +unique id for the C method to work correctly. + +=cut + +# The POD nodes +sub nodes { + my ($self,@nodes) = @_; + if(@nodes) { + push(@{$self->{-nodes}}, @nodes); + return @nodes; + } + else { + return @{$self->{-nodes}}; + } +} + +=item $cacheitem-Efind_node($name) + +Look for a node or index entry named C<$name> in the object. +Returns the unique id of the node (i.e. the second element of the array +stored in the node array) or undef if not found. + +=cut + +sub find_node { + my ($self,$node) = @_; + my @search; + push(@search, @{$self->{-nodes}}) if($self->{-nodes}); + push(@search, @{$self->{-idx}}) if($self->{-idx}); + foreach(@search) { + if($_->[0] eq $node) { + return $_->[1]; # id + } + } + return; +} + +=item $cacheitem-Eidx() + +Add an index entry (or a list of them) to the document's index list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of index entries is returned in the +same order the entries have been added. +An index entry can be any scalar, but usually is a pair of string and +unique id. + +=back + +=cut + +# The POD index entries +sub idx { + my ($self,@idx) = @_; + if(@idx) { + push(@{$self->{-idx}}, @idx); + return @idx; + } + else { + return @{$self->{-idx}}; + } +} + +=head1 AUTHOR + +Please report bugs using L. + +Marek Rouchal Emarekr@cpan.orgE, borrowing +a lot of things from L and L as well as other POD +processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. + +B is part of the L distribution. + +=head1 SEE ALSO + +L, L, L, L, +L + +=cut + +1; diff --git a/cpan/Pod-Parser/lib/Pod/Parser.pm b/cpan/Pod-Parser/lib/Pod/Parser.pm index 9a6acd62f1..4b4fecfbdd 100644 --- a/cpan/Pod-Parser/lib/Pod/Parser.pm +++ b/cpan/Pod-Parser/lib/Pod/Parser.pm @@ -1,1832 +1,1836 @@ -############################################################################# -# Pod/Parser.pm -- package which defines a base class for parsing POD docs. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Parser; -use strict; - -## These "variables" are used as local "glob aliases" for performance -use vars qw($VERSION @ISA %myData %myOpts @input_stack); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::Parser - base class for creating POD filters and translators - -=head1 SYNOPSIS - - use Pod::Parser; - - package MyParser; - @ISA = qw(Pod::Parser); - - sub command { - my ($parser, $command, $paragraph, $line_num) = @_; - ## Interpret the command and its text; sample actions might be: - if ($command eq 'head1') { ... } - elsif ($command eq 'head2') { ... } - ## ... other commands and their actions - my $out_fh = $parser->output_handle(); - my $expansion = $parser->interpolate($paragraph, $line_num); - print $out_fh $expansion; - } - - sub verbatim { - my ($parser, $paragraph, $line_num) = @_; - ## Format verbatim paragraph; sample actions might be: - my $out_fh = $parser->output_handle(); - print $out_fh $paragraph; - } - - sub textblock { - my ($parser, $paragraph, $line_num) = @_; - ## Translate/Format this block of text; sample actions might be: - my $out_fh = $parser->output_handle(); - my $expansion = $parser->interpolate($paragraph, $line_num); - print $out_fh $expansion; - } - - sub interior_sequence { - my ($parser, $seq_command, $seq_argument) = @_; - ## Expand an interior sequence; sample actions might be: - return "*$seq_argument*" if ($seq_command eq 'B'); - return "`$seq_argument'" if ($seq_command eq 'C'); - return "_${seq_argument}_'" if ($seq_command eq 'I'); - ## ... other sequence commands and their resulting text - } - - package main; - - ## Create a parser object and have it parse file whose name was - ## given on the command-line (use STDIN if no files were given). - $parser = new MyParser(); - $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0); - for (@ARGV) { $parser->parse_from_file($_); } - -=head1 REQUIRES - -perl5.005, Pod::InputObjects, Exporter, Symbol, Carp - -=head1 EXPORTS - -Nothing. - -=head1 DESCRIPTION - -B is a base class for creating POD filters and translators. -It handles most of the effort involved with parsing the POD sections -from an input stream, leaving subclasses free to be concerned only with -performing the actual translation of text. - -B parses PODs, and makes method calls to handle the various -components of the POD. Subclasses of B override these methods -to translate the POD into whatever output format they desire. - -=head1 QUICK OVERVIEW - -To create a POD filter for translating POD documentation into some other -format, you create a subclass of B which typically overrides -just the base class implementation for the following methods: - -=over 2 - -=item * - -B - -=item * - -B - -=item * - -B - -=item * - -B - -=back - -You may also want to override the B and B -methods for your subclass (to perform any needed per-file and/or -per-document initialization or cleanup). - -If you need to perform any preprocessing of input before it is parsed -you may want to override one or more of B and/or -B. - -Sometimes it may be necessary to make more than one pass over the input -files. If this is the case you have several options. You can make the -first pass using B and override your methods to store the -intermediate results in memory somewhere for the B method to -process. You could use B for several passes with an -appropriate state variable to control the operation for each pass. If -your input source can't be reset to start at the beginning, you can -store it in some other structure as a string or an array and have that -structure implement a B method (which is all that -B uses to read input). - -Feel free to add any member data fields you need to keep track of things -like current font, indentation, horizontal or vertical position, or -whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA"> -to avoid name collisions. - -For the most part, the B base class should be able to -do most of the input parsing for you and leave you free to worry about -how to interpret the commands and translate the result. - -Note that all we have described here in this quick overview is the -simplest most straightforward use of B to do stream-based -parsing. It is also possible to use the B function -to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. - -=head1 PARSING OPTIONS - -A I is simply a named option of B with a -value that corresponds to a certain specified behavior. These various -behaviors of B may be enabled/disabled by setting -or unsetting one or more I using the B method. -The set of currently accepted parse-options is as follows: - -=over 3 - -=item B<-want_nonPODs> (default: unset) - -Normally (by default) B will only provide access to -the POD sections of the input. Input paragraphs that are not part -of the POD-format documentation are not made available to the caller -(not even using B). Setting this option to a -non-empty, non-zero value will allow B to see -non-POD sections of the input as well as POD sections. The B -method can be used to determine if the corresponding paragraph is a POD -paragraph, or some other input paragraph. - -=item B<-process_cut_cmd> (default: unset) - -Normally (by default) B handles the C<=cut> POD directive -by itself and does not pass it on to the caller for processing. Setting -this option to a non-empty, non-zero value will cause B to -pass the C<=cut> directive to the caller just like any other POD command -(and hence it may be processed by the B method). - -B will still interpret the C<=cut> directive to mean that -"cutting mode" has been (re)entered, but the caller will get a chance -to capture the actual C<=cut> paragraph itself for whatever purpose -it desires. - -=item B<-warnings> (default: unset) - -Normally (by default) B recognizes a bare minimum of -pod syntax errors and warnings and issues diagnostic messages -for errors, but not for warnings. (Use B to do more -thorough checking of POD syntax.) Setting this option to a non-empty, -non-zero value will cause B to issue diagnostics for -the few warnings it recognizes as well as the errors. - -=back - -Please see L<"parseopts()"> for a complete description of the interface -for the setting and unsetting of parse-options. - -=cut - -############################################################################# - -#use diagnostics; -use Pod::InputObjects; -use Carp; -use Exporter; -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} -@ISA = qw(Exporter); - -############################################################################# - -=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES - -B provides several methods which most subclasses will probably -want to override. These methods are as follows: - -=cut - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->command($cmd,$text,$line_num,$pod_para); - -This method should be overridden by subclasses to take the appropriate -action when a POD command paragraph (denoted by a line beginning with -"=") is encountered. When such a POD directive is seen in the input, -this method is called and is passed: - -=over 3 - -=item C<$cmd> - -the name of the command for this POD paragraph - -=item C<$text> - -the paragraph text for the given POD paragraph command. - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C object which contains further -information about the paragraph command (see L -for details). - -=back - -B that this method I called for C<=pod> paragraphs. - -The base class implementation of this method simply treats the raw POD -command as normal block of paragraph text (invoking the B -method with the command paragraph). - -=cut - -sub command { - my ($self, $cmd, $text, $line_num, $pod_para) = @_; - ## Just treat this like a textblock - $self->textblock($pod_para->raw_text(), $line_num, $pod_para); -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->verbatim($text,$line_num,$pod_para); - -This method may be overridden by subclasses to take the appropriate -action when a block of verbatim text is encountered. It is passed the -following parameters: - -=over 3 - -=item C<$text> - -the block of text for the verbatim paragraph - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C object which contains further -information about the paragraph (see L -for details). - -=back - -The base class implementation of this method simply prints the textblock -(unmodified) to the output filehandle. - -=cut - -sub verbatim { - my ($self, $text, $line_num, $pod_para) = @_; - my $out_fh = $self->{_OUTPUT}; - print $out_fh $text; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->textblock($text,$line_num,$pod_para); - -This method may be overridden by subclasses to take the appropriate -action when a normal block of POD text is encountered (although the base -class method will usually do what you want). It is passed the following -parameters: - -=over 3 - -=item C<$text> - -the block of text for the a POD paragraph - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C object which contains further -information about the paragraph (see L -for details). - -=back - -In order to process interior sequences, subclasses implementations of -this method will probably want to invoke either B or -B, passing it the text block C<$text>, and the corresponding -line number in C<$line_num>, and then perform any desired processing upon -the returned result. - -The base class implementation of this method simply prints the text block -as it occurred in the input stream). - -=cut - -sub textblock { - my ($self, $text, $line_num, $pod_para) = @_; - my $out_fh = $self->{_OUTPUT}; - print $out_fh $self->interpolate($text, $line_num); -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq); - -This method should be overridden by subclasses to take the appropriate -action when an interior sequence is encountered. An interior sequence is -an embedded command within a block of text which appears as a command -name (usually a single uppercase character) followed immediately by a -string of text which is enclosed in angle brackets. This method is -passed the sequence command C<$seq_cmd> and the corresponding text -C<$seq_arg>. It is invoked by the B method for each interior -sequence that occurs in the string that it is passed. It should return -the desired text string to be used in place of the interior sequence. -The C<$pod_seq> argument is a reference to a C -object which contains further information about the interior sequence. -Please see L for details if you need to access this -additional information. - -Subclass implementations of this method may wish to invoke the -B method of C<$pod_seq> to see if it is nested inside -some other interior-sequence (and if so, which kind). - -The base class implementation of the B method -simply returns the raw text of the interior sequence (as it occurred -in the input) to the caller. - -=cut - -sub interior_sequence { - my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; - ## Just return the raw text of the interior sequence - return $pod_seq->raw_text(); -} - -############################################################################# - -=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES - -B provides several methods which subclasses may want to override -to perform any special pre/post-processing. These methods do I have to -be overridden, but it may be useful for subclasses to take advantage of them. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B - - my $parser = Pod::Parser->new(); - -This is the constructor for B and its subclasses. You -I need to override this method! It is capable of constructing -subclass objects as well as base class objects, provided you use -any of the following constructor invocation styles: - - my $parser1 = MyParser->new(); - my $parser2 = new MyParser(); - my $parser3 = $parser2->new(); - -where C is some subclass of B. - -Using the syntax C to invoke the constructor is I -recommended, but if you insist on being able to do this, then the -subclass I need to override the B constructor method. If -you do override the constructor, you I be sure to invoke the -B method of the newly blessed object. - -Using any of the above invocations, the first argument to the -constructor is always the corresponding package name (or object -reference). No other arguments are required, but if desired, an -associative array (or hash-table) my be passed to the B -constructor, as in: - - my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 ); - my $parser2 = new MyParser( -myflag => 1 ); - -All arguments passed to the B constructor will be treated as -key/value pairs in a hash-table. The newly constructed object will be -initialized by copying the contents of the given hash-table (which may -have been empty). The B constructor for this class and all of its -subclasses returns a blessed reference to the initialized object (hash-table). - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my ($this,%params) = @_; - my $class = ref($this) || $this; - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. - my $self = { %params }; - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - $self->initialize(); - return $self; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->initialize(); - -This method performs any necessary object initialization. It takes no -arguments (other than the object instance of course, which is typically -copied to a local variable named C<$self>). If subclasses override this -method then they I be sure to invoke C<$self-ESUPER::initialize()>. - -=cut - -sub initialize { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->begin_pod(); - -This method is invoked at the beginning of processing for each POD -document that is encountered in the input. Subclasses should override -this method to perform any per-document initialization. - -=cut - -sub begin_pod { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->begin_input(); - -This method is invoked by B immediately I -processing input from a filehandle. The base class implementation does -nothing, however, subclasses may override it to perform any per-file -initializations. - -Note that if multiple files are parsed for a single POD document -(perhaps the result of some future C<=include> directive) this method -is invoked for every file that is parsed. If you wish to perform certain -initializations once per document, then you should use B. - -=cut - -sub begin_input { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->end_input(); - -This method is invoked by B immediately I -processing input from a filehandle. The base class implementation does -nothing, however, subclasses may override it to perform any per-file -cleanup actions. - -Please note that if multiple files are parsed for a single POD document -(perhaps the result of some kind of C<=include> directive) this method -is invoked for every file that is parsed. If you wish to perform certain -cleanup actions once per document, then you should use B. - -=cut - -sub end_input { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->end_pod(); - -This method is invoked at the end of processing for each POD document -that is encountered in the input. Subclasses should override this method -to perform any per-document finalization. - -=cut - -sub end_pod { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $textline = $parser->preprocess_line($text, $line_num); - -This method should be overridden by subclasses that wish to perform -any kind of preprocessing for each I of input (I it has -been determined whether or not it is part of a POD paragraph). The -parameter C<$text> is the input line; and the parameter C<$line_num> is -the line number of the corresponding text line. - -The value returned should correspond to the new text to use in its -place. If the empty string or an undefined value is returned then no -further processing will be performed for this line. - -Please note that the B method is invoked I -the B method. After all (possibly preprocessed) -lines in a paragraph have been assembled together and it has been -determined that the paragraph is part of the POD documentation from one -of the selected sections, then B is invoked. - -The base class implementation of this method returns the given text. - -=cut - -sub preprocess_line { - my ($self, $text, $line_num) = @_; - return $text; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $textblock = $parser->preprocess_paragraph($text, $line_num); - -This method should be overridden by subclasses that wish to perform any -kind of preprocessing for each block (paragraph) of POD documentation -that appears in the input stream. The parameter C<$text> is the POD -paragraph from the input file; and the parameter C<$line_num> is the -line number for the beginning of the corresponding paragraph. - -The value returned should correspond to the new text to use in its -place If the empty string is returned or an undefined value is -returned, then the given C<$text> is ignored (not processed). - -This method is invoked after gathering up all the lines in a paragraph -and after determining the cutting state of the paragraph, -but before trying to further parse or interpret them. After -B returns, the current cutting state (which -is returned by C<$self-Ecutting()>) is examined. If it evaluates -to true then input text (including the given C<$text>) is cut (not -processed) until the next POD directive is encountered. - -Please note that the B method is invoked I -the B method. After all (possibly preprocessed) -lines in a paragraph have been assembled together and either it has been -determined that the paragraph is part of the POD documentation from one -of the selected sections or the C<-want_nonPODs> option is true, -then B is invoked. - -The base class implementation of this method returns the given text. - -=cut - -sub preprocess_paragraph { - my ($self, $text, $line_num) = @_; - return $text; -} - -############################################################################# - -=head1 METHODS FOR PARSING AND PROCESSING - -B provides several methods to process input text. These -methods typically won't need to be overridden (and in some cases they -can't be overridden), but subclasses may want to invoke them to exploit -their functionality. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B - - $ptree1 = $parser->parse_text($text, $line_num); - $ptree2 = $parser->parse_text({%opts}, $text, $line_num); - $ptree3 = $parser->parse_text(\%opts, $text, $line_num); - -This method is useful if you need to perform your own interpolation -of interior sequences and can't rely upon B to expand -them in simple bottom-up order. - -The parameter C<$text> is a string or block of text to be parsed -for interior sequences; and the parameter C<$line_num> is the -line number corresponding to the beginning of C<$text>. - -B will parse the given text into a parse-tree of "nodes." -and interior-sequences. Each "node" in the parse tree is either a -text-string, or a B. The result returned is a -parse-tree of type B. Please see L -for more information about B and B. - -If desired, an optional hash-ref may be specified as the first argument -to customize certain aspects of the parse-tree that is created and -returned. The set of recognized option keywords are: - -=over 3 - -=item B<-expand_seq> =E I|I - -Normally, the parse-tree returned by B will contain an -unexpanded C object for each interior-sequence -encountered. Specifying B<-expand_seq> tells B to "expand" -every interior-sequence it sees by invoking the referenced function -(or named method of the parser object) and using the return value as the -expanded result. - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $sequence ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $sequence ) - -where C<$parser> is a reference to the parser object, and C<$sequence> -is a reference to the interior-sequence object. -[I: If the B method is specified, then it is -invoked according to the interface specified in L<"interior_sequence()">]. - -=item B<-expand_text> =E I|I - -Normally, the parse-tree returned by B will contain a -text-string for each contiguous sequence of characters outside of an -interior-sequence. Specifying B<-expand_text> tells B to -"preprocess" every such text-string it sees by invoking the referenced -function (or named method of the parser object) and using the return value -as the preprocessed (or "expanded") result. [Note that if the result is -an interior-sequence, then it will I be expanded as specified by the -B<-expand_seq> option; Any such recursive expansion needs to be handled by -the specified callback routine.] - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $text, $ptree_node ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $text, $ptree_node ) - -where C<$parser> is a reference to the parser object, C<$text> is the -text-string encountered, and C<$ptree_node> is a reference to the current -node in the parse-tree (usually an interior-sequence object or else the -top-level node of the parse-tree). - -=item B<-expand_ptree> =E I|I - -Rather than returning a C, pass the parse-tree as an -argument to the referenced subroutine (or named method of the parser -object) and return the result instead of the parse-tree object. - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $ptree ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $ptree ) - -where C<$parser> is a reference to the parser object, and C<$ptree> -is a reference to the parse-tree object. - -=back - -=cut - -sub parse_text { - my $self = shift; - local $_ = ''; - - ## Get options and set any defaults - my %opts = (ref $_[0]) ? %{ shift() } : (); - my $expand_seq = $opts{'-expand_seq'} || undef; - my $expand_text = $opts{'-expand_text'} || undef; - my $expand_ptree = $opts{'-expand_ptree'} || undef; - - my $text = shift; - my $line = shift; - my $file = $self->input_file(); - my $cmd = ""; - - ## Convert method calls into closures, for our convenience - my $xseq_sub = $expand_seq; - my $xtext_sub = $expand_text; - my $xptree_sub = $expand_ptree; - if (defined $expand_seq and $expand_seq eq 'interior_sequence') { - ## If 'interior_sequence' is the method to use, we have to pass - ## more than just the sequence object, we also need to pass the - ## sequence name and text. - $xseq_sub = sub { - my ($sself, $iseq) = @_; - my $args = join('', $iseq->parse_tree->children); - return $sself->interior_sequence($iseq->name, $args, $iseq); - }; - } - ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; - ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) }; - ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; - - ## Keep track of the "current" interior sequence, and maintain a stack - ## of "in progress" sequences. - ## - ## NOTE that we push our own "accumulator" at the very beginning of the - ## stack. It's really a parse-tree, not a sequence; but it implements - ## the methods we need so we can use it to gather-up all the sequences - ## and strings we parse. Thus, by the end of our parsing, it should be - ## the only thing left on our stack and all we have to do is return it! - ## - my $seq = Pod::ParseTree->new(); - my @seq_stack = ($seq); - my ($ldelim, $rdelim) = ('', ''); - - ## Iterate over all sequence starts text (NOTE: split with - ## capturing parens keeps the delimiters) - $_ = $text; - my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/; - while ( @tokens ) { - $_ = shift @tokens; - ## Look for the beginning of a sequence - if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) { - ## Push a new sequence onto the stack of those "in-progress" - my $ldelim_orig; - ($cmd, $ldelim_orig) = ($1, $2); - ($ldelim = $ldelim_orig) =~ s/\s+$//; - ($rdelim = $ldelim) =~ tr//; - $seq = Pod::InteriorSequence->new( - -name => $cmd, - -ldelim => $ldelim_orig, -rdelim => $rdelim, - -file => $file, -line => $line - ); - (@seq_stack > 1) and $seq->nested($seq_stack[-1]); - push @seq_stack, $seq; - } - ## Look for sequence ending - elsif ( @seq_stack > 1 ) { - ## Make sure we match the right kind of closing delimiter - my ($seq_end, $post_seq) = ('', ''); - if ( ($ldelim eq '<' and /\A(.*?)(>)/s) - or /\A(.*?)(\s+$rdelim)/s ) - { - ## Found end-of-sequence, capture the interior and the - ## closing the delimiter, and put the rest back on the - ## token-list - $post_seq = substr($_, length($1) + length($2)); - ($_, $seq_end) = ($1, $2); - (length $post_seq) and unshift @tokens, $post_seq; - } - if (length) { - ## In the middle of a sequence, append this text to it, and - ## dont forget to "expand" it if that's what the caller wanted - $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); - $_ .= $seq_end; - } - if (length $seq_end) { - ## End of current sequence, record terminating delimiter - $seq->rdelim($seq_end); - ## Pop it off the stack of "in progress" sequences - pop @seq_stack; - ## Append result to its parent in current parse tree - $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) - : $seq); - ## Remember the current cmd-name and left-delimiter - if(@seq_stack > 1) { - $cmd = $seq_stack[-1]->name; - $ldelim = $seq_stack[-1]->ldelim; - $rdelim = $seq_stack[-1]->rdelim; - } else { - $cmd = $ldelim = $rdelim = ''; - } - } - } - elsif (length) { - ## In the middle of a sequence, append this text to it, and - ## dont forget to "expand" it if that's what the caller wanted - $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); - } - ## Keep track of line count - $line += /\n/; - ## Remember the "current" sequence - $seq = $seq_stack[-1]; - } - - ## Handle unterminated sequences - my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; - while (@seq_stack > 1) { - ($cmd, $file, $line) = ($seq->name, $seq->file_line); - $ldelim = $seq->ldelim; - ($rdelim = $ldelim) =~ tr//; - $rdelim =~ s/^(\S+)(\s*)$/$2$1/; - pop @seq_stack; - my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}". - " at line $line in file $file\n"; - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $self->$errorsub($errmsg) - or carp($errmsg); - $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); - $seq = $seq_stack[-1]; - } - - ## Return the resulting parse-tree - my $ptree = (pop @seq_stack)->parse_tree; - return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $textblock = $parser->interpolate($text, $line_num); - -This method translates all text (including any embedded interior sequences) -in the given text string C<$text> and returns the interpolated result. The -parameter C<$line_num> is the line number corresponding to the beginning -of C<$text>. - -B merely invokes a private method to recursively expand -nested interior sequences in bottom-up order (innermost sequences are -expanded first). If there is a need to expand nested sequences in -some alternate order, use B instead. - -=cut - -sub interpolate { - my($self, $text, $line_num) = @_; - my %parse_opts = ( -expand_seq => 'interior_sequence' ); - my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); - return join '', $ptree->children(); -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B - - $parser->parse_paragraph($text, $line_num); - -This method takes the text of a POD paragraph to be processed, along -with its corresponding line number, and invokes the appropriate method -(one of B, B, or B). - -For performance reasons, this method is invoked directly without any -dynamic lookup; Hence subclasses may I override it! - -=end __PRIVATE__ - -=cut - -sub parse_paragraph { - my ($self, $text, $line_num) = @_; - local *myData = $self; ## alias to avoid deref-ing overhead - local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options - local $_; - - ## See if we want to preprocess nonPOD paragraphs as well as POD ones. - my $wantNonPods = $myOpts{'-want_nonPODs'}; - - ## Update cutting status - $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/; - - ## Perform any desired preprocessing if we wanted it this early - $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num); - - ## Ignore up until next POD directive if we are cutting - return if $myData{_CUTTING}; - - ## Now we know this is block of text in a POD section! - - ##----------------------------------------------------------------- - ## This is a hook (hack ;-) for Pod::Select to do its thing without - ## having to override methods, but also without Pod::Parser assuming - ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS - ## field exists then we assume there is an is_selected() method for - ## us to invoke (calling $self->can('is_selected') could verify this - ## but that is more overhead than I want to incur) - ##----------------------------------------------------------------- - - ## Ignore this block if it isnt in one of the selected sections - if (exists $myData{_SELECTED_SECTIONS}) { - $self->is_selected($text) or return ($myData{_CUTTING} = 1); - } - - ## If we havent already, perform any desired preprocessing and - ## then re-check the "cutting" state - unless ($wantNonPods) { - $text = $self->preprocess_paragraph($text, $line_num); - return 1 unless ((defined $text) and (length $text)); - return 1 if ($myData{_CUTTING}); - } - - ## Look for one of the three types of paragraphs - my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); - my $pod_para = undef; - if ($text =~ /^(={1,2})(?=\S)/) { - ## Looks like a command paragraph. Capture the command prefix used - ## ("=" or "=="), as well as the command-name, its paragraph text, - ## and whatever sequence of characters was used to separate them - $pfx = $1; - $_ = substr($text, length $pfx); - ($cmd, $sep, $text) = split /(\s+)/, $_, 2; - $sep = '' unless defined $sep; - $text = '' unless defined $text; - ## If this is a "cut" directive then we dont need to do anything - ## except return to "cutting" mode. - if ($cmd eq 'cut') { - $myData{_CUTTING} = 1; - return unless $myOpts{'-process_cut_cmd'}; - } - } - ## Save the attributes indicating how the command was specified. - $pod_para = new Pod::Paragraph( - -name => $cmd, - -text => $text, - -prefix => $pfx, - -separator => $sep, - -file => $myData{_INFILE}, - -line => $line_num - ); - # ## Invoke appropriate callbacks - # if (exists $myData{_CALLBACKS}) { - # ## Look through the callback list, invoke callbacks, - # ## then see if we need to do the default actions - # ## (invoke_callbacks will return true if we do). - # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para); - # } - - # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp - if ($myData{_WHITESPACE} and $myOpts{'-warnings'} - and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) { - my $errorsub = $self->errorsub(); - my $line = $line_num - 1; - my $errmsg = "*** WARNING: line containing nothing but whitespace". - " in paragraph at line $line in file $myData{_INFILE}\n"; - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $self->$errorsub($errmsg) - or carp($errmsg); - } - - if (length $cmd) { - ## A command paragraph - $self->command($cmd, $text, $line_num, $pod_para); - $myData{_PREVIOUS} = $cmd; - } - elsif ($text =~ /^\s+/) { - ## Indented text - must be a verbatim paragraph - $self->verbatim($text, $line_num, $pod_para); - $myData{_PREVIOUS} = "verbatim"; - } - else { - ## Looks like an ordinary block of text - $self->textblock($text, $line_num, $pod_para); - $myData{_PREVIOUS} = "textblock"; - } - - # Update the whitespace for the next time around - #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0; - $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0; - - return 1; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->parse_from_filehandle($in_fh,$out_fh); - -This method takes an input filehandle (which is assumed to already be -opened for reading) and reads the entire input stream looking for blocks -(paragraphs) of POD documentation to be processed. If no first argument -is given the default input filehandle C is used. - -The C<$in_fh> parameter may be any object that provides a B -method to retrieve a single line of input text (hence, an appropriate -wrapper object could be used to parse PODs from a single string or an -array of strings). - -Using C<$in_fh-Egetline()>, input is read line-by-line and assembled -into paragraphs or "blocks" (which are separated by lines containing -nothing but whitespace). For each block of POD documentation -encountered it will invoke a method to parse the given paragraph. - -If a second argument is given then it should correspond to a filehandle where -output should be sent (otherwise the default output filehandle is -C if no output filehandle is currently in use). - -B For performance reasons, this method caches the input stream at -the top of the stack in a local variable. Any attempts by clients to -change the stack contents during processing when in the midst executing -of this method I the input stream used by the current -invocation of this method. - -This method does I usually need to be overridden by subclasses. - -=cut - -sub parse_from_filehandle { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); - my ($in_fh, $out_fh) = @_; - $in_fh = \*STDIN unless ($in_fh); - local *myData = $self; ## alias to avoid deref-ing overhead - local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options - local $_; - - ## Put this stream at the top of the stack and do beginning-of-input - ## processing. NOTE that $in_fh might be reset during this process. - my $topstream = $self->_push_input_stream($in_fh, $out_fh); - (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} ); - - ## Initialize line/paragraph - my ($textline, $paragraph) = ('', ''); - my ($nlines, $plines) = (0, 0); - - ## Use <$fh> instead of $fh->getline where possible (for speed) - $_ = ref $in_fh; - my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh); - - ## Read paragraphs line-by-line - while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { - $textline = $self->preprocess_line($textline, ++$nlines); - next unless ((defined $textline) && (length $textline)); - - if ((! length $paragraph) && ($textline =~ /^==/)) { - ## '==' denotes a one-line command paragraph - $paragraph = $textline; - $plines = 1; - $textline = ''; - } else { - ## Append this line to the current paragraph - $paragraph .= $textline; - ++$plines; - } - - ## See if this line is blank and ends the current paragraph. - ## If it isnt, then keep iterating until it is. - next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/) - && (length $paragraph)); - - ## Now process the paragraph - parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); - $paragraph = ''; - $plines = 0; - } - ## Dont forget about the last paragraph in the file - if (length $paragraph) { - parse_paragraph($self, $paragraph, ($nlines - $plines) + 1) - } - - ## Now pop the input stream off the top of the input stack. - $self->_pop_input_stream(); -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->parse_from_file($filename,$outfile); - -This method takes a filename and does the following: - -=over 2 - -=item * - -opens the input and output files for reading -(creating the appropriate filehandles) - -=item * - -invokes the B method passing it the -corresponding input and output filehandles. - -=item * - -closes the input and output files. - -=back - -If the special input filename "-" or "<&STDIN" is given then the STDIN -filehandle is used for input (and no open or close is performed). If no -input filename is specified then "-" is implied. Filehandle references, -or objects that support the regular IO operations (like C$fhE> -or C<$fh-getline>) are also accepted; the handles must already be -opened. - -If a second argument is given then it should be the name of the desired -output file. If the special output filename "-" or ">&STDOUT" is given -then the STDOUT filehandle is used for output (and no open or close is -performed). If the special output filename ">&STDERR" is given then the -STDERR filehandle is used for output (and no open or close is -performed). If no output filehandle is currently in use and no output -filename is specified, then "-" is implied. -Alternatively, filehandle references or objects that support the regular -IO operations (like C, e.g. L) are also accepted; -the object must already be opened. - -This method does I usually need to be overridden by subclasses. - -=cut - -sub parse_from_file { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); - my ($infile, $outfile) = @_; - my ($in_fh, $out_fh); - if ($] < 5.006) { - ($in_fh, $out_fh) = (gensym(), gensym()); - } - my ($close_input, $close_output) = (0, 0); - local *myData = $self; - local *_; - - ## Is $infile a filename or a (possibly implied) filehandle - if (defined $infile && ref $infile) { - if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) { - croak "Input from $1 reference not supported!\n"; - } - ## Must be a filehandle-ref (or else assume its a ref to an object - ## that supports the common IO read operations). - $myData{_INFILE} = ${$infile}; - $in_fh = $infile; - } - elsif (!defined($infile) || !length($infile) || ($infile eq '-') - || ($infile =~ /^<&(?:STDIN|0)$/i)) - { - ## Not a filename, just a string implying STDIN - $infile ||= '-'; - $myData{_INFILE} = ''; - $in_fh = \*STDIN; - } - else { - ## We have a filename, open it for reading - $myData{_INFILE} = $infile; - open($in_fh, "< $infile") or - croak "Can't open $infile for reading: $!\n"; - $close_input = 1; - } - - ## NOTE: we need to be *very* careful when "defaulting" the output - ## file. We only want to use a default if this is the beginning of - ## the entire document (but *not* if this is an included file). We - ## determine this by seeing if the input stream stack has been set-up - ## already - - ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref? - if (ref $outfile) { - ## we need to check for ref() first, as other checks involve reading - if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) { - croak "Output to $1 reference not supported!\n"; - } - elsif (ref($outfile) eq 'SCALAR') { -# # NOTE: IO::String isn't a part of the perl distribution, -# # so probably we shouldn't support this case... -# require IO::String; -# $myData{_OUTFILE} = "$outfile"; -# $out_fh = IO::String->new($outfile); - croak "Output to SCALAR reference not supported!\n"; - } - else { - ## Must be a filehandle-ref (or else assume its a ref to an - ## object that supports the common IO write operations). - $myData{_OUTFILE} = ${$outfile}; - $out_fh = $outfile; - } - } - elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-') - || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) - { - if (defined $myData{_TOP_STREAM}) { - $out_fh = $myData{_OUTPUT}; - } - else { - ## Not a filename, just a string implying STDOUT - $outfile ||= '-'; - $myData{_OUTFILE} = ''; - $out_fh = \*STDOUT; - } - } - elsif ($outfile =~ /^>&(STDERR|2)$/i) { - ## Not a filename, just a string implying STDERR - $myData{_OUTFILE} = ''; - $out_fh = \*STDERR; - } - else { - ## We have a filename, open it for writing - $myData{_OUTFILE} = $outfile; - (-d $outfile) and croak "$outfile is a directory, not POD input!\n"; - open($out_fh, "> $outfile") or - croak "Can't open $outfile for writing: $!\n"; - $close_output = 1; - } - - ## Whew! That was a lot of work to set up reasonably/robust behavior - ## in the case of a non-filename for reading and writing. Now we just - ## have to parse the input and close the handles when we're finished. - $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); - - $close_input and - close($in_fh) || croak "Can't close $infile after reading: $!\n"; - $close_output and - close($out_fh) || croak "Can't close $outfile after writing: $!\n"; -} - -############################################################################# - -=head1 ACCESSOR METHODS - -Clients of B should use the following methods to access -instance data fields: - -=cut - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->errorsub("method_name"); - $parser->errorsub(\&warn_user); - $parser->errorsub(sub { print STDERR, @_ }); - -Specifies the method or subroutine to use when printing error messages -about POD syntax. The supplied method/subroutine I return TRUE upon -successful printing of the message. If C is given, then the B -builtin is used to issue error messages (this is the default behavior). - - my $errorsub = $parser->errorsub() - my $errmsg = "This is an error message!\n" - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $parser->$errorsub($errmsg) - or carp($errmsg); - -Returns a method name, or else a reference to the user-supplied subroutine -used to print error messages. Returns C if the B builtin -is used to issue error messages (this is the default behavior). - -=cut - -sub errorsub { - return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $boolean = $parser->cutting(); - -Returns the current C state: a boolean-valued scalar which -evaluates to true if text from the input file is currently being "cut" -(meaning it is I considered part of the POD document). - - $parser->cutting($boolean); - -Sets the current C state to the given value and returns the -result. - -=cut - -sub cutting { - return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; -} - -##--------------------------------------------------------------------------- - -##--------------------------------------------------------------------------- - -=head1 B - -When invoked with no additional arguments, B returns a hashtable -of all the current parsing options. - - ## See if we are parsing non-POD sections as well as POD ones - my %opts = $parser->parseopts(); - $opts{'-want_nonPODs}' and print "-want_nonPODs\n"; - -When invoked using a single string, B treats the string as the -name of a parse-option and returns its corresponding value if it exists -(returns C if it doesn't). - - ## Did we ask to see '=cut' paragraphs? - my $want_cut = $parser->parseopts('-process_cut_cmd'); - $want_cut and print "-process_cut_cmd\n"; - -When invoked with multiple arguments, B treats them as -key/value pairs and the specified parse-option names are set to the -given values. Any unspecified parse-options are unaffected. - - ## Set them back to the default - $parser->parseopts(-warnings => 0); - -When passed a single hash-ref, B uses that hash to completely -reset the existing parse-options, all previous parse-option values -are lost. - - ## Reset all options to default - $parser->parseopts( { } ); - -See L<"PARSING OPTIONS"> for more information on the name and meaning of each -parse-option currently recognized. - -=cut - -sub parseopts { - local *myData = shift; - local *myOpts = ($myData{_PARSEOPTS} ||= {}); - return %myOpts if (@_ == 0); - if (@_ == 1) { - local $_ = shift; - return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_}; - } - my @newOpts = (%myOpts, @_); - $myData{_PARSEOPTS} = { @newOpts }; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $fname = $parser->output_file(); - -Returns the name of the output file being written. - -=cut - -sub output_file { - return $_[0]->{_OUTFILE}; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $fhandle = $parser->output_handle(); - -Returns the output filehandle object. - -=cut - -sub output_handle { - return $_[0]->{_OUTPUT}; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $fname = $parser->input_file(); - -Returns the name of the input file being read. - -=cut - -sub input_file { - return $_[0]->{_INFILE}; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $fhandle = $parser->input_handle(); - -Returns the current input filehandle object. - -=cut - -sub input_handle { - return $_[0]->{_INPUT}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B - - $listref = $parser->input_streams(); - -Returns a reference to an array which corresponds to the stack of all -the input streams that are currently in the middle of being parsed. - -While parsing an input stream, it is possible to invoke -B or B to parse a new input -stream and then return to parsing the previous input stream. Each input -stream to be parsed is pushed onto the end of this input stack -before any of its input is read. The input stream that is currently -being parsed is always at the end (or top) of the input stack. When an -input stream has been exhausted, it is popped off the end of the -input stack. - -Each element on this input stack is a reference to C -object. Please see L for more details. - -This method might be invoked when printing diagnostic messages, for example, -to obtain the name and line number of the all input files that are currently -being processed. - -=end __PRIVATE__ - -=cut - -sub input_streams { - return $_[0]->{_INPUT_STREAMS}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B - - $hashref = $parser->top_stream(); - -Returns a reference to the hash-table that represents the element -that is currently at the top (end) of the input stream stack -(see L<"input_streams()">). The return value will be the C -if the input stack is empty. - -This method might be used when printing diagnostic messages, for example, -to obtain the name and line number of the current input file. - -=end __PRIVATE__ - -=cut - -sub top_stream { - return $_[0]->{_TOP_STREAM} || undef; -} - -############################################################################# - -=head1 PRIVATE METHODS AND DATA - -B makes use of several internal methods and data fields -which clients should not need to see or use. For the sake of avoiding -name collisions for client data and methods, these methods and fields -are briefly discussed here. Determined hackers may obtain further -information about them by reading the B source code. - -Private data fields are stored in the hash-object whose reference is -returned by the B constructor for this class. The names of all -private methods and data-fields used by B begin with a -prefix of "_" and match the regular expression C. - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_push_input_stream()> - - $hashref = $parser->_push_input_stream($in_fh,$out_fh); - -This method will push the given input stream on the input stack and -perform any necessary beginning-of-document or beginning-of-file -processing. The argument C<$in_fh> is the input stream filehandle to -push, and C<$out_fh> is the corresponding output filehandle to use (if -it is not given or is undefined, then the current output stream is used, -which defaults to standard output if it doesnt exist yet). - -The value returned will be reference to the hash-table that represents -the new top of the input stream stack. I that it is -possible for this method to use default values for the input and output -file handles. If this happens, you will need to look at the C -and C instance data members to determine their new values. - -=end _PRIVATE_ - -=cut - -sub _push_input_stream { - my ($self, $in_fh, $out_fh) = @_; - local *myData = $self; - - ## Initialize stuff for the entire document if this is *not* - ## an included file. - ## - ## NOTE: we need to be *very* careful when "defaulting" the output - ## filehandle. We only want to use a default value if this is the - ## beginning of the entire document (but *not* if this is an included - ## file). - unless (defined $myData{_TOP_STREAM}) { - $out_fh = \*STDOUT unless (defined $out_fh); - $myData{_CUTTING} = 1; ## current "cutting" state - $myData{_INPUT_STREAMS} = []; ## stack of all input streams - } - - ## Initialize input indicators - $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE}); - $myData{_OUTPUT} = $out_fh if (defined $out_fh); - $in_fh = \*STDIN unless (defined $in_fh); - $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE}); - $myData{_INPUT} = $in_fh; - my $input_top = $myData{_TOP_STREAM} - = new Pod::InputSource( - -name => $myData{_INFILE}, - -handle => $in_fh, - -was_cutting => $myData{_CUTTING} - ); - local *input_stack = $myData{_INPUT_STREAMS}; - push(@input_stack, $input_top); - - ## Perform beginning-of-document and/or beginning-of-input processing - $self->begin_pod() if (@input_stack == 1); - $self->begin_input(); - - return $input_top; -} - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_pop_input_stream()> - - $hashref = $parser->_pop_input_stream(); - -This takes no arguments. It will perform any necessary end-of-file or -end-of-document processing and then pop the current input stream from -the top of the input stack. - -The value returned will be reference to the hash-table that represents -the new top of the input stream stack. - -=end _PRIVATE_ - -=cut - -sub _pop_input_stream { - my ($self) = @_; - local *myData = $self; - local *input_stack = $myData{_INPUT_STREAMS}; - - ## Perform end-of-input and/or end-of-document processing - $self->end_input() if (@input_stack > 0); - $self->end_pod() if (@input_stack == 1); - - ## Restore cutting state to whatever it was before we started - ## parsing this file. - my $old_top = pop(@input_stack); - $myData{_CUTTING} = $old_top->was_cutting(); - - ## Dont forget to reset the input indicators - my $input_top = undef; - if (@input_stack > 0) { - $input_top = $myData{_TOP_STREAM} = $input_stack[-1]; - $myData{_INFILE} = $input_top->name(); - $myData{_INPUT} = $input_top->handle(); - } else { - delete $myData{_TOP_STREAM}; - delete $myData{_INPUT_STREAMS}; - } - - return $input_top; -} - -############################################################################# - -=head1 TREE-BASED PARSING - -If straightforward stream-based parsing wont meet your needs (as is -likely the case for tasks such as translating PODs into structured -markup languages like HTML and XML) then you may need to take the -tree-based approach. Rather than doing everything in one pass and -calling the B method to expand sequences into text, it -may be desirable to instead create a parse-tree using the B -method to return a tree-like structure which may contain an ordered -list of children (each of which may be a text-string, or a similar -tree-like structure). - -Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and -to the objects described in L. The former describes -the gory details and parameters for how to customize and extend the -parsing behavior of B. B provides -several objects that may all be used interchangeably as parse-trees. The -most obvious one is the B object. It defines the basic -interface and functionality that all things trying to be a POD parse-tree -should do. A B is defined such that each "node" may be a -text-string, or a reference to another parse-tree. Each B -object and each B object also supports the basic -parse-tree interface. - -The B method takes a given paragraph of text, and -returns a parse-tree that contains one or more children, each of which -may be a text-string, or an InteriorSequence object. There are also -callback-options that may be passed to B to customize -the way it expands or transforms interior-sequences, as well as the -returned result. These callbacks can be used to create a parse-tree -with custom-made objects (which may or may not support the parse-tree -interface, depending on how you choose to do it). - -If you wish to turn an entire POD document into a parse-tree, that process -is fairly straightforward. The B method is the key to doing -this successfully. Every paragraph-callback (i.e. the polymorphic methods -for B, B, and B paragraphs) takes -a B object as an argument. Each paragraph object has a -B method that can be used to get or set a corresponding -parse-tree. So for each of those paragraph-callback methods, simply call -B with the options you desire, and then use the returned -parse-tree to assign to the given paragraph object. - -That gives you a parse-tree for each paragraph - so now all you need is -an ordered list of paragraphs. You can maintain that yourself as a data -element in the object/hash. The most straightforward way would be simply -to use an array-ref, with the desired set of custom "options" for each -invocation of B. Let's assume the desired option-set is -given by the hash C<%options>. Then we might do something like the -following: - - package MyPodParserTree; - - @ISA = qw( Pod::Parser ); - - ... - - sub begin_pod { - my $self = shift; - $self->{'-paragraphs'} = []; ## initialize paragraph list - } - - sub command { - my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({%options}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - sub verbatim { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - sub textblock { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({%options}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - ... - - package main; - ... - my $parser = new MyPodParserTree(...); - $parser->parse_from_file(...); - my $paragraphs_ref = $parser->{'-paragraphs'}; - -Of course, in this module-author's humble opinion, I'd be more inclined to -use the existing B object than a simple array. That way -everything in it, paragraphs and sequences, all respond to the same core -interface for all parse-tree nodes. The result would look something like: - - package MyPodParserTree2; - - ... - - sub begin_pod { - my $self = shift; - $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree - } - - sub parse_tree { - ## convenience method to get/set the parse-tree for the entire POD - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; - } - - sub command { - my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({<>}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - $parser->parse_tree()->append( $pod_para ); - } - - sub verbatim { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - $parser->parse_tree()->append( $pod_para ); - } - - sub textblock { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({<>}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - $parser->parse_tree()->append( $pod_para ); - } - - ... - - package main; - ... - my $parser = new MyPodParserTree2(...); - $parser->parse_from_file(...); - my $ptree = $parser->parse_tree; - ... - -Now you have the entire POD document as one great big parse-tree. You -can even use the B<-expand_seq> option to B to insert -whole different kinds of objects. Just don't expect B -to know what to do with them after that. That will need to be in your -code. Or, alternatively, you can insert any object you like so long as -it conforms to the B interface. - -One could use this to create subclasses of B and -B for specific commands (or to create your own -custom node-types in the parse-tree) and add some kind of B -method to each custom node/subclass object in the tree. Then all you'd -need to do is recursively walk the tree in the desired order, processing -the children (most likely from left to right) by formatting them if -they are text-strings, or by calling their B method if they -are objects/references. - -=head1 CAVEATS - -Please note that POD has the notion of "paragraphs": this is something -starting I a blank (read: empty) line, with the single exception -of the file start, which is also starting a paragraph. That means that -especially a command (e.g. C<=head1>) I be preceded with a blank -line; C<__END__> is I a blank line. - -=head1 SEE ALSO - -L, L - -B defines POD input objects corresponding to -command paragraphs, parse-trees, and interior-sequences. - -B is a subclass of B which provides the ability -to selectively include and/or exclude sections of a POD document from being -translated based upon the current heading, subheading, subsubheading, etc. - -=for __PRIVATE__ -B is a subclass of B which gives its users -the ability the employ I instead of, or in addition -to, overriding methods of the base class. - -=for __PRIVATE__ -B and B do not override any -methods nor do they define any new methods with the same name. Because -of this, they may I be used (in combination) as a base class of -the same subclass in order to combine their functionality without -causing any namespace clashes due to multiple inheritance. - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=head1 LICENSE - -Pod-Parser is free software; you can redistribute it and/or modify it -under the terms of the Artistic License distributed with Perl version -5.000 or (at your option) any later version. Please refer to the -Artistic License that came with your Perl distribution for more -details. If your version of Perl was not distributed under the -terms of the Artistic License, than you may distribute PodParser -under the same terms as Perl itself. - -=cut - -1; -# vim: ts=4 sw=4 et +############################################################################# +# Pod/Parser.pm -- package which defines a base class for parsing POD docs. +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Parser; +use strict; + +## These "variables" are used as local "glob aliases" for performance +use vars qw($VERSION @ISA %myData %myOpts @input_stack); +$VERSION = '1.60'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::Parser - base class for creating POD filters and translators + +=head1 SYNOPSIS + + use Pod::Parser; + + package MyParser; + @ISA = qw(Pod::Parser); + + sub command { + my ($parser, $command, $paragraph, $line_num) = @_; + ## Interpret the command and its text; sample actions might be: + if ($command eq 'head1') { ... } + elsif ($command eq 'head2') { ... } + ## ... other commands and their actions + my $out_fh = $parser->output_handle(); + my $expansion = $parser->interpolate($paragraph, $line_num); + print $out_fh $expansion; + } + + sub verbatim { + my ($parser, $paragraph, $line_num) = @_; + ## Format verbatim paragraph; sample actions might be: + my $out_fh = $parser->output_handle(); + print $out_fh $paragraph; + } + + sub textblock { + my ($parser, $paragraph, $line_num) = @_; + ## Translate/Format this block of text; sample actions might be: + my $out_fh = $parser->output_handle(); + my $expansion = $parser->interpolate($paragraph, $line_num); + print $out_fh $expansion; + } + + sub interior_sequence { + my ($parser, $seq_command, $seq_argument) = @_; + ## Expand an interior sequence; sample actions might be: + return "*$seq_argument*" if ($seq_command eq 'B'); + return "`$seq_argument'" if ($seq_command eq 'C'); + return "_${seq_argument}_'" if ($seq_command eq 'I'); + ## ... other sequence commands and their resulting text + } + + package main; + + ## Create a parser object and have it parse file whose name was + ## given on the command-line (use STDIN if no files were given). + $parser = new MyParser(); + $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0); + for (@ARGV) { $parser->parse_from_file($_); } + +=head1 REQUIRES + +perl5.005, Pod::InputObjects, Exporter, Symbol, Carp + +=head1 EXPORTS + +Nothing. + +=head1 DESCRIPTION + +B is a base class for creating POD filters and translators. +It handles most of the effort involved with parsing the POD sections +from an input stream, leaving subclasses free to be concerned only with +performing the actual translation of text. + +B parses PODs, and makes method calls to handle the various +components of the POD. Subclasses of B override these methods +to translate the POD into whatever output format they desire. + +Note: This module is considered as legacy; modern Perl releases (5.18 and +higher) are going to remove Pod::Parser from core and use L +for all things POD. + +=head1 QUICK OVERVIEW + +To create a POD filter for translating POD documentation into some other +format, you create a subclass of B which typically overrides +just the base class implementation for the following methods: + +=over 2 + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=back + +You may also want to override the B and B +methods for your subclass (to perform any needed per-file and/or +per-document initialization or cleanup). + +If you need to perform any preprocessing of input before it is parsed +you may want to override one or more of B and/or +B. + +Sometimes it may be necessary to make more than one pass over the input +files. If this is the case you have several options. You can make the +first pass using B and override your methods to store the +intermediate results in memory somewhere for the B method to +process. You could use B for several passes with an +appropriate state variable to control the operation for each pass. If +your input source can't be reset to start at the beginning, you can +store it in some other structure as a string or an array and have that +structure implement a B method (which is all that +B uses to read input). + +Feel free to add any member data fields you need to keep track of things +like current font, indentation, horizontal or vertical position, or +whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA"> +to avoid name collisions. + +For the most part, the B base class should be able to +do most of the input parsing for you and leave you free to worry about +how to interpret the commands and translate the result. + +Note that all we have described here in this quick overview is the +simplest most straightforward use of B to do stream-based +parsing. It is also possible to use the B function +to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. + +=head1 PARSING OPTIONS + +A I is simply a named option of B with a +value that corresponds to a certain specified behavior. These various +behaviors of B may be enabled/disabled by setting +or unsetting one or more I using the B method. +The set of currently accepted parse-options is as follows: + +=over 3 + +=item B<-want_nonPODs> (default: unset) + +Normally (by default) B will only provide access to +the POD sections of the input. Input paragraphs that are not part +of the POD-format documentation are not made available to the caller +(not even using B). Setting this option to a +non-empty, non-zero value will allow B to see +non-POD sections of the input as well as POD sections. The B +method can be used to determine if the corresponding paragraph is a POD +paragraph, or some other input paragraph. + +=item B<-process_cut_cmd> (default: unset) + +Normally (by default) B handles the C<=cut> POD directive +by itself and does not pass it on to the caller for processing. Setting +this option to a non-empty, non-zero value will cause B to +pass the C<=cut> directive to the caller just like any other POD command +(and hence it may be processed by the B method). + +B will still interpret the C<=cut> directive to mean that +"cutting mode" has been (re)entered, but the caller will get a chance +to capture the actual C<=cut> paragraph itself for whatever purpose +it desires. + +=item B<-warnings> (default: unset) + +Normally (by default) B recognizes a bare minimum of +pod syntax errors and warnings and issues diagnostic messages +for errors, but not for warnings. (Use B to do more +thorough checking of POD syntax.) Setting this option to a non-empty, +non-zero value will cause B to issue diagnostics for +the few warnings it recognizes as well as the errors. + +=back + +Please see L<"parseopts()"> for a complete description of the interface +for the setting and unsetting of parse-options. + +=cut + +############################################################################# + +#use diagnostics; +use Pod::InputObjects; +use Carp; +use Exporter; +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} +@ISA = qw(Exporter); + +############################################################################# + +=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES + +B provides several methods which most subclasses will probably +want to override. These methods are as follows: + +=cut + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->command($cmd,$text,$line_num,$pod_para); + +This method should be overridden by subclasses to take the appropriate +action when a POD command paragraph (denoted by a line beginning with +"=") is encountered. When such a POD directive is seen in the input, +this method is called and is passed: + +=over 3 + +=item C<$cmd> + +the name of the command for this POD paragraph + +=item C<$text> + +the paragraph text for the given POD paragraph command. + +=item C<$line_num> + +the line-number of the beginning of the paragraph + +=item C<$pod_para> + +a reference to a C object which contains further +information about the paragraph command (see L +for details). + +=back + +B that this method I called for C<=pod> paragraphs. + +The base class implementation of this method simply treats the raw POD +command as normal block of paragraph text (invoking the B +method with the command paragraph). + +=cut + +sub command { + my ($self, $cmd, $text, $line_num, $pod_para) = @_; + ## Just treat this like a textblock + $self->textblock($pod_para->raw_text(), $line_num, $pod_para); +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->verbatim($text,$line_num,$pod_para); + +This method may be overridden by subclasses to take the appropriate +action when a block of verbatim text is encountered. It is passed the +following parameters: + +=over 3 + +=item C<$text> + +the block of text for the verbatim paragraph + +=item C<$line_num> + +the line-number of the beginning of the paragraph + +=item C<$pod_para> + +a reference to a C object which contains further +information about the paragraph (see L +for details). + +=back + +The base class implementation of this method simply prints the textblock +(unmodified) to the output filehandle. + +=cut + +sub verbatim { + my ($self, $text, $line_num, $pod_para) = @_; + my $out_fh = $self->{_OUTPUT}; + print $out_fh $text; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->textblock($text,$line_num,$pod_para); + +This method may be overridden by subclasses to take the appropriate +action when a normal block of POD text is encountered (although the base +class method will usually do what you want). It is passed the following +parameters: + +=over 3 + +=item C<$text> + +the block of text for the a POD paragraph + +=item C<$line_num> + +the line-number of the beginning of the paragraph + +=item C<$pod_para> + +a reference to a C object which contains further +information about the paragraph (see L +for details). + +=back + +In order to process interior sequences, subclasses implementations of +this method will probably want to invoke either B or +B, passing it the text block C<$text>, and the corresponding +line number in C<$line_num>, and then perform any desired processing upon +the returned result. + +The base class implementation of this method simply prints the text block +as it occurred in the input stream). + +=cut + +sub textblock { + my ($self, $text, $line_num, $pod_para) = @_; + my $out_fh = $self->{_OUTPUT}; + print $out_fh $self->interpolate($text, $line_num); +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq); + +This method should be overridden by subclasses to take the appropriate +action when an interior sequence is encountered. An interior sequence is +an embedded command within a block of text which appears as a command +name (usually a single uppercase character) followed immediately by a +string of text which is enclosed in angle brackets. This method is +passed the sequence command C<$seq_cmd> and the corresponding text +C<$seq_arg>. It is invoked by the B method for each interior +sequence that occurs in the string that it is passed. It should return +the desired text string to be used in place of the interior sequence. +The C<$pod_seq> argument is a reference to a C +object which contains further information about the interior sequence. +Please see L for details if you need to access this +additional information. + +Subclass implementations of this method may wish to invoke the +B method of C<$pod_seq> to see if it is nested inside +some other interior-sequence (and if so, which kind). + +The base class implementation of the B method +simply returns the raw text of the interior sequence (as it occurred +in the input) to the caller. + +=cut + +sub interior_sequence { + my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; + ## Just return the raw text of the interior sequence + return $pod_seq->raw_text(); +} + +############################################################################# + +=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES + +B provides several methods which subclasses may want to override +to perform any special pre/post-processing. These methods do I have to +be overridden, but it may be useful for subclasses to take advantage of them. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B + + my $parser = Pod::Parser->new(); + +This is the constructor for B and its subclasses. You +I need to override this method! It is capable of constructing +subclass objects as well as base class objects, provided you use +any of the following constructor invocation styles: + + my $parser1 = MyParser->new(); + my $parser2 = new MyParser(); + my $parser3 = $parser2->new(); + +where C is some subclass of B. + +Using the syntax C to invoke the constructor is I +recommended, but if you insist on being able to do this, then the +subclass I need to override the B constructor method. If +you do override the constructor, you I be sure to invoke the +B method of the newly blessed object. + +Using any of the above invocations, the first argument to the +constructor is always the corresponding package name (or object +reference). No other arguments are required, but if desired, an +associative array (or hash-table) my be passed to the B +constructor, as in: + + my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 ); + my $parser2 = new MyParser( -myflag => 1 ); + +All arguments passed to the B constructor will be treated as +key/value pairs in a hash-table. The newly constructed object will be +initialized by copying the contents of the given hash-table (which may +have been empty). The B constructor for this class and all of its +subclasses returns a blessed reference to the initialized object (hash-table). + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my ($this,%params) = @_; + my $class = ref($this) || $this; + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. + my $self = { %params }; + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + $self->initialize(); + return $self; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->initialize(); + +This method performs any necessary object initialization. It takes no +arguments (other than the object instance of course, which is typically +copied to a local variable named C<$self>). If subclasses override this +method then they I be sure to invoke C<$self-ESUPER::initialize()>. + +=cut + +sub initialize { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->begin_pod(); + +This method is invoked at the beginning of processing for each POD +document that is encountered in the input. Subclasses should override +this method to perform any per-document initialization. + +=cut + +sub begin_pod { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->begin_input(); + +This method is invoked by B immediately I +processing input from a filehandle. The base class implementation does +nothing, however, subclasses may override it to perform any per-file +initializations. + +Note that if multiple files are parsed for a single POD document +(perhaps the result of some future C<=include> directive) this method +is invoked for every file that is parsed. If you wish to perform certain +initializations once per document, then you should use B. + +=cut + +sub begin_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->end_input(); + +This method is invoked by B immediately I +processing input from a filehandle. The base class implementation does +nothing, however, subclasses may override it to perform any per-file +cleanup actions. + +Please note that if multiple files are parsed for a single POD document +(perhaps the result of some kind of C<=include> directive) this method +is invoked for every file that is parsed. If you wish to perform certain +cleanup actions once per document, then you should use B. + +=cut + +sub end_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->end_pod(); + +This method is invoked at the end of processing for each POD document +that is encountered in the input. Subclasses should override this method +to perform any per-document finalization. + +=cut + +sub end_pod { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $textline = $parser->preprocess_line($text, $line_num); + +This method should be overridden by subclasses that wish to perform +any kind of preprocessing for each I of input (I it has +been determined whether or not it is part of a POD paragraph). The +parameter C<$text> is the input line; and the parameter C<$line_num> is +the line number of the corresponding text line. + +The value returned should correspond to the new text to use in its +place. If the empty string or an undefined value is returned then no +further processing will be performed for this line. + +Please note that the B method is invoked I +the B method. After all (possibly preprocessed) +lines in a paragraph have been assembled together and it has been +determined that the paragraph is part of the POD documentation from one +of the selected sections, then B is invoked. + +The base class implementation of this method returns the given text. + +=cut + +sub preprocess_line { + my ($self, $text, $line_num) = @_; + return $text; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $textblock = $parser->preprocess_paragraph($text, $line_num); + +This method should be overridden by subclasses that wish to perform any +kind of preprocessing for each block (paragraph) of POD documentation +that appears in the input stream. The parameter C<$text> is the POD +paragraph from the input file; and the parameter C<$line_num> is the +line number for the beginning of the corresponding paragraph. + +The value returned should correspond to the new text to use in its +place If the empty string is returned or an undefined value is +returned, then the given C<$text> is ignored (not processed). + +This method is invoked after gathering up all the lines in a paragraph +and after determining the cutting state of the paragraph, +but before trying to further parse or interpret them. After +B returns, the current cutting state (which +is returned by C<$self-Ecutting()>) is examined. If it evaluates +to true then input text (including the given C<$text>) is cut (not +processed) until the next POD directive is encountered. + +Please note that the B method is invoked I +the B method. After all (possibly preprocessed) +lines in a paragraph have been assembled together and either it has been +determined that the paragraph is part of the POD documentation from one +of the selected sections or the C<-want_nonPODs> option is true, +then B is invoked. + +The base class implementation of this method returns the given text. + +=cut + +sub preprocess_paragraph { + my ($self, $text, $line_num) = @_; + return $text; +} + +############################################################################# + +=head1 METHODS FOR PARSING AND PROCESSING + +B provides several methods to process input text. These +methods typically won't need to be overridden (and in some cases they +can't be overridden), but subclasses may want to invoke them to exploit +their functionality. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B + + $ptree1 = $parser->parse_text($text, $line_num); + $ptree2 = $parser->parse_text({%opts}, $text, $line_num); + $ptree3 = $parser->parse_text(\%opts, $text, $line_num); + +This method is useful if you need to perform your own interpolation +of interior sequences and can't rely upon B to expand +them in simple bottom-up order. + +The parameter C<$text> is a string or block of text to be parsed +for interior sequences; and the parameter C<$line_num> is the +line number corresponding to the beginning of C<$text>. + +B will parse the given text into a parse-tree of "nodes." +and interior-sequences. Each "node" in the parse tree is either a +text-string, or a B. The result returned is a +parse-tree of type B. Please see L +for more information about B and B. + +If desired, an optional hash-ref may be specified as the first argument +to customize certain aspects of the parse-tree that is created and +returned. The set of recognized option keywords are: + +=over 3 + +=item B<-expand_seq> =E I|I + +Normally, the parse-tree returned by B will contain an +unexpanded C object for each interior-sequence +encountered. Specifying B<-expand_seq> tells B to "expand" +every interior-sequence it sees by invoking the referenced function +(or named method of the parser object) and using the return value as the +expanded result. + +If a subroutine reference was given, it is invoked as: + + &$code_ref( $parser, $sequence ) + +and if a method-name was given, it is invoked as: + + $parser->method_name( $sequence ) + +where C<$parser> is a reference to the parser object, and C<$sequence> +is a reference to the interior-sequence object. +[I: If the B method is specified, then it is +invoked according to the interface specified in L<"interior_sequence()">]. + +=item B<-expand_text> =E I|I + +Normally, the parse-tree returned by B will contain a +text-string for each contiguous sequence of characters outside of an +interior-sequence. Specifying B<-expand_text> tells B to +"preprocess" every such text-string it sees by invoking the referenced +function (or named method of the parser object) and using the return value +as the preprocessed (or "expanded") result. [Note that if the result is +an interior-sequence, then it will I be expanded as specified by the +B<-expand_seq> option; Any such recursive expansion needs to be handled by +the specified callback routine.] + +If a subroutine reference was given, it is invoked as: + + &$code_ref( $parser, $text, $ptree_node ) + +and if a method-name was given, it is invoked as: + + $parser->method_name( $text, $ptree_node ) + +where C<$parser> is a reference to the parser object, C<$text> is the +text-string encountered, and C<$ptree_node> is a reference to the current +node in the parse-tree (usually an interior-sequence object or else the +top-level node of the parse-tree). + +=item B<-expand_ptree> =E I|I + +Rather than returning a C, pass the parse-tree as an +argument to the referenced subroutine (or named method of the parser +object) and return the result instead of the parse-tree object. + +If a subroutine reference was given, it is invoked as: + + &$code_ref( $parser, $ptree ) + +and if a method-name was given, it is invoked as: + + $parser->method_name( $ptree ) + +where C<$parser> is a reference to the parser object, and C<$ptree> +is a reference to the parse-tree object. + +=back + +=cut + +sub parse_text { + my $self = shift; + local $_ = ''; + + ## Get options and set any defaults + my %opts = (ref $_[0]) ? %{ shift() } : (); + my $expand_seq = $opts{'-expand_seq'} || undef; + my $expand_text = $opts{'-expand_text'} || undef; + my $expand_ptree = $opts{'-expand_ptree'} || undef; + + my $text = shift; + my $line = shift; + my $file = $self->input_file(); + my $cmd = ""; + + ## Convert method calls into closures, for our convenience + my $xseq_sub = $expand_seq; + my $xtext_sub = $expand_text; + my $xptree_sub = $expand_ptree; + if (defined $expand_seq and $expand_seq eq 'interior_sequence') { + ## If 'interior_sequence' is the method to use, we have to pass + ## more than just the sequence object, we also need to pass the + ## sequence name and text. + $xseq_sub = sub { + my ($sself, $iseq) = @_; + my $args = join('', $iseq->parse_tree->children); + return $sself->interior_sequence($iseq->name, $args, $iseq); + }; + } + ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; + ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) }; + ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; + + ## Keep track of the "current" interior sequence, and maintain a stack + ## of "in progress" sequences. + ## + ## NOTE that we push our own "accumulator" at the very beginning of the + ## stack. It's really a parse-tree, not a sequence; but it implements + ## the methods we need so we can use it to gather-up all the sequences + ## and strings we parse. Thus, by the end of our parsing, it should be + ## the only thing left on our stack and all we have to do is return it! + ## + my $seq = Pod::ParseTree->new(); + my @seq_stack = ($seq); + my ($ldelim, $rdelim) = ('', ''); + + ## Iterate over all sequence starts text (NOTE: split with + ## capturing parens keeps the delimiters) + $_ = $text; + my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/; + while ( @tokens ) { + $_ = shift @tokens; + ## Look for the beginning of a sequence + if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) { + ## Push a new sequence onto the stack of those "in-progress" + my $ldelim_orig; + ($cmd, $ldelim_orig) = ($1, $2); + ($ldelim = $ldelim_orig) =~ s/\s+$//; + ($rdelim = $ldelim) =~ tr//; + $seq = Pod::InteriorSequence->new( + -name => $cmd, + -ldelim => $ldelim_orig, -rdelim => $rdelim, + -file => $file, -line => $line + ); + (@seq_stack > 1) and $seq->nested($seq_stack[-1]); + push @seq_stack, $seq; + } + ## Look for sequence ending + elsif ( @seq_stack > 1 ) { + ## Make sure we match the right kind of closing delimiter + my ($seq_end, $post_seq) = ('', ''); + if ( ($ldelim eq '<' and /\A(.*?)(>)/s) + or /\A(.*?)(\s+$rdelim)/s ) + { + ## Found end-of-sequence, capture the interior and the + ## closing the delimiter, and put the rest back on the + ## token-list + $post_seq = substr($_, length($1) + length($2)); + ($_, $seq_end) = ($1, $2); + (length $post_seq) and unshift @tokens, $post_seq; + } + if (length) { + ## In the middle of a sequence, append this text to it, and + ## dont forget to "expand" it if that's what the caller wanted + $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); + $_ .= $seq_end; + } + if (length $seq_end) { + ## End of current sequence, record terminating delimiter + $seq->rdelim($seq_end); + ## Pop it off the stack of "in progress" sequences + pop @seq_stack; + ## Append result to its parent in current parse tree + $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) + : $seq); + ## Remember the current cmd-name and left-delimiter + if(@seq_stack > 1) { + $cmd = $seq_stack[-1]->name; + $ldelim = $seq_stack[-1]->ldelim; + $rdelim = $seq_stack[-1]->rdelim; + } else { + $cmd = $ldelim = $rdelim = ''; + } + } + } + elsif (length) { + ## In the middle of a sequence, append this text to it, and + ## dont forget to "expand" it if that's what the caller wanted + $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); + } + ## Keep track of line count + $line += /\n/; + ## Remember the "current" sequence + $seq = $seq_stack[-1]; + } + + ## Handle unterminated sequences + my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; + while (@seq_stack > 1) { + ($cmd, $file, $line) = ($seq->name, $seq->file_line); + $ldelim = $seq->ldelim; + ($rdelim = $ldelim) =~ tr//; + $rdelim =~ s/^(\S+)(\s*)$/$2$1/; + pop @seq_stack; + my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}". + " at line $line in file $file\n"; + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errorsub) and $self->$errorsub($errmsg) + or carp($errmsg); + $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); + $seq = $seq_stack[-1]; + } + + ## Return the resulting parse-tree + my $ptree = (pop @seq_stack)->parse_tree; + return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $textblock = $parser->interpolate($text, $line_num); + +This method translates all text (including any embedded interior sequences) +in the given text string C<$text> and returns the interpolated result. The +parameter C<$line_num> is the line number corresponding to the beginning +of C<$text>. + +B merely invokes a private method to recursively expand +nested interior sequences in bottom-up order (innermost sequences are +expanded first). If there is a need to expand nested sequences in +some alternate order, use B instead. + +=cut + +sub interpolate { + my($self, $text, $line_num) = @_; + my %parse_opts = ( -expand_seq => 'interior_sequence' ); + my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); + return join '', $ptree->children(); +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B + + $parser->parse_paragraph($text, $line_num); + +This method takes the text of a POD paragraph to be processed, along +with its corresponding line number, and invokes the appropriate method +(one of B, B, or B). + +For performance reasons, this method is invoked directly without any +dynamic lookup; Hence subclasses may I override it! + +=end __PRIVATE__ + +=cut + +sub parse_paragraph { + my ($self, $text, $line_num) = @_; + local *myData = $self; ## alias to avoid deref-ing overhead + local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options + local $_; + + ## See if we want to preprocess nonPOD paragraphs as well as POD ones. + my $wantNonPods = $myOpts{'-want_nonPODs'}; + + ## Update cutting status + $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/; + + ## Perform any desired preprocessing if we wanted it this early + $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num); + + ## Ignore up until next POD directive if we are cutting + return if $myData{_CUTTING}; + + ## Now we know this is block of text in a POD section! + + ##----------------------------------------------------------------- + ## This is a hook (hack ;-) for Pod::Select to do its thing without + ## having to override methods, but also without Pod::Parser assuming + ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS + ## field exists then we assume there is an is_selected() method for + ## us to invoke (calling $self->can('is_selected') could verify this + ## but that is more overhead than I want to incur) + ##----------------------------------------------------------------- + + ## Ignore this block if it isnt in one of the selected sections + if (exists $myData{_SELECTED_SECTIONS}) { + $self->is_selected($text) or return ($myData{_CUTTING} = 1); + } + + ## If we havent already, perform any desired preprocessing and + ## then re-check the "cutting" state + unless ($wantNonPods) { + $text = $self->preprocess_paragraph($text, $line_num); + return 1 unless ((defined $text) and (length $text)); + return 1 if ($myData{_CUTTING}); + } + + ## Look for one of the three types of paragraphs + my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); + my $pod_para = undef; + if ($text =~ /^(={1,2})(?=\S)/) { + ## Looks like a command paragraph. Capture the command prefix used + ## ("=" or "=="), as well as the command-name, its paragraph text, + ## and whatever sequence of characters was used to separate them + $pfx = $1; + $_ = substr($text, length $pfx); + ($cmd, $sep, $text) = split /(\s+)/, $_, 2; + $sep = '' unless defined $sep; + $text = '' unless defined $text; + ## If this is a "cut" directive then we dont need to do anything + ## except return to "cutting" mode. + if ($cmd eq 'cut') { + $myData{_CUTTING} = 1; + return unless $myOpts{'-process_cut_cmd'}; + } + } + ## Save the attributes indicating how the command was specified. + $pod_para = new Pod::Paragraph( + -name => $cmd, + -text => $text, + -prefix => $pfx, + -separator => $sep, + -file => $myData{_INFILE}, + -line => $line_num + ); + # ## Invoke appropriate callbacks + # if (exists $myData{_CALLBACKS}) { + # ## Look through the callback list, invoke callbacks, + # ## then see if we need to do the default actions + # ## (invoke_callbacks will return true if we do). + # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para); + # } + + # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp + if ($myData{_WHITESPACE} and $myOpts{'-warnings'} + and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) { + my $errorsub = $self->errorsub(); + my $line = $line_num - 1; + my $errmsg = "*** WARNING: line containing nothing but whitespace". + " in paragraph at line $line in file $myData{_INFILE}\n"; + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errorsub) and $self->$errorsub($errmsg) + or carp($errmsg); + } + + if (length $cmd) { + ## A command paragraph + $self->command($cmd, $text, $line_num, $pod_para); + $myData{_PREVIOUS} = $cmd; + } + elsif ($text =~ /^\s+/) { + ## Indented text - must be a verbatim paragraph + $self->verbatim($text, $line_num, $pod_para); + $myData{_PREVIOUS} = "verbatim"; + } + else { + ## Looks like an ordinary block of text + $self->textblock($text, $line_num, $pod_para); + $myData{_PREVIOUS} = "textblock"; + } + + # Update the whitespace for the next time around + #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0; + $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0; + + return 1; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->parse_from_filehandle($in_fh,$out_fh); + +This method takes an input filehandle (which is assumed to already be +opened for reading) and reads the entire input stream looking for blocks +(paragraphs) of POD documentation to be processed. If no first argument +is given the default input filehandle C is used. + +The C<$in_fh> parameter may be any object that provides a B +method to retrieve a single line of input text (hence, an appropriate +wrapper object could be used to parse PODs from a single string or an +array of strings). + +Using C<$in_fh-Egetline()>, input is read line-by-line and assembled +into paragraphs or "blocks" (which are separated by lines containing +nothing but whitespace). For each block of POD documentation +encountered it will invoke a method to parse the given paragraph. + +If a second argument is given then it should correspond to a filehandle where +output should be sent (otherwise the default output filehandle is +C if no output filehandle is currently in use). + +B For performance reasons, this method caches the input stream at +the top of the stack in a local variable. Any attempts by clients to +change the stack contents during processing when in the midst executing +of this method I the input stream used by the current +invocation of this method. + +This method does I usually need to be overridden by subclasses. + +=cut + +sub parse_from_filehandle { + my $self = shift; + my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); + my ($in_fh, $out_fh) = @_; + $in_fh = \*STDIN unless ($in_fh); + local *myData = $self; ## alias to avoid deref-ing overhead + local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options + local $_; + + ## Put this stream at the top of the stack and do beginning-of-input + ## processing. NOTE that $in_fh might be reset during this process. + my $topstream = $self->_push_input_stream($in_fh, $out_fh); + (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} ); + + ## Initialize line/paragraph + my ($textline, $paragraph) = ('', ''); + my ($nlines, $plines) = (0, 0); + + ## Use <$fh> instead of $fh->getline where possible (for speed) + $_ = ref $in_fh; + my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh); + + ## Read paragraphs line-by-line + while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { + $textline = $self->preprocess_line($textline, ++$nlines); + next unless ((defined $textline) && (length $textline)); + + if ((! length $paragraph) && ($textline =~ /^==/)) { + ## '==' denotes a one-line command paragraph + $paragraph = $textline; + $plines = 1; + $textline = ''; + } else { + ## Append this line to the current paragraph + $paragraph .= $textline; + ++$plines; + } + + ## See if this line is blank and ends the current paragraph. + ## If it isnt, then keep iterating until it is. + next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/) + && (length $paragraph)); + + ## Now process the paragraph + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); + $paragraph = ''; + $plines = 0; + } + ## Dont forget about the last paragraph in the file + if (length $paragraph) { + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1) + } + + ## Now pop the input stream off the top of the input stack. + $self->_pop_input_stream(); +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->parse_from_file($filename,$outfile); + +This method takes a filename and does the following: + +=over 2 + +=item * + +opens the input and output files for reading +(creating the appropriate filehandles) + +=item * + +invokes the B method passing it the +corresponding input and output filehandles. + +=item * + +closes the input and output files. + +=back + +If the special input filename "-" or "<&STDIN" is given then the STDIN +filehandle is used for input (and no open or close is performed). If no +input filename is specified then "-" is implied. Filehandle references, +or objects that support the regular IO operations (like C$fhE> +or C<$fh-getline>) are also accepted; the handles must already be +opened. + +If a second argument is given then it should be the name of the desired +output file. If the special output filename "-" or ">&STDOUT" is given +then the STDOUT filehandle is used for output (and no open or close is +performed). If the special output filename ">&STDERR" is given then the +STDERR filehandle is used for output (and no open or close is +performed). If no output filehandle is currently in use and no output +filename is specified, then "-" is implied. +Alternatively, filehandle references or objects that support the regular +IO operations (like C, e.g. L) are also accepted; +the object must already be opened. + +This method does I usually need to be overridden by subclasses. + +=cut + +sub parse_from_file { + my $self = shift; + my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); + my ($infile, $outfile) = @_; + my ($in_fh, $out_fh); + if ($] < 5.006) { + ($in_fh, $out_fh) = (gensym(), gensym()); + } + my ($close_input, $close_output) = (0, 0); + local *myData = $self; + local *_; + + ## Is $infile a filename or a (possibly implied) filehandle + if (defined $infile && ref $infile) { + if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) { + croak "Input from $1 reference not supported!\n"; + } + ## Must be a filehandle-ref (or else assume its a ref to an object + ## that supports the common IO read operations). + $myData{_INFILE} = ${$infile}; + $in_fh = $infile; + } + elsif (!defined($infile) || !length($infile) || ($infile eq '-') + || ($infile =~ /^<&(?:STDIN|0)$/i)) + { + ## Not a filename, just a string implying STDIN + $infile ||= '-'; + $myData{_INFILE} = ''; + $in_fh = \*STDIN; + } + else { + ## We have a filename, open it for reading + $myData{_INFILE} = $infile; + open($in_fh, "< $infile") or + croak "Can't open $infile for reading: $!\n"; + $close_input = 1; + } + + ## NOTE: we need to be *very* careful when "defaulting" the output + ## file. We only want to use a default if this is the beginning of + ## the entire document (but *not* if this is an included file). We + ## determine this by seeing if the input stream stack has been set-up + ## already + + ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref? + if (ref $outfile) { + ## we need to check for ref() first, as other checks involve reading + if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) { + croak "Output to $1 reference not supported!\n"; + } + elsif (ref($outfile) eq 'SCALAR') { +# # NOTE: IO::String isn't a part of the perl distribution, +# # so probably we shouldn't support this case... +# require IO::String; +# $myData{_OUTFILE} = "$outfile"; +# $out_fh = IO::String->new($outfile); + croak "Output to SCALAR reference not supported!\n"; + } + else { + ## Must be a filehandle-ref (or else assume its a ref to an + ## object that supports the common IO write operations). + $myData{_OUTFILE} = ${$outfile}; + $out_fh = $outfile; + } + } + elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-') + || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) + { + if (defined $myData{_TOP_STREAM}) { + $out_fh = $myData{_OUTPUT}; + } + else { + ## Not a filename, just a string implying STDOUT + $outfile ||= '-'; + $myData{_OUTFILE} = ''; + $out_fh = \*STDOUT; + } + } + elsif ($outfile =~ /^>&(STDERR|2)$/i) { + ## Not a filename, just a string implying STDERR + $myData{_OUTFILE} = ''; + $out_fh = \*STDERR; + } + else { + ## We have a filename, open it for writing + $myData{_OUTFILE} = $outfile; + (-d $outfile) and croak "$outfile is a directory, not POD input!\n"; + open($out_fh, "> $outfile") or + croak "Can't open $outfile for writing: $!\n"; + $close_output = 1; + } + + ## Whew! That was a lot of work to set up reasonably/robust behavior + ## in the case of a non-filename for reading and writing. Now we just + ## have to parse the input and close the handles when we're finished. + $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); + + $close_input and + close($in_fh) || croak "Can't close $infile after reading: $!\n"; + $close_output and + close($out_fh) || croak "Can't close $outfile after writing: $!\n"; +} + +############################################################################# + +=head1 ACCESSOR METHODS + +Clients of B should use the following methods to access +instance data fields: + +=cut + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->errorsub("method_name"); + $parser->errorsub(\&warn_user); + $parser->errorsub(sub { print STDERR, @_ }); + +Specifies the method or subroutine to use when printing error messages +about POD syntax. The supplied method/subroutine I return TRUE upon +successful printing of the message. If C is given, then the B +builtin is used to issue error messages (this is the default behavior). + + my $errorsub = $parser->errorsub() + my $errmsg = "This is an error message!\n" + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errorsub) and $parser->$errorsub($errmsg) + or carp($errmsg); + +Returns a method name, or else a reference to the user-supplied subroutine +used to print error messages. Returns C if the B builtin +is used to issue error messages (this is the default behavior). + +=cut + +sub errorsub { + return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $boolean = $parser->cutting(); + +Returns the current C state: a boolean-valued scalar which +evaluates to true if text from the input file is currently being "cut" +(meaning it is I considered part of the POD document). + + $parser->cutting($boolean); + +Sets the current C state to the given value and returns the +result. + +=cut + +sub cutting { + return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; +} + +##--------------------------------------------------------------------------- + +##--------------------------------------------------------------------------- + +=head1 B + +When invoked with no additional arguments, B returns a hashtable +of all the current parsing options. + + ## See if we are parsing non-POD sections as well as POD ones + my %opts = $parser->parseopts(); + $opts{'-want_nonPODs}' and print "-want_nonPODs\n"; + +When invoked using a single string, B treats the string as the +name of a parse-option and returns its corresponding value if it exists +(returns C if it doesn't). + + ## Did we ask to see '=cut' paragraphs? + my $want_cut = $parser->parseopts('-process_cut_cmd'); + $want_cut and print "-process_cut_cmd\n"; + +When invoked with multiple arguments, B treats them as +key/value pairs and the specified parse-option names are set to the +given values. Any unspecified parse-options are unaffected. + + ## Set them back to the default + $parser->parseopts(-warnings => 0); + +When passed a single hash-ref, B uses that hash to completely +reset the existing parse-options, all previous parse-option values +are lost. + + ## Reset all options to default + $parser->parseopts( { } ); + +See L<"PARSING OPTIONS"> for more information on the name and meaning of each +parse-option currently recognized. + +=cut + +sub parseopts { + local *myData = shift; + local *myOpts = ($myData{_PARSEOPTS} ||= {}); + return %myOpts if (@_ == 0); + if (@_ == 1) { + local $_ = shift; + return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_}; + } + my @newOpts = (%myOpts, @_); + $myData{_PARSEOPTS} = { @newOpts }; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $fname = $parser->output_file(); + +Returns the name of the output file being written. + +=cut + +sub output_file { + return $_[0]->{_OUTFILE}; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $fhandle = $parser->output_handle(); + +Returns the output filehandle object. + +=cut + +sub output_handle { + return $_[0]->{_OUTPUT}; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $fname = $parser->input_file(); + +Returns the name of the input file being read. + +=cut + +sub input_file { + return $_[0]->{_INFILE}; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $fhandle = $parser->input_handle(); + +Returns the current input filehandle object. + +=cut + +sub input_handle { + return $_[0]->{_INPUT}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B + + $listref = $parser->input_streams(); + +Returns a reference to an array which corresponds to the stack of all +the input streams that are currently in the middle of being parsed. + +While parsing an input stream, it is possible to invoke +B or B to parse a new input +stream and then return to parsing the previous input stream. Each input +stream to be parsed is pushed onto the end of this input stack +before any of its input is read. The input stream that is currently +being parsed is always at the end (or top) of the input stack. When an +input stream has been exhausted, it is popped off the end of the +input stack. + +Each element on this input stack is a reference to C +object. Please see L for more details. + +This method might be invoked when printing diagnostic messages, for example, +to obtain the name and line number of the all input files that are currently +being processed. + +=end __PRIVATE__ + +=cut + +sub input_streams { + return $_[0]->{_INPUT_STREAMS}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B + + $hashref = $parser->top_stream(); + +Returns a reference to the hash-table that represents the element +that is currently at the top (end) of the input stream stack +(see L<"input_streams()">). The return value will be the C +if the input stack is empty. + +This method might be used when printing diagnostic messages, for example, +to obtain the name and line number of the current input file. + +=end __PRIVATE__ + +=cut + +sub top_stream { + return $_[0]->{_TOP_STREAM} || undef; +} + +############################################################################# + +=head1 PRIVATE METHODS AND DATA + +B makes use of several internal methods and data fields +which clients should not need to see or use. For the sake of avoiding +name collisions for client data and methods, these methods and fields +are briefly discussed here. Determined hackers may obtain further +information about them by reading the B source code. + +Private data fields are stored in the hash-object whose reference is +returned by the B constructor for this class. The names of all +private methods and data-fields used by B begin with a +prefix of "_" and match the regular expression C. + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_push_input_stream()> + + $hashref = $parser->_push_input_stream($in_fh,$out_fh); + +This method will push the given input stream on the input stack and +perform any necessary beginning-of-document or beginning-of-file +processing. The argument C<$in_fh> is the input stream filehandle to +push, and C<$out_fh> is the corresponding output filehandle to use (if +it is not given or is undefined, then the current output stream is used, +which defaults to standard output if it doesnt exist yet). + +The value returned will be reference to the hash-table that represents +the new top of the input stream stack. I that it is +possible for this method to use default values for the input and output +file handles. If this happens, you will need to look at the C +and C instance data members to determine their new values. + +=end _PRIVATE_ + +=cut + +sub _push_input_stream { + my ($self, $in_fh, $out_fh) = @_; + local *myData = $self; + + ## Initialize stuff for the entire document if this is *not* + ## an included file. + ## + ## NOTE: we need to be *very* careful when "defaulting" the output + ## filehandle. We only want to use a default value if this is the + ## beginning of the entire document (but *not* if this is an included + ## file). + unless (defined $myData{_TOP_STREAM}) { + $out_fh = \*STDOUT unless (defined $out_fh); + $myData{_CUTTING} = 1; ## current "cutting" state + $myData{_INPUT_STREAMS} = []; ## stack of all input streams + } + + ## Initialize input indicators + $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE}); + $myData{_OUTPUT} = $out_fh if (defined $out_fh); + $in_fh = \*STDIN unless (defined $in_fh); + $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE}); + $myData{_INPUT} = $in_fh; + my $input_top = $myData{_TOP_STREAM} + = new Pod::InputSource( + -name => $myData{_INFILE}, + -handle => $in_fh, + -was_cutting => $myData{_CUTTING} + ); + local *input_stack = $myData{_INPUT_STREAMS}; + push(@input_stack, $input_top); + + ## Perform beginning-of-document and/or beginning-of-input processing + $self->begin_pod() if (@input_stack == 1); + $self->begin_input(); + + return $input_top; +} + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_pop_input_stream()> + + $hashref = $parser->_pop_input_stream(); + +This takes no arguments. It will perform any necessary end-of-file or +end-of-document processing and then pop the current input stream from +the top of the input stack. + +The value returned will be reference to the hash-table that represents +the new top of the input stream stack. + +=end _PRIVATE_ + +=cut + +sub _pop_input_stream { + my ($self) = @_; + local *myData = $self; + local *input_stack = $myData{_INPUT_STREAMS}; + + ## Perform end-of-input and/or end-of-document processing + $self->end_input() if (@input_stack > 0); + $self->end_pod() if (@input_stack == 1); + + ## Restore cutting state to whatever it was before we started + ## parsing this file. + my $old_top = pop(@input_stack); + $myData{_CUTTING} = $old_top->was_cutting(); + + ## Dont forget to reset the input indicators + my $input_top = undef; + if (@input_stack > 0) { + $input_top = $myData{_TOP_STREAM} = $input_stack[-1]; + $myData{_INFILE} = $input_top->name(); + $myData{_INPUT} = $input_top->handle(); + } else { + delete $myData{_TOP_STREAM}; + delete $myData{_INPUT_STREAMS}; + } + + return $input_top; +} + +############################################################################# + +=head1 TREE-BASED PARSING + +If straightforward stream-based parsing wont meet your needs (as is +likely the case for tasks such as translating PODs into structured +markup languages like HTML and XML) then you may need to take the +tree-based approach. Rather than doing everything in one pass and +calling the B method to expand sequences into text, it +may be desirable to instead create a parse-tree using the B +method to return a tree-like structure which may contain an ordered +list of children (each of which may be a text-string, or a similar +tree-like structure). + +Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and +to the objects described in L. The former describes +the gory details and parameters for how to customize and extend the +parsing behavior of B. B provides +several objects that may all be used interchangeably as parse-trees. The +most obvious one is the B object. It defines the basic +interface and functionality that all things trying to be a POD parse-tree +should do. A B is defined such that each "node" may be a +text-string, or a reference to another parse-tree. Each B +object and each B object also supports the basic +parse-tree interface. + +The B method takes a given paragraph of text, and +returns a parse-tree that contains one or more children, each of which +may be a text-string, or an InteriorSequence object. There are also +callback-options that may be passed to B to customize +the way it expands or transforms interior-sequences, as well as the +returned result. These callbacks can be used to create a parse-tree +with custom-made objects (which may or may not support the parse-tree +interface, depending on how you choose to do it). + +If you wish to turn an entire POD document into a parse-tree, that process +is fairly straightforward. The B method is the key to doing +this successfully. Every paragraph-callback (i.e. the polymorphic methods +for B, B, and B paragraphs) takes +a B object as an argument. Each paragraph object has a +B method that can be used to get or set a corresponding +parse-tree. So for each of those paragraph-callback methods, simply call +B with the options you desire, and then use the returned +parse-tree to assign to the given paragraph object. + +That gives you a parse-tree for each paragraph - so now all you need is +an ordered list of paragraphs. You can maintain that yourself as a data +element in the object/hash. The most straightforward way would be simply +to use an array-ref, with the desired set of custom "options" for each +invocation of B. Let's assume the desired option-set is +given by the hash C<%options>. Then we might do something like the +following: + + package MyPodParserTree; + + @ISA = qw( Pod::Parser ); + + ... + + sub begin_pod { + my $self = shift; + $self->{'-paragraphs'} = []; ## initialize paragraph list + } + + sub command { + my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({%options}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + push @{ $self->{'-paragraphs'} }, $pod_para; + } + + sub verbatim { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + push @{ $self->{'-paragraphs'} }, $pod_para; + } + + sub textblock { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({%options}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + push @{ $self->{'-paragraphs'} }, $pod_para; + } + + ... + + package main; + ... + my $parser = new MyPodParserTree(...); + $parser->parse_from_file(...); + my $paragraphs_ref = $parser->{'-paragraphs'}; + +Of course, in this module-author's humble opinion, I'd be more inclined to +use the existing B object than a simple array. That way +everything in it, paragraphs and sequences, all respond to the same core +interface for all parse-tree nodes. The result would look something like: + + package MyPodParserTree2; + + ... + + sub begin_pod { + my $self = shift; + $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree + } + + sub parse_tree { + ## convenience method to get/set the parse-tree for the entire POD + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; + } + + sub command { + my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({<>}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + $parser->parse_tree()->append( $pod_para ); + } + + sub verbatim { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + $parser->parse_tree()->append( $pod_para ); + } + + sub textblock { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({<>}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + $parser->parse_tree()->append( $pod_para ); + } + + ... + + package main; + ... + my $parser = new MyPodParserTree2(...); + $parser->parse_from_file(...); + my $ptree = $parser->parse_tree; + ... + +Now you have the entire POD document as one great big parse-tree. You +can even use the B<-expand_seq> option to B to insert +whole different kinds of objects. Just don't expect B +to know what to do with them after that. That will need to be in your +code. Or, alternatively, you can insert any object you like so long as +it conforms to the B interface. + +One could use this to create subclasses of B and +B for specific commands (or to create your own +custom node-types in the parse-tree) and add some kind of B +method to each custom node/subclass object in the tree. Then all you'd +need to do is recursively walk the tree in the desired order, processing +the children (most likely from left to right) by formatting them if +they are text-strings, or by calling their B method if they +are objects/references. + +=head1 CAVEATS + +Please note that POD has the notion of "paragraphs": this is something +starting I a blank (read: empty) line, with the single exception +of the file start, which is also starting a paragraph. That means that +especially a command (e.g. C<=head1>) I be preceded with a blank +line; C<__END__> is I a blank line. + +=head1 SEE ALSO + +L, L + +B defines POD input objects corresponding to +command paragraphs, parse-trees, and interior-sequences. + +B is a subclass of B which provides the ability +to selectively include and/or exclude sections of a POD document from being +translated based upon the current heading, subheading, subsubheading, etc. + +=for __PRIVATE__ +B is a subclass of B which gives its users +the ability the employ I instead of, or in addition +to, overriding methods of the base class. + +=for __PRIVATE__ +B and B do not override any +methods nor do they define any new methods with the same name. Because +of this, they may I be used (in combination) as a base class of +the same subclass in order to combine their functionality without +causing any namespace clashes due to multiple inheritance. + +=head1 AUTHOR + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +=head1 LICENSE + +Pod-Parser is free software; you can redistribute it and/or modify it +under the terms of the Artistic License distributed with Perl version +5.000 or (at your option) any later version. Please refer to the +Artistic License that came with your Perl distribution for more +details. If your version of Perl was not distributed under the +terms of the Artistic License, than you may distribute PodParser +under the same terms as Perl itself. + +=cut + +1; +# vim: ts=4 sw=4 et diff --git a/cpan/Pod-Parser/lib/Pod/PlainText.pm b/cpan/Pod-Parser/lib/Pod/PlainText.pm index 06df184097..e8dc001dff 100644 --- a/cpan/Pod-Parser/lib/Pod/PlainText.pm +++ b/cpan/Pod-Parser/lib/Pod/PlainText.pm @@ -1,740 +1,744 @@ -# Pod::PlainText -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ -# -# Copyright 1999-2000 by Russ Allbery -# -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# This module is intended to be a replacement for Pod::Text, and attempts to -# match its output except for some specific circumstances where other -# decisions seemed to produce better output. It uses Pod::Parser and is -# designed to be very easy to subclass. - -############################################################################ -# Modules and declarations -############################################################################ - -package Pod::PlainText; -use strict; - -require 5.005; - -use Carp qw(carp croak); -use Pod::Select (); - -use vars qw(@ISA %ESCAPES $VERSION); - -# We inherit from Pod::Select instead of Pod::Parser so that we can be used -# by Pod::Usage. -@ISA = qw(Pod::Select); - -$VERSION = '2.05'; - -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} - -############################################################################ -# Table of supported E<> escapes -############################################################################ - -# This table is taken near verbatim from Pod::PlainText in Pod::Parser, -# which got it near verbatim from the original Pod::Text. It is therefore -# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) -%ESCAPES = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\xC1", # capital A, acute accent - "aacute" => "\xE1", # small a, acute accent - "Acirc" => "\xC2", # capital A, circumflex accent - "acirc" => "\xE2", # small a, circumflex accent - "AElig" => "\xC6", # capital AE diphthong (ligature) - "aelig" => "\xE6", # small ae diphthong (ligature) - "Agrave" => "\xC0", # capital A, grave accent - "agrave" => "\xE0", # small a, grave accent - "Aring" => "\xC5", # capital A, ring - "aring" => "\xE5", # small a, ring - "Atilde" => "\xC3", # capital A, tilde - "atilde" => "\xE3", # small a, tilde - "Auml" => "\xC4", # capital A, dieresis or umlaut mark - "auml" => "\xE4", # small a, dieresis or umlaut mark - "Ccedil" => "\xC7", # capital C, cedilla - "ccedil" => "\xE7", # small c, cedilla - "Eacute" => "\xC9", # capital E, acute accent - "eacute" => "\xE9", # small e, acute accent - "Ecirc" => "\xCA", # capital E, circumflex accent - "ecirc" => "\xEA", # small e, circumflex accent - "Egrave" => "\xC8", # capital E, grave accent - "egrave" => "\xE8", # small e, grave accent - "ETH" => "\xD0", # capital Eth, Icelandic - "eth" => "\xF0", # small eth, Icelandic - "Euml" => "\xCB", # capital E, dieresis or umlaut mark - "euml" => "\xEB", # small e, dieresis or umlaut mark - "Iacute" => "\xCD", # capital I, acute accent - "iacute" => "\xED", # small i, acute accent - "Icirc" => "\xCE", # capital I, circumflex accent - "icirc" => "\xEE", # small i, circumflex accent - "Igrave" => "\xCD", # capital I, grave accent - "igrave" => "\xED", # small i, grave accent - "Iuml" => "\xCF", # capital I, dieresis or umlaut mark - "iuml" => "\xEF", # small i, dieresis or umlaut mark - "Ntilde" => "\xD1", # capital N, tilde - "ntilde" => "\xF1", # small n, tilde - "Oacute" => "\xD3", # capital O, acute accent - "oacute" => "\xF3", # small o, acute accent - "Ocirc" => "\xD4", # capital O, circumflex accent - "ocirc" => "\xF4", # small o, circumflex accent - "Ograve" => "\xD2", # capital O, grave accent - "ograve" => "\xF2", # small o, grave accent - "Oslash" => "\xD8", # capital O, slash - "oslash" => "\xF8", # small o, slash - "Otilde" => "\xD5", # capital O, tilde - "otilde" => "\xF5", # small o, tilde - "Ouml" => "\xD6", # capital O, dieresis or umlaut mark - "ouml" => "\xF6", # small o, dieresis or umlaut mark - "szlig" => "\xDF", # small sharp s, German (sz ligature) - "THORN" => "\xDE", # capital THORN, Icelandic - "thorn" => "\xFE", # small thorn, Icelandic - "Uacute" => "\xDA", # capital U, acute accent - "uacute" => "\xFA", # small u, acute accent - "Ucirc" => "\xDB", # capital U, circumflex accent - "ucirc" => "\xFB", # small u, circumflex accent - "Ugrave" => "\xD9", # capital U, grave accent - "ugrave" => "\xF9", # small u, grave accent - "Uuml" => "\xDC", # capital U, dieresis or umlaut mark - "uuml" => "\xFC", # small u, dieresis or umlaut mark - "Yacute" => "\xDD", # capital Y, acute accent - "yacute" => "\xFD", # small y, acute accent - "yuml" => "\xFF", # small y, dieresis or umlaut mark - - "lchevron" => "\xAB", # left chevron (double less than) - "rchevron" => "\xBB", # right chevron (double greater than) -); - - -############################################################################ -# Initialization -############################################################################ - -# Initialize the object. Must be sure to call our parent initializer. -sub initialize { - my $self = shift; - - $$self{alt} = 0 unless defined $$self{alt}; - $$self{indent} = 4 unless defined $$self{indent}; - $$self{loose} = 0 unless defined $$self{loose}; - $$self{sentence} = 0 unless defined $$self{sentence}; - $$self{width} = 76 unless defined $$self{width}; - - $$self{INDENTS} = []; # Stack of indentations. - $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. - - return $self->SUPER::initialize; -} - - -############################################################################ -# Core overrides -############################################################################ - -# Called for each command paragraph. Gets the command, the associated -# paragraph, the line number, and a Pod::Paragraph object. Just dispatches -# the command to a method named the same as the command. =cut is handled -# internally by Pod::Parser. -sub command { - my $self = shift; - my $command = shift; - return if $command eq 'pod'; - return if ($$self{EXCLUDE} && $command ne 'end'); - if (defined $$self{ITEM}) { - $self->item ("\n"); - local $_ = "\n"; - $self->output($_) if($command eq 'back'); - } - $command = 'cmd_' . $command; - return $self->$command (@_); -} - -# Called for a verbatim paragraph. Gets the paragraph, the line number, and -# a Pod::Paragraph object. Just output it verbatim, but with tabs converted -# to spaces. -sub verbatim { - my $self = shift; - return if $$self{EXCLUDE}; - $self->item if defined $$self{ITEM}; - local $_ = shift; - return if /^\s*$/; - s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; - return $self->output($_); -} - -# Called for a regular text block. Gets the paragraph, the line number, and -# a Pod::Paragraph object. Perform interpolation and output the results. -sub textblock { - my $self = shift; - return if $$self{EXCLUDE}; - if($$self{VERBATIM}) { - $self->output($_[0]); - return; - } - local $_ = shift; - my $line = shift; - - # Perform a little magic to collapse multiple L<> references. This is - # here mostly for backwards-compatibility. We'll just rewrite the whole - # thing into actual text at this part, bypassing the whole internal - # sequence parsing thing. - s{ - ( - L< # A link of the form L. - / - ( - [:\w]+ # The item has to be a simple word... - (\(\))? # ...or simple function. - ) - > - ( - ,?\s+(and\s+)? # Allow lots of them, conjuncted. - L< - / - ( - [:\w]+ - (\(\))? - ) - > - )+ - ) - } { - local $_ = $1; - s%L]+)>%$1%g; - my @items = split /(?:,?\s+(?:and\s+)?)/; - my $string = "the "; - my $i; - for ($i = 0; $i < @items; $i++) { - $string .= $items[$i]; - $string .= ", " if @items > 2 && $i != $#items; - $string .= " and " if ($i == $#items - 1); - } - $string .= " entries elsewhere in this document"; - $string; - }gex; - - # Now actually interpolate and output the paragraph. - $_ = $self->interpolate ($_, $line); - s/\s*$/\n/s; - if (defined $$self{ITEM}) { - $self->item ($_ . "\n"); - } else { - $self->output ($self->reformat ($_ . "\n")); - } -} - -# Called for an interior sequence. Gets the command, argument, and a -# Pod::InteriorSequence object and is expected to return the resulting text. -# Calls code, bold, italic, file, and link to handle those types of -# sequences, and handles S<>, E<>, X<>, and Z<> directly. -sub interior_sequence { - my $self = shift; - my $command = shift; - local $_ = shift; - return '' if ($command eq 'X' || $command eq 'Z'); - - # Expand escapes into the actual character now, carping if invalid. - if ($command eq 'E') { - return $ESCAPES{$_} if defined $ESCAPES{$_}; - carp "Unknown escape: E<$_>"; - return "E<$_>"; - } - - # For all the other sequences, empty content produces no output. - return if $_ eq ''; - - # For S<>, compress all internal whitespace and then map spaces to \01. - # When we output the text, we'll map this back. - if ($command eq 'S') { - s/\s{2,}/ /g; - tr/ /\01/; - return $_; - } - - # Anything else needs to get dispatched to another method. - if ($command eq 'B') { return $self->seq_b ($_) } - elsif ($command eq 'C') { return $self->seq_c ($_) } - elsif ($command eq 'F') { return $self->seq_f ($_) } - elsif ($command eq 'I') { return $self->seq_i ($_) } - elsif ($command eq 'L') { return $self->seq_l ($_) } - else { carp "Unknown sequence $command<$_>" } -} - -# Called for each paragraph that's actually part of the POD. We take -# advantage of this opportunity to untabify the input. -sub preprocess_paragraph { - my $self = shift; - local $_ = shift; - 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; - return $_; -} - - -############################################################################ -# Command paragraphs -############################################################################ - -# All command paragraphs take the paragraph and the line number. - -# First level heading. -sub cmd_head1 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n==== $_ ====\n\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output ($_ . "\n"); - } -} - -# Second level heading. -sub cmd_head2 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n== $_ ==\n\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output (' ' x ($$self{indent} / 2) . $_ . "\n"); - } -} - -# third level heading - not strictly perlpodspec compliant -sub cmd_head3 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n= $_ =\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output (' ' x ($$self{indent}) . $_ . "\n"); - } -} - -# fourth level heading - not strictly perlpodspec compliant -# just like head3 -*cmd_head4 = \&cmd_head3; - -# Start a list. -sub cmd_over { - my $self = shift; - local $_ = shift; - unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } - push (@{ $$self{INDENTS} }, $$self{MARGIN}); - $$self{MARGIN} += ($_ + 0); -} - -# End a list. -sub cmd_back { - my $self = shift; - $$self{MARGIN} = pop @{ $$self{INDENTS} }; - unless (defined $$self{MARGIN}) { - carp 'Unmatched =back'; - $$self{MARGIN} = $$self{indent}; - } -} - -# An individual list item. -sub cmd_item { - my $self = shift; - if (defined $$self{ITEM}) { $self->item } - local $_ = shift; - s/\s+$//s; - $$self{ITEM} = $self->interpolate ($_); -} - -# Begin a block for a particular translator. Setting VERBATIM triggers -# special handling in textblock(). -sub cmd_begin { - my $self = shift; - local $_ = shift; - my ($kind) = /^(\S+)/ or return; - if ($kind eq 'text') { - $$self{VERBATIM} = 1; - } else { - $$self{EXCLUDE} = 1; - } -} - -# End a block for a particular translator. We assume that all =begin/=end -# pairs are properly closed. -sub cmd_end { - my $self = shift; - $$self{EXCLUDE} = 0; - $$self{VERBATIM} = 0; -} - -# One paragraph for a particular translator. Ignore it unless it's intended -# for text, in which case we treat it as a verbatim text block. -sub cmd_for { - my $self = shift; - local $_ = shift; - my $line = shift; - return unless s/^text\b[ \t]*\r?\n?//; - $self->verbatim ($_, $line); -} - - -############################################################################ -# Interior sequences -############################################################################ - -# The simple formatting ones. These are here mostly so that subclasses can -# override them and do more complicated things. -sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } -sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } -sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } -sub seq_i { return '*' . $_[1] . '*' } - -# The complicated one. Handle links. Since this is plain text, we can't -# actually make any real links, so this is all to figure out what text we -# print out. -sub seq_l { - my $self = shift; - local $_ = shift; - - # Smash whitespace in case we were split across multiple lines. - s/\s+/ /g; - - # If we were given any explicit text, just output it. - if (/^([^|]+)\|/) { return $1 } - - # Okay, leading and trailing whitespace isn't important; get rid of it. - s/^\s+//; - s/\s+$//; - - # Default to using the whole content of the link entry as a section - # name. Note that L forces a manpage interpretation, as does - # something looking like L. The latter is an - # enhancement over the original Pod::Text. - my ($manpage, $section) = ('', $_); - if (/^(?:https?|ftp|news):/) { - # a URL - return $_; - } elsif (/^"\s*(.*?)\s*"$/) { - $section = '"' . $1 . '"'; - } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { - ($manpage, $section) = ($_, ''); - } elsif (m{/}) { - ($manpage, $section) = split (/\s*\/\s*/, $_, 2); - } - - my $text = ''; - # Now build the actual output text. - if (!length $section) { - $text = "the $manpage manpage" if length $manpage; - } elsif ($section =~ /^[:\w]+(?:\(\))?/) { - $text .= 'the ' . $section . ' entry'; - $text .= (length $manpage) ? " in the $manpage manpage" - : ' elsewhere in this document'; - } else { - $section =~ s/^\"\s*//; - $section =~ s/\s*\"$//; - $text .= 'the section on "' . $section . '"'; - $text .= " in the $manpage manpage" if length $manpage; - } - return $text; -} - - -############################################################################ -# List handling -############################################################################ - -# This method is called whenever an =item command is complete (in other -# words, we've seen its associated paragraph or know for certain that it -# doesn't have one). It gets the paragraph associated with the item as an -# argument. If that argument is empty, just output the item tag; if it -# contains a newline, output the item tag followed by the newline. -# Otherwise, see if there's enough room for us to output the item tag in the -# margin of the text or if we have to put it on a separate line. -sub item { - my $self = shift; - local $_ = shift; - my $tag = $$self{ITEM}; - unless (defined $tag) { - carp 'item called without tag'; - return; - } - undef $$self{ITEM}; - my $indent = $$self{INDENTS}[-1]; - unless (defined $indent) { $indent = $$self{indent} } - my $space = ' ' x $indent; - $space =~ s/^ /:/ if $$self{alt}; - if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { - my $margin = $$self{MARGIN}; - $$self{MARGIN} = $indent; - my $output = $self->reformat ($tag); - $output =~ s/[\r\n]*$/\n/; - $self->output ($output); - $$self{MARGIN} = $margin; - $self->output ($self->reformat ($_)) if /\S/; - } else { - $_ = $self->reformat ($_); - s/^ /:/ if ($$self{alt} && $indent > 0); - my $tagspace = ' ' x length $tag; - s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item'; - $self->output ($_); - } -} - - -############################################################################ -# Output formatting -############################################################################ - -# Wrap a line, indenting by the current left margin. We can't use -# Text::Wrap because it plays games with tabs. We can't use formline, even -# though we'd really like to, because it screws up non-printing characters. -# So we have to do the wrapping ourselves. -sub wrap { - my $self = shift; - local $_ = shift; - my $output = ''; - my $spaces = ' ' x $$self{MARGIN}; - my $width = $$self{width} - $$self{MARGIN}; - while (length > $width) { - if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) { - $output .= $spaces . $1 . "\n"; - } else { - last; - } - } - $output .= $spaces . $_; - $output =~ s/\s+$/\n\n/; - return $output; -} - -# Reformat a paragraph of text for the current margin. Takes the text to -# reformat and returns the formatted text. -sub reformat { - my $self = shift; - local $_ = shift; - - # If we're trying to preserve two spaces after sentences, do some - # munging to support that. Otherwise, smash all repeated whitespace. - if ($$self{sentence}) { - s/ +$//mg; - s/\.\r?\n/. \n/g; - s/[\r\n]+/ /g; - s/ +/ /g; - } else { - s/\s+/ /g; - } - return $self->wrap($_); -} - -# Output text to the output device. -sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } - - -############################################################################ -# Backwards compatibility -############################################################################ - -# The old Pod::Text module did everything in a pod2text() function. This -# tries to provide the same interface for legacy applications. -sub pod2text { - my @args; - - # This is really ugly; I hate doing option parsing in the middle of a - # module. But the old Pod::Text module supported passing flags to its - # entry function, so handle -a and -. - while ($_[0] =~ /^-/) { - my $flag = shift; - if ($flag eq '-a') { push (@args, alt => 1) } - elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } - else { - unshift (@_, $flag); - last; - } - } - - # Now that we know what arguments we're using, create the parser. - my $parser = Pod::PlainText->new (@args); - - # If two arguments were given, the second argument is going to be a file - # handle. That means we want to call parse_from_filehandle(), which - # means we need to turn the first argument into a file handle. Magic - # open will handle the <&STDIN case automagically. - if (defined $_[1]) { - my $infh; - if ($] < 5.006) { - $infh = gensym(); - } - unless (open ($infh, $_[0])) { - croak ("Can't open $_[0] for reading: $!\n"); - } - $_[0] = $infh; - return $parser->parse_from_filehandle (@_); - } else { - return $parser->parse_from_file (@_); - } -} - - -############################################################################ -# Module return value and documentation -############################################################################ - -1; -__END__ - -=head1 NAME - -Pod::PlainText - Convert POD data to formatted ASCII text - -=head1 SYNOPSIS - - use Pod::PlainText; - my $parser = Pod::PlainText->new (sentence => 0, width => 78); - - # Read POD from STDIN and write to STDOUT. - $parser->parse_from_filehandle; - - # Read POD from file.pod and write to file.txt. - $parser->parse_from_file ('file.pod', 'file.txt'); - -=head1 DESCRIPTION - -Pod::PlainText is a module that can convert documentation in the POD format (the -preferred language for documenting Perl) into formatted ASCII. It uses no -special formatting controls or codes whatsoever, and its output is therefore -suitable for nearly any device. - -As a derived class from Pod::Parser, Pod::PlainText supports the same methods and -interfaces. See L for all the details; briefly, one creates a -new parser with Cnew()> and then calls either -parse_from_filehandle() or parse_from_file(). - -new() can take options, in the form of key/value pairs, that control the -behavior of the parser. The currently recognized options are: - -=over 4 - -=item alt - -If set to a true value, selects an alternate output format that, among other -things, uses a different heading style and marks C<=item> entries with a -colon in the left margin. Defaults to false. - -=item indent - -The number of spaces to indent regular text, and the default indentation for -C<=over> blocks. Defaults to 4. - -=item loose - -If set to a true value, a blank line is printed after a C<=headN> headings. -If set to false (the default), no blank line is printed after C<=headN>. -This is the default because it's the expected formatting for manual pages; -if you're formatting arbitrary text documents, setting this to true may -result in more pleasing output. - -=item sentence - -If set to a true value, Pod::PlainText will assume that each sentence ends in two -spaces, and will try to preserve that spacing. If set to false, all -consecutive whitespace in non-verbatim paragraphs is compressed into a -single space. Defaults to true. - -=item width - -The column at which to wrap text on the right-hand side. Defaults to 76. - -=back - -The standard Pod::Parser method parse_from_filehandle() takes up to two -arguments, the first being the file handle to read POD from and the second -being the file handle to write the formatted output to. The first defaults -to STDIN if not given, and the second defaults to STDOUT. The method -parse_from_file() is almost identical, except that its two arguments are the -input and output disk files instead. See L for the specific -details. - -=head1 DIAGNOSTICS - -=over 4 - -=item Bizarre space in item - -(W) Something has gone wrong in internal C<=item> processing. This message -indicates a bug in Pod::PlainText; you should never see it. - -=item Can't open %s for reading: %s - -(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface -and the input file it was given could not be opened. - -=item Unknown escape: %s - -(W) The POD source contained an CE> escape that Pod::PlainText didn't -know about. - -=item Unknown sequence: %s - -(W) The POD source contained a non-standard internal sequence (something of -the form CE>) that Pod::PlainText didn't know about. - -=item Unmatched =back - -(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an -C<=over> command. - -=back - -=head1 RESTRICTIONS - -Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on -output, due to an internal implementation detail. - -=head1 NOTES - -This is a replacement for an earlier Pod::Text module written by Tom -Christiansen. It has a revamped interface, since it now uses Pod::Parser, -but an interface roughly compatible with the old Pod::Text::pod2text() -function is still available. Please change to the new calling convention, -though. - -The original Pod::Text contained code to do formatting via termcap -sequences, although it wasn't turned on by default and it was problematic to -get it to work at all. This rewrite doesn't even try to do that, but a -subclass of it does. Look for L. - -=head1 SEE ALSO - -B is part of the L distribution. - -L, L, -pod2text(1) - -=head1 AUTHOR - -Please report bugs using L. - -Russ Allbery Erra@stanford.eduE, based I heavily on the -original Pod::Text by Tom Christiansen Etchrist@mox.perl.comE and -its conversion to Pod::Parser by Brad Appleton -Ebradapp@enteract.comE. - -=cut +# Pod::PlainText -- Convert POD data to formatted ASCII text. +# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ +# +# Copyright 1999-2000 by Russ Allbery +# +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module is intended to be a replacement for Pod::Text, and attempts to +# match its output except for some specific circumstances where other +# decisions seemed to produce better output. It uses Pod::Parser and is +# designed to be very easy to subclass. + +############################################################################ +# Modules and declarations +############################################################################ + +package Pod::PlainText; +use strict; + +require 5.005; + +use Carp qw(carp croak); +use Pod::Select (); + +use vars qw(@ISA %ESCAPES $VERSION); + +# We inherit from Pod::Select instead of Pod::Parser so that we can be used +# by Pod::Usage. +@ISA = qw(Pod::Select); + +$VERSION = '2.06'; + +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} + +############################################################################ +# Table of supported E<> escapes +############################################################################ + +# This table is taken near verbatim from Pod::PlainText in Pod::Parser, +# which got it near verbatim from the original Pod::Text. It is therefore +# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) +%ESCAPES = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1", # capital A, acute accent + "aacute" => "\xE1", # small a, acute accent + "Acirc" => "\xC2", # capital A, circumflex accent + "acirc" => "\xE2", # small a, circumflex accent + "AElig" => "\xC6", # capital AE diphthong (ligature) + "aelig" => "\xE6", # small ae diphthong (ligature) + "Agrave" => "\xC0", # capital A, grave accent + "agrave" => "\xE0", # small a, grave accent + "Aring" => "\xC5", # capital A, ring + "aring" => "\xE5", # small a, ring + "Atilde" => "\xC3", # capital A, tilde + "atilde" => "\xE3", # small a, tilde + "Auml" => "\xC4", # capital A, dieresis or umlaut mark + "auml" => "\xE4", # small a, dieresis or umlaut mark + "Ccedil" => "\xC7", # capital C, cedilla + "ccedil" => "\xE7", # small c, cedilla + "Eacute" => "\xC9", # capital E, acute accent + "eacute" => "\xE9", # small e, acute accent + "Ecirc" => "\xCA", # capital E, circumflex accent + "ecirc" => "\xEA", # small e, circumflex accent + "Egrave" => "\xC8", # capital E, grave accent + "egrave" => "\xE8", # small e, grave accent + "ETH" => "\xD0", # capital Eth, Icelandic + "eth" => "\xF0", # small eth, Icelandic + "Euml" => "\xCB", # capital E, dieresis or umlaut mark + "euml" => "\xEB", # small e, dieresis or umlaut mark + "Iacute" => "\xCD", # capital I, acute accent + "iacute" => "\xED", # small i, acute accent + "Icirc" => "\xCE", # capital I, circumflex accent + "icirc" => "\xEE", # small i, circumflex accent + "Igrave" => "\xCD", # capital I, grave accent + "igrave" => "\xED", # small i, grave accent + "Iuml" => "\xCF", # capital I, dieresis or umlaut mark + "iuml" => "\xEF", # small i, dieresis or umlaut mark + "Ntilde" => "\xD1", # capital N, tilde + "ntilde" => "\xF1", # small n, tilde + "Oacute" => "\xD3", # capital O, acute accent + "oacute" => "\xF3", # small o, acute accent + "Ocirc" => "\xD4", # capital O, circumflex accent + "ocirc" => "\xF4", # small o, circumflex accent + "Ograve" => "\xD2", # capital O, grave accent + "ograve" => "\xF2", # small o, grave accent + "Oslash" => "\xD8", # capital O, slash + "oslash" => "\xF8", # small o, slash + "Otilde" => "\xD5", # capital O, tilde + "otilde" => "\xF5", # small o, tilde + "Ouml" => "\xD6", # capital O, dieresis or umlaut mark + "ouml" => "\xF6", # small o, dieresis or umlaut mark + "szlig" => "\xDF", # small sharp s, German (sz ligature) + "THORN" => "\xDE", # capital THORN, Icelandic + "thorn" => "\xFE", # small thorn, Icelandic + "Uacute" => "\xDA", # capital U, acute accent + "uacute" => "\xFA", # small u, acute accent + "Ucirc" => "\xDB", # capital U, circumflex accent + "ucirc" => "\xFB", # small u, circumflex accent + "Ugrave" => "\xD9", # capital U, grave accent + "ugrave" => "\xF9", # small u, grave accent + "Uuml" => "\xDC", # capital U, dieresis or umlaut mark + "uuml" => "\xFC", # small u, dieresis or umlaut mark + "Yacute" => "\xDD", # capital Y, acute accent + "yacute" => "\xFD", # small y, acute accent + "yuml" => "\xFF", # small y, dieresis or umlaut mark + + "lchevron" => "\xAB", # left chevron (double less than) + "rchevron" => "\xBB", # right chevron (double greater than) +); + + +############################################################################ +# Initialization +############################################################################ + +# Initialize the object. Must be sure to call our parent initializer. +sub initialize { + my $self = shift; + + $$self{alt} = 0 unless defined $$self{alt}; + $$self{indent} = 4 unless defined $$self{indent}; + $$self{loose} = 0 unless defined $$self{loose}; + $$self{sentence} = 0 unless defined $$self{sentence}; + $$self{width} = 76 unless defined $$self{width}; + + $$self{INDENTS} = []; # Stack of indentations. + $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. + + return $self->SUPER::initialize; +} + + +############################################################################ +# Core overrides +############################################################################ + +# Called for each command paragraph. Gets the command, the associated +# paragraph, the line number, and a Pod::Paragraph object. Just dispatches +# the command to a method named the same as the command. =cut is handled +# internally by Pod::Parser. +sub command { + my $self = shift; + my $command = shift; + return if $command eq 'pod'; + return if ($$self{EXCLUDE} && $command ne 'end'); + if (defined $$self{ITEM}) { + $self->item ("\n"); + local $_ = "\n"; + $self->output($_) if($command eq 'back'); + } + $command = 'cmd_' . $command; + return $self->$command (@_); +} + +# Called for a verbatim paragraph. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Just output it verbatim, but with tabs converted +# to spaces. +sub verbatim { + my $self = shift; + return if $$self{EXCLUDE}; + $self->item if defined $$self{ITEM}; + local $_ = shift; + return if /^\s*$/; + s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; + return $self->output($_); +} + +# Called for a regular text block. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Perform interpolation and output the results. +sub textblock { + my $self = shift; + return if $$self{EXCLUDE}; + if($$self{VERBATIM}) { + $self->output($_[0]); + return; + } + local $_ = shift; + my $line = shift; + + # Perform a little magic to collapse multiple L<> references. This is + # here mostly for backwards-compatibility. We'll just rewrite the whole + # thing into actual text at this part, bypassing the whole internal + # sequence parsing thing. + s{ + ( + L< # A link of the form L. + / + ( + [:\w]+ # The item has to be a simple word... + (\(\))? # ...or simple function. + ) + > + ( + ,?\s+(and\s+)? # Allow lots of them, conjuncted. + L< + / + ( + [:\w]+ + (\(\))? + ) + > + )+ + ) + } { + local $_ = $1; + s%L]+)>%$1%g; + my @items = split /(?:,?\s+(?:and\s+)?)/; + my $string = "the "; + my $i; + for ($i = 0; $i < @items; $i++) { + $string .= $items[$i]; + $string .= ", " if @items > 2 && $i != $#items; + $string .= " and " if ($i == $#items - 1); + } + $string .= " entries elsewhere in this document"; + $string; + }gex; + + # Now actually interpolate and output the paragraph. + $_ = $self->interpolate ($_, $line); + s/\s*$/\n/s; + if (defined $$self{ITEM}) { + $self->item ($_ . "\n"); + } else { + $self->output ($self->reformat ($_ . "\n")); + } +} + +# Called for an interior sequence. Gets the command, argument, and a +# Pod::InteriorSequence object and is expected to return the resulting text. +# Calls code, bold, italic, file, and link to handle those types of +# sequences, and handles S<>, E<>, X<>, and Z<> directly. +sub interior_sequence { + my $self = shift; + my $command = shift; + local $_ = shift; + return '' if ($command eq 'X' || $command eq 'Z'); + + # Expand escapes into the actual character now, carping if invalid. + if ($command eq 'E') { + return $ESCAPES{$_} if defined $ESCAPES{$_}; + carp "Unknown escape: E<$_>"; + return "E<$_>"; + } + + # For all the other sequences, empty content produces no output. + return if $_ eq ''; + + # For S<>, compress all internal whitespace and then map spaces to \01. + # When we output the text, we'll map this back. + if ($command eq 'S') { + s/\s{2,}/ /g; + tr/ /\01/; + return $_; + } + + # Anything else needs to get dispatched to another method. + if ($command eq 'B') { return $self->seq_b ($_) } + elsif ($command eq 'C') { return $self->seq_c ($_) } + elsif ($command eq 'F') { return $self->seq_f ($_) } + elsif ($command eq 'I') { return $self->seq_i ($_) } + elsif ($command eq 'L') { return $self->seq_l ($_) } + else { carp "Unknown sequence $command<$_>" } +} + +# Called for each paragraph that's actually part of the POD. We take +# advantage of this opportunity to untabify the input. +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + return $_; +} + + +############################################################################ +# Command paragraphs +############################################################################ + +# All command paragraphs take the paragraph and the line number. + +# First level heading. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//s; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n==== $_ ====\n\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output ($_ . "\n"); + } +} + +# Second level heading. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//s; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n== $_ ==\n\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output (' ' x ($$self{indent} / 2) . $_ . "\n"); + } +} + +# third level heading - not strictly perlpodspec compliant +sub cmd_head3 { + my $self = shift; + local $_ = shift; + s/\s+$//s; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n= $_ =\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output (' ' x ($$self{indent}) . $_ . "\n"); + } +} + +# fourth level heading - not strictly perlpodspec compliant +# just like head3 +*cmd_head4 = \&cmd_head3; + +# Start a list. +sub cmd_over { + my $self = shift; + local $_ = shift; + unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } + push (@{ $$self{INDENTS} }, $$self{MARGIN}); + $$self{MARGIN} += ($_ + 0); +} + +# End a list. +sub cmd_back { + my $self = shift; + $$self{MARGIN} = pop @{ $$self{INDENTS} }; + unless (defined $$self{MARGIN}) { + carp 'Unmatched =back'; + $$self{MARGIN} = $$self{indent}; + } +} + +# An individual list item. +sub cmd_item { + my $self = shift; + if (defined $$self{ITEM}) { $self->item } + local $_ = shift; + s/\s+$//s; + $$self{ITEM} = $self->interpolate ($_); +} + +# Begin a block for a particular translator. Setting VERBATIM triggers +# special handling in textblock(). +sub cmd_begin { + my $self = shift; + local $_ = shift; + my ($kind) = /^(\S+)/ or return; + if ($kind eq 'text') { + $$self{VERBATIM} = 1; + } else { + $$self{EXCLUDE} = 1; + } +} + +# End a block for a particular translator. We assume that all =begin/=end +# pairs are properly closed. +sub cmd_end { + my $self = shift; + $$self{EXCLUDE} = 0; + $$self{VERBATIM} = 0; +} + +# One paragraph for a particular translator. Ignore it unless it's intended +# for text, in which case we treat it as a verbatim text block. +sub cmd_for { + my $self = shift; + local $_ = shift; + my $line = shift; + return unless s/^text\b[ \t]*\r?\n?//; + $self->verbatim ($_, $line); +} + +# just a dummy method for the time being +sub cmd_encoding { + return; +} + +############################################################################ +# Interior sequences +############################################################################ + +# The simple formatting ones. These are here mostly so that subclasses can +# override them and do more complicated things. +sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } +sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } +sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } +sub seq_i { return '*' . $_[1] . '*' } + +# The complicated one. Handle links. Since this is plain text, we can't +# actually make any real links, so this is all to figure out what text we +# print out. +sub seq_l { + my $self = shift; + local $_ = shift; + + # Smash whitespace in case we were split across multiple lines. + s/\s+/ /g; + + # If we were given any explicit text, just output it. + if (/^([^|]+)\|/) { return $1 } + + # Okay, leading and trailing whitespace isn't important; get rid of it. + s/^\s+//; + s/\s+$//; + + # Default to using the whole content of the link entry as a section + # name. Note that L forces a manpage interpretation, as does + # something looking like L. The latter is an + # enhancement over the original Pod::Text. + my ($manpage, $section) = ('', $_); + if (/^(?:https?|ftp|news):/) { + # a URL + return $_; + } elsif (/^"\s*(.*?)\s*"$/) { + $section = '"' . $1 . '"'; + } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { + ($manpage, $section) = ($_, ''); + } elsif (m{/}) { + ($manpage, $section) = split (/\s*\/\s*/, $_, 2); + } + + my $text = ''; + # Now build the actual output text. + if (!length $section) { + $text = "the $manpage manpage" if length $manpage; + } elsif ($section =~ /^[:\w]+(?:\(\))?/) { + $text .= 'the ' . $section . ' entry'; + $text .= (length $manpage) ? " in the $manpage manpage" + : ' elsewhere in this document'; + } else { + $section =~ s/^\"\s*//; + $section =~ s/\s*\"$//; + $text .= 'the section on "' . $section . '"'; + $text .= " in the $manpage manpage" if length $manpage; + } + return $text; +} + + +############################################################################ +# List handling +############################################################################ + +# This method is called whenever an =item command is complete (in other +# words, we've seen its associated paragraph or know for certain that it +# doesn't have one). It gets the paragraph associated with the item as an +# argument. If that argument is empty, just output the item tag; if it +# contains a newline, output the item tag followed by the newline. +# Otherwise, see if there's enough room for us to output the item tag in the +# margin of the text or if we have to put it on a separate line. +sub item { + my $self = shift; + local $_ = shift; + my $tag = $$self{ITEM}; + unless (defined $tag) { + carp 'item called without tag'; + return; + } + undef $$self{ITEM}; + my $indent = $$self{INDENTS}[-1]; + unless (defined $indent) { $indent = $$self{indent} } + my $space = ' ' x $indent; + $space =~ s/^ /:/ if $$self{alt}; + if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { + my $margin = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/[\r\n]*$/\n/; + $self->output ($output); + $$self{MARGIN} = $margin; + $self->output ($self->reformat ($_)) if /\S/; + } else { + $_ = $self->reformat ($_); + s/^ /:/ if ($$self{alt} && $indent > 0); + my $tagspace = ' ' x length $tag; + s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item'; + $self->output ($_); + } +} + + +############################################################################ +# Output formatting +############################################################################ + +# Wrap a line, indenting by the current left margin. We can't use +# Text::Wrap because it plays games with tabs. We can't use formline, even +# though we'd really like to, because it screws up non-printing characters. +# So we have to do the wrapping ourselves. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +# Reformat a paragraph of text for the current margin. Takes the text to +# reformat and returns the formatted text. +sub reformat { + my $self = shift; + local $_ = shift; + + # If we're trying to preserve two spaces after sentences, do some + # munging to support that. Otherwise, smash all repeated whitespace. + if ($$self{sentence}) { + s/ +$//mg; + s/\.\r?\n/. \n/g; + s/[\r\n]+/ /g; + s/ +/ /g; + } else { + s/\s+/ /g; + } + return $self->wrap($_); +} + +# Output text to the output device. +sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } + + +############################################################################ +# Backwards compatibility +############################################################################ + +# The old Pod::Text module did everything in a pod2text() function. This +# tries to provide the same interface for legacy applications. +sub pod2text { + my @args; + + # This is really ugly; I hate doing option parsing in the middle of a + # module. But the old Pod::Text module supported passing flags to its + # entry function, so handle -a and -. + while ($_[0] =~ /^-/) { + my $flag = shift; + if ($flag eq '-a') { push (@args, alt => 1) } + elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } + else { + unshift (@_, $flag); + last; + } + } + + # Now that we know what arguments we're using, create the parser. + my $parser = Pod::PlainText->new (@args); + + # If two arguments were given, the second argument is going to be a file + # handle. That means we want to call parse_from_filehandle(), which + # means we need to turn the first argument into a file handle. Magic + # open will handle the <&STDIN case automagically. + if (defined $_[1]) { + my $infh; + if ($] < 5.006) { + $infh = gensym(); + } + unless (open ($infh, $_[0])) { + croak ("Can't open $_[0] for reading: $!\n"); + } + $_[0] = $infh; + return $parser->parse_from_filehandle (@_); + } else { + return $parser->parse_from_file (@_); + } +} + + +############################################################################ +# Module return value and documentation +############################################################################ + +1; +__END__ + +=head1 NAME + +Pod::PlainText - Convert POD data to formatted ASCII text + +=head1 SYNOPSIS + + use Pod::PlainText; + my $parser = Pod::PlainText->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::PlainText is a module that can convert documentation in the POD format (the +preferred language for documenting Perl) into formatted ASCII. It uses no +special formatting controls or codes whatsoever, and its output is therefore +suitable for nearly any device. + +As a derived class from Pod::Parser, Pod::PlainText supports the same methods and +interfaces. See L for all the details; briefly, one creates a +new parser with Cnew()> and then calls either +parse_from_filehandle() or parse_from_file(). + +new() can take options, in the form of key/value pairs, that control the +behavior of the parser. The currently recognized options are: + +=over 4 + +=item alt + +If set to a true value, selects an alternate output format that, among other +things, uses a different heading style and marks C<=item> entries with a +colon in the left margin. Defaults to false. + +=item indent + +The number of spaces to indent regular text, and the default indentation for +C<=over> blocks. Defaults to 4. + +=item loose + +If set to a true value, a blank line is printed after a C<=headN> headings. +If set to false (the default), no blank line is printed after C<=headN>. +This is the default because it's the expected formatting for manual pages; +if you're formatting arbitrary text documents, setting this to true may +result in more pleasing output. + +=item sentence + +If set to a true value, Pod::PlainText will assume that each sentence ends in two +spaces, and will try to preserve that spacing. If set to false, all +consecutive whitespace in non-verbatim paragraphs is compressed into a +single space. Defaults to true. + +=item width + +The column at which to wrap text on the right-hand side. Defaults to 76. + +=back + +The standard Pod::Parser method parse_from_filehandle() takes up to two +arguments, the first being the file handle to read POD from and the second +being the file handle to write the formatted output to. The first defaults +to STDIN if not given, and the second defaults to STDOUT. The method +parse_from_file() is almost identical, except that its two arguments are the +input and output disk files instead. See L for the specific +details. + +=head1 DIAGNOSTICS + +=over 4 + +=item Bizarre space in item + +(W) Something has gone wrong in internal C<=item> processing. This message +indicates a bug in Pod::PlainText; you should never see it. + +=item Can't open %s for reading: %s + +(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface +and the input file it was given could not be opened. + +=item Unknown escape: %s + +(W) The POD source contained an CE> escape that Pod::PlainText didn't +know about. + +=item Unknown sequence: %s + +(W) The POD source contained a non-standard internal sequence (something of +the form CE>) that Pod::PlainText didn't know about. + +=item Unmatched =back + +(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an +C<=over> command. + +=back + +=head1 RESTRICTIONS + +Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on +output, due to an internal implementation detail. + +=head1 NOTES + +This is a replacement for an earlier Pod::Text module written by Tom +Christiansen. It has a revamped interface, since it now uses Pod::Parser, +but an interface roughly compatible with the old Pod::Text::pod2text() +function is still available. Please change to the new calling convention, +though. + +The original Pod::Text contained code to do formatting via termcap +sequences, although it wasn't turned on by default and it was problematic to +get it to work at all. This rewrite doesn't even try to do that, but a +subclass of it does. Look for L. + +=head1 SEE ALSO + +B is part of the L distribution. + +L, L, +pod2text(1) + +=head1 AUTHOR + +Please report bugs using L. + +Russ Allbery Erra@stanford.eduE, based I heavily on the +original Pod::Text by Tom Christiansen Etchrist@mox.perl.comE and +its conversion to Pod::Parser by Brad Appleton +Ebradapp@enteract.comE. + +=cut diff --git a/cpan/Pod-Parser/lib/Pod/Select.pm b/cpan/Pod-Parser/lib/Pod/Select.pm index 300eee537e..148b5d17cf 100644 --- a/cpan/Pod-Parser/lib/Pod/Select.pm +++ b/cpan/Pod-Parser/lib/Pod/Select.pm @@ -1,748 +1,748 @@ -############################################################################# -# Pod/Select.pm -- function to select portions of POD docs -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Select; -use strict; - -use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::Select, podselect() - extract selected sections of POD from input - -=head1 SYNOPSIS - - use Pod::Select; - - ## Select all the POD sections for each file in @filelist - ## and print the result on standard output. - podselect(@filelist); - - ## Same as above, but write to tmp.out - podselect({-output => "tmp.out"}, @filelist): - - ## Select from the given filelist, only those POD sections that are - ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. - podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist): - - ## Select the "DESCRIPTION" section of the PODs from STDIN and write - ## the result to STDERR. - podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN); - -or - - use Pod::Select; - - ## Create a parser object for selecting POD sections from the input - $parser = new Pod::Select(); - - ## Select all the POD sections for each file in @filelist - ## and print the result to tmp.out. - $parser->parse_from_file("<&STDIN", "tmp.out"); - - ## Select from the given filelist, only those POD sections that are - ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. - $parser->select("NAME|SYNOPSIS", "OPTIONS"); - for (@filelist) { $parser->parse_from_file($_); } - - ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from - ## STDIN and write the result to STDERR. - $parser->select("DESCRIPTION"); - $parser->add_selection("SEE ALSO"); - $parser->parse_from_filehandle(\*STDIN, \*STDERR); - -=head1 REQUIRES - -perl5.005, Pod::Parser, Exporter, Carp - -=head1 EXPORTS - -podselect() - -=head1 DESCRIPTION - -B is a function which will extract specified sections of -pod documentation from an input stream. This ability is provided by the -B module which is a subclass of B. -B provides a method named B to specify the set of -POD sections to select for processing/printing. B merely -creates a B object and then invokes the B -followed by B. - -=head1 SECTION SPECIFICATIONS - -B and B may be given one or more -"section specifications" to restrict the text processed to only the -desired set of sections and their corresponding subsections. A section -specification is a string containing one or more Perl-style regular -expressions separated by forward slashes ("/"). If you need to use a -forward slash literally within a section title you can escape it with a -backslash ("\/"). - -The formal syntax of a section specification is: - -=over 4 - -=item * - -I/I/... - -=back - -Any omitted or empty regular expressions will default to ".*". -Please note that each regular expression given is implicitly -anchored by adding "^" and "$" to the beginning and end. Also, if a -given regular expression starts with a "!" character, then the -expression is I (so C would match anything I -C). - -Some example section specifications follow. - -=over 4 - -=item * - -Match the C and C sections and all of their subsections: - -C - -=item * - -Match only the C and C subsections of the C -section: - -C - -=item * - -Match the C subsection of I sections: - -C - -=item * - -Match all subsections of C I for C: - -C - -=item * - -Match the C section but do I match any of its subsections: - -C - -=item * - -Match all top level sections but none of their subsections: - -C - -=back - -=begin _NOT_IMPLEMENTED_ - -=head1 RANGE SPECIFICATIONS - -B and B may be given one or more -"range specifications" to restrict the text processed to only the -desired ranges of paragraphs in the desired set of sections. A range -specification is a string containing a single Perl-style regular -expression (a regex), or else two Perl-style regular expressions -(regexs) separated by a ".." (Perl's "range" operator is ".."). -The regexs in a range specification are delimited by forward slashes -("/"). If you need to use a forward slash literally within a regex you -can escape it with a backslash ("\/"). - -The formal syntax of a range specification is: - -=over 4 - -=item * - -/I/[../I/] - -=back - -Where each the item inside square brackets (the ".." followed by the -end-range-regex) is optional. Each "range-regex" is of the form: - - =cmd-expr text-expr - -Where I is intended to match the name of one or more POD -commands, and I is intended to match the paragraph text for -the command. If a range-regex is supposed to match a POD command, then -the first character of the regex (the one after the initial '/') -absolutely I be a single '=' character; it may not be anything -else (not even a regex meta-character) if it is supposed to match -against the name of a POD command. - -If no I<=cmd-expr> is given then the text-expr will be matched against -plain textblocks unless it is preceded by a space, in which case it is -matched against verbatim text-blocks. If no I is given then -only the command-portion of the paragraph is matched against. - -Note that these two expressions are each implicitly anchored. This -means that when matching against the command-name, there will be an -implicit '^' and '$' around the given I<=cmd-expr>; and when matching -against the paragraph text there will be an implicit '\A' and '\Z' -around the given I. - -Unlike with section-specs, the '!' character does I have any special -meaning (negation or otherwise) at the beginning of a range-spec! - -Some example range specifications follow. - -=over 4 - -=item -Match all C<=for html> paragraphs: - -C - -=item -Match all paragraphs between C<=begin html> and C<=end html> -(note that this will I work correctly if such sections -are nested): - -C - -=item -Match all paragraphs between the given C<=item> name until the end of the -current section: - -C - -=item -Match all paragraphs between the given C<=item> until the next item, or -until the end of the itemized list (note that this will I work as -desired if the item contains an itemized list nested within it): - -C - -=back - -=end _NOT_IMPLEMENTED_ - -=cut - -############################################################################# - -#use diagnostics; -use Carp; -use Pod::Parser 1.04; - -@ISA = qw(Pod::Parser); -@EXPORT = qw(&podselect); - -## Maximum number of heading levels supported for '=headN' directives -*MAX_HEADING_LEVEL = \3; - -############################################################################# - -=head1 OBJECT METHODS - -The following methods are provided in this module. Each one takes a -reference to the object itself as an implicit first parameter. - -=cut - -##--------------------------------------------------------------------------- - -## =begin _PRIVATE_ -## -## =head1 B<_init_headings()> -## -## Initialize the current set of active section headings. -## -## =cut -## -## =end _PRIVATE_ - -sub _init_headings { - my $self = shift; - local *myData = $self; - - ## Initialize current section heading titles if necessary - unless (defined $myData{_SECTION_HEADINGS}) { - local *section_headings = $myData{_SECTION_HEADINGS} = []; - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $section_headings[$i] = ''; - } - } -} - -##--------------------------------------------------------------------------- - -=head1 B - - ($head1, $head2, $head3, ...) = $parser->curr_headings(); - $head1 = $parser->curr_headings(1); - -This method returns a list of the currently active section headings and -subheadings in the document being parsed. The list of headings returned -corresponds to the most recently parsed paragraph of the input. - -If an argument is given, it must correspond to the desired section -heading number, in which case only the specified section heading is -returned. If there is no current section heading at the specified -level, then C is returned. - -=cut - -sub curr_headings { - my $self = shift; - $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS}); - my @headings = @{ $self->{_SECTION_HEADINGS} }; - return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings; -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->select($section_spec1,$section_spec2,...); - -This method is used to select the particular sections and subsections of -POD documentation that are to be printed and/or processed. The existing -set of selected sections is I with the given set of sections. -See B for adding to the current set of selected -sections. - -Each of the C<$section_spec> arguments should be a section specification -as described in L<"SECTION SPECIFICATIONS">. The section specifications -are parsed by this method and the resulting regular expressions are -stored in the invoking object. - -If no C<$section_spec> arguments are given, then the existing set of -selected sections is cleared out (which means C sections will be -processed). - -This method should I normally be overridden by subclasses. - -=cut - -sub select { - my ($self, @sections) = @_; - local *myData = $self; - local $_; - -### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?) - - ##--------------------------------------------------------------------- - ## The following is a blatant hack for backward compatibility, and for - ## implementing add_selection(). If the *first* *argument* is the - ## string "+", then the remaining section specifications are *added* - ## to the current set of selections; otherwise the given section - ## specifications will *replace* the current set of selections. - ## - ## This should probably be fixed someday, but for the present time, - ## it seems incredibly unlikely that "+" would ever correspond to - ## a legitimate section heading - ##--------------------------------------------------------------------- - my $add = ($sections[0] eq '+') ? shift(@sections) : ''; - - ## Reset the set of sections to use - unless (@sections) { - delete $myData{_SELECTED_SECTIONS} unless ($add); - return; - } - $myData{_SELECTED_SECTIONS} = [] - unless ($add && exists $myData{_SELECTED_SECTIONS}); - local *selected_sections = $myData{_SELECTED_SECTIONS}; - - ## Compile each spec - for my $spec (@sections) { - if ( defined($_ = _compile_section_spec($spec)) ) { - ## Store them in our sections array - push(@selected_sections, $_); - } - else { - carp qq{Ignoring section spec "$spec"!\n}; - } - } -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->add_selection($section_spec1,$section_spec2,...); - -This method is used to add to the currently selected sections and -subsections of POD documentation that are to be printed and/or -processed. See for replacing the currently selected sections. - -Each of the C<$section_spec> arguments should be a section specification -as described in L<"SECTION SPECIFICATIONS">. The section specifications -are parsed by this method and the resulting regular expressions are -stored in the invoking object. - -This method should I normally be overridden by subclasses. - -=cut - -sub add_selection { - my $self = shift; - return $self->select('+', @_); -} - -##--------------------------------------------------------------------------- - -=head1 B - - $parser->clear_selections(); - -This method takes no arguments, it has the exact same effect as invoking - with no arguments. - -=cut - -sub clear_selections { - my $self = shift; - return $self->select(); -} - -##--------------------------------------------------------------------------- - -=head1 B - - $boolean = $parser->match_section($heading1,$heading2,...); - -Returns a value of true if the given section and subsection heading -titles match any of the currently selected section specifications in -effect from prior calls to B and B (or if -there are no explicitly selected/deselected sections). - -The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of -the corresponding sections, subsections, etc. to try and match. If -C<$headingN> is omitted then it defaults to the current corresponding -section heading title in the input. - -This method should I normally be overridden by subclasses. - -=cut - -sub match_section { - my $self = shift; - my (@headings) = @_; - local *myData = $self; - - ## Return true if no restrictions were explicitly specified - my $selections = (exists $myData{_SELECTED_SECTIONS}) - ? $myData{_SELECTED_SECTIONS} : undef; - return 1 unless ((defined $selections) && @{$selections}); - - ## Default any unspecified sections to the current one - my @current_headings = $self->curr_headings(); - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - (defined $headings[$i]) or $headings[$i] = $current_headings[$i]; - } - - ## Look for a match against the specified section expressions - for my $section_spec ( @{$selections} ) { - ##------------------------------------------------------ - ## Each portion of this spec must match in order for - ## the spec to be matched. So we will start with a - ## match-value of 'true' and logically 'and' it with - ## the results of matching a given element of the spec. - ##------------------------------------------------------ - my $match = 1; - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - my $regex = $section_spec->[$i]; - my $negated = ($regex =~ s/^\!//); - $match &= ($negated ? ($headings[$i] !~ /${regex}/) - : ($headings[$i] =~ /${regex}/)); - last unless ($match); - } - return 1 if ($match); - } - return 0; ## no match -} - -##--------------------------------------------------------------------------- - -=head1 B - - $boolean = $parser->is_selected($paragraph); - -This method is used to determine if the block of text given in -C<$paragraph> falls within the currently selected set of POD sections -and subsections to be printed or processed. This method is also -responsible for keeping track of the current input section and -subsections. It is assumed that C<$paragraph> is the most recently read -(but not yet processed) input paragraph. - -The value returned will be true if the C<$paragraph> and the rest of the -text in the same section as C<$paragraph> should be selected (included) -for processing; otherwise a false value is returned. - -=cut - -sub is_selected { - my ($self, $paragraph) = @_; - local $_; - local *myData = $self; - - $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS}); - - ## Keep track of current sections levels and headings - $_ = $paragraph; - if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/) - { - ## This is a section heading command - my ($level, $heading) = ($2, $3); - $level = 1 + (length($1) / 3) if ((! length $level) || (length $1)); - ## Reset the current section heading at this level - $myData{_SECTION_HEADINGS}->[$level - 1] = $heading; - ## Reset subsection headings of this one to empty - for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) { - $myData{_SECTION_HEADINGS}->[$i] = ''; - } - } - - return $self->match_section(); -} - -############################################################################# - -=head1 EXPORTED FUNCTIONS - -The following functions are exported by this module. Please note that -these are functions (not methods) and therefore C take an -implicit first argument. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B - - podselect(\%options,@filelist); - -B will print the raw (untranslated) POD paragraphs of all -POD sections in the given input files specified by C<@filelist> -according to the given options. - -If any argument to B is a reference to a hash -(associative array) then the values with the following keys are -processed as follows: - -=over 4 - -=item B<-output> - -A string corresponding to the desired output file (or ">&STDOUT" -or ">&STDERR"). The default is to use standard output. - -=item B<-sections> - -A reference to an array of sections specifications (as described in -L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD -sections and subsections to be selected from input. If no section -specifications are given, then all sections of the PODs are used. - -=begin _NOT_IMPLEMENTED_ - -=item B<-ranges> - -A reference to an array of range specifications (as described in -L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD -paragraphs to be selected from the desired input sections. If no range -specifications are given, then all paragraphs of the desired sections -are used. - -=end _NOT_IMPLEMENTED_ - -=back - -All other arguments should correspond to the names of input files -containing POD sections. A file name of "-" or "<&STDIN" will -be interpreted to mean standard input (which is the default if no -filenames are given). - -=cut - -sub podselect { - my(@argv) = @_; - my %defaults = (); - my $pod_parser = new Pod::Select(%defaults); - my $num_inputs = 0; - my $output = '>&STDOUT'; - my %opts; - local $_; - for (@argv) { - if (ref($_)) { - next unless (ref($_) eq 'HASH'); - %opts = (%defaults, %{$_}); - - ##------------------------------------------------------------- - ## Need this for backward compatibility since we formerly used - ## options that were all uppercase words rather than ones that - ## looked like Unix command-line options. - ## to be uppercase keywords) - ##------------------------------------------------------------- - %opts = map { - my ($key, $val) = (lc $_, $opts{$_}); - $key =~ s/^(?=\w)/-/; - $key =~ /^-se[cl]/ and $key = '-sections'; - #! $key eq '-range' and $key .= 's'; - ($key => $val); - } (keys %opts); - - ## Process the options - (exists $opts{'-output'}) and $output = $opts{'-output'}; - - ## Select the desired sections - $pod_parser->select(@{ $opts{'-sections'} }) - if ( (defined $opts{'-sections'}) - && ((ref $opts{'-sections'}) eq 'ARRAY') ); - - #! ## Select the desired paragraph ranges - #! $pod_parser->select(@{ $opts{'-ranges'} }) - #! if ( (defined $opts{'-ranges'}) - #! && ((ref $opts{'-ranges'}) eq 'ARRAY') ); - } - else { - $pod_parser->parse_from_file($_, $output); - ++$num_inputs; - } - } - $pod_parser->parse_from_file('-') unless ($num_inputs > 0); -} - -############################################################################# - -=head1 PRIVATE METHODS AND DATA - -B makes uses a number of internal methods and data fields -which clients should not need to see or use. For the sake of avoiding -name collisions with client data and methods, these methods and fields -are briefly discussed here. Determined hackers may obtain further -information about them by reading the B source code. - -Private data fields are stored in the hash-object whose reference is -returned by the B constructor for this class. The names of all -private methods and data-fields used by B begin with a -prefix of "_" and match the regular expression C. - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_compile_section_spec()> - - $listref = $parser->_compile_section_spec($section_spec); - -This function (note it is a function and I a method) takes a -section specification (as described in L<"SECTION SPECIFICATIONS">) -given in C<$section_sepc>, and compiles it into a list of regular -expressions. If C<$section_spec> has no syntax errors, then a reference -to the list (array) of corresponding regular expressions is returned; -otherwise C is returned and an error message is printed (using -B) for each invalid regex. - -=end _PRIVATE_ - -=cut - -sub _compile_section_spec { - my ($section_spec) = @_; - my (@regexs, $negated); - - ## Compile the spec into a list of regexs - local $_ = $section_spec; - s{\\\\}{\001}g; ## handle escaped backward slashes - s{\\/}{\002}g; ## handle escaped forward slashes - - ## Parse the regexs for the heading titles - @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); - - ## Set default regex for ommitted levels - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $regexs[$i] = '.*' unless ((defined $regexs[$i]) - && (length $regexs[$i])); - } - ## Modify the regexs as needed and validate their syntax - my $bad_regexs = 0; - for (@regexs) { - $_ .= '.+' if ($_ eq '!'); - s{\001}{\\\\}g; ## restore escaped backward slashes - s{\002}{\\/}g; ## restore escaped forward slashes - $negated = s/^\!//; ## check for negation - eval "m{$_}"; ## check regex syntax - if ($@) { - ++$bad_regexs; - carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; - } - else { - ## Add the forward and rear anchors (and put the negator back) - $_ = '^' . $_ unless (/^\^/); - $_ = $_ . '$' unless (/\$$/); - $_ = '!' . $_ if ($negated); - } - } - return (! $bad_regexs) ? [ @regexs ] : undef; -} - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head2 $self->{_SECTION_HEADINGS} - -A reference to an array of the current section heading titles for each -heading level (note that the first heading level title is at index 0). - -=end _PRIVATE_ - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head2 $self->{_SELECTED_SECTIONS} - -A reference to an array of references to arrays. Each subarray is a list -of anchored regular expressions (preceded by a "!" if the expression is to -be negated). The index of the expression in the subarray should correspond -to the index of the heading title in C<$self-E{_SECTION_HEADINGS}> -that it is to be matched against. - -=end _PRIVATE_ - -=cut - -############################################################################# - -=head1 SEE ALSO - -L - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -B is part of the L distribution. - -=cut - -1; -# vim: ts=4 sw=4 et +############################################################################# +# Pod/Select.pm -- function to select portions of POD docs +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Select; +use strict; + +use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections); +$VERSION = '1.60'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::Select, podselect() - extract selected sections of POD from input + +=head1 SYNOPSIS + + use Pod::Select; + + ## Select all the POD sections for each file in @filelist + ## and print the result on standard output. + podselect(@filelist); + + ## Same as above, but write to tmp.out + podselect({-output => "tmp.out"}, @filelist): + + ## Select from the given filelist, only those POD sections that are + ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. + podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist): + + ## Select the "DESCRIPTION" section of the PODs from STDIN and write + ## the result to STDERR. + podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN); + +or + + use Pod::Select; + + ## Create a parser object for selecting POD sections from the input + $parser = new Pod::Select(); + + ## Select all the POD sections for each file in @filelist + ## and print the result to tmp.out. + $parser->parse_from_file("<&STDIN", "tmp.out"); + + ## Select from the given filelist, only those POD sections that are + ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. + $parser->select("NAME|SYNOPSIS", "OPTIONS"); + for (@filelist) { $parser->parse_from_file($_); } + + ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from + ## STDIN and write the result to STDERR. + $parser->select("DESCRIPTION"); + $parser->add_selection("SEE ALSO"); + $parser->parse_from_filehandle(\*STDIN, \*STDERR); + +=head1 REQUIRES + +perl5.005, Pod::Parser, Exporter, Carp + +=head1 EXPORTS + +podselect() + +=head1 DESCRIPTION + +B is a function which will extract specified sections of +pod documentation from an input stream. This ability is provided by the +B module which is a subclass of B. +B provides a method named B to specify the set of +POD sections to select for processing/printing. B merely +creates a B object and then invokes the B +followed by B. + +=head1 SECTION SPECIFICATIONS + +B and B may be given one or more +"section specifications" to restrict the text processed to only the +desired set of sections and their corresponding subsections. A section +specification is a string containing one or more Perl-style regular +expressions separated by forward slashes ("/"). If you need to use a +forward slash literally within a section title you can escape it with a +backslash ("\/"). + +The formal syntax of a section specification is: + +=over 4 + +=item * + +I/I/... + +=back + +Any omitted or empty regular expressions will default to ".*". +Please note that each regular expression given is implicitly +anchored by adding "^" and "$" to the beginning and end. Also, if a +given regular expression starts with a "!" character, then the +expression is I (so C would match anything I +C). + +Some example section specifications follow. + +=over 4 + +=item * + +Match the C and C sections and all of their subsections: + +C + +=item * + +Match only the C and C subsections of the C +section: + +C + +=item * + +Match the C subsection of I sections: + +C + +=item * + +Match all subsections of C I for C: + +C + +=item * + +Match the C section but do I match any of its subsections: + +C + +=item * + +Match all top level sections but none of their subsections: + +C + +=back + +=begin _NOT_IMPLEMENTED_ + +=head1 RANGE SPECIFICATIONS + +B and B may be given one or more +"range specifications" to restrict the text processed to only the +desired ranges of paragraphs in the desired set of sections. A range +specification is a string containing a single Perl-style regular +expression (a regex), or else two Perl-style regular expressions +(regexs) separated by a ".." (Perl's "range" operator is ".."). +The regexs in a range specification are delimited by forward slashes +("/"). If you need to use a forward slash literally within a regex you +can escape it with a backslash ("\/"). + +The formal syntax of a range specification is: + +=over 4 + +=item * + +/I/[../I/] + +=back + +Where each the item inside square brackets (the ".." followed by the +end-range-regex) is optional. Each "range-regex" is of the form: + + =cmd-expr text-expr + +Where I is intended to match the name of one or more POD +commands, and I is intended to match the paragraph text for +the command. If a range-regex is supposed to match a POD command, then +the first character of the regex (the one after the initial '/') +absolutely I be a single '=' character; it may not be anything +else (not even a regex meta-character) if it is supposed to match +against the name of a POD command. + +If no I<=cmd-expr> is given then the text-expr will be matched against +plain textblocks unless it is preceded by a space, in which case it is +matched against verbatim text-blocks. If no I is given then +only the command-portion of the paragraph is matched against. + +Note that these two expressions are each implicitly anchored. This +means that when matching against the command-name, there will be an +implicit '^' and '$' around the given I<=cmd-expr>; and when matching +against the paragraph text there will be an implicit '\A' and '\Z' +around the given I. + +Unlike with section-specs, the '!' character does I have any special +meaning (negation or otherwise) at the beginning of a range-spec! + +Some example range specifications follow. + +=over 4 + +=item +Match all C<=for html> paragraphs: + +C + +=item +Match all paragraphs between C<=begin html> and C<=end html> +(note that this will I work correctly if such sections +are nested): + +C + +=item +Match all paragraphs between the given C<=item> name until the end of the +current section: + +C + +=item +Match all paragraphs between the given C<=item> until the next item, or +until the end of the itemized list (note that this will I work as +desired if the item contains an itemized list nested within it): + +C + +=back + +=end _NOT_IMPLEMENTED_ + +=cut + +############################################################################# + +#use diagnostics; +use Carp; +use Pod::Parser 1.04; + +@ISA = qw(Pod::Parser); +@EXPORT = qw(&podselect); + +## Maximum number of heading levels supported for '=headN' directives +*MAX_HEADING_LEVEL = \3; + +############################################################################# + +=head1 OBJECT METHODS + +The following methods are provided in this module. Each one takes a +reference to the object itself as an implicit first parameter. + +=cut + +##--------------------------------------------------------------------------- + +## =begin _PRIVATE_ +## +## =head1 B<_init_headings()> +## +## Initialize the current set of active section headings. +## +## =cut +## +## =end _PRIVATE_ + +sub _init_headings { + my $self = shift; + local *myData = $self; + + ## Initialize current section heading titles if necessary + unless (defined $myData{_SECTION_HEADINGS}) { + local *section_headings = $myData{_SECTION_HEADINGS} = []; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $section_headings[$i] = ''; + } + } +} + +##--------------------------------------------------------------------------- + +=head1 B + + ($head1, $head2, $head3, ...) = $parser->curr_headings(); + $head1 = $parser->curr_headings(1); + +This method returns a list of the currently active section headings and +subheadings in the document being parsed. The list of headings returned +corresponds to the most recently parsed paragraph of the input. + +If an argument is given, it must correspond to the desired section +heading number, in which case only the specified section heading is +returned. If there is no current section heading at the specified +level, then C is returned. + +=cut + +sub curr_headings { + my $self = shift; + $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS}); + my @headings = @{ $self->{_SECTION_HEADINGS} }; + return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings; +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->select($section_spec1,$section_spec2,...); + +This method is used to select the particular sections and subsections of +POD documentation that are to be printed and/or processed. The existing +set of selected sections is I with the given set of sections. +See B for adding to the current set of selected +sections. + +Each of the C<$section_spec> arguments should be a section specification +as described in L<"SECTION SPECIFICATIONS">. The section specifications +are parsed by this method and the resulting regular expressions are +stored in the invoking object. + +If no C<$section_spec> arguments are given, then the existing set of +selected sections is cleared out (which means C sections will be +processed). + +This method should I normally be overridden by subclasses. + +=cut + +sub select { + my ($self, @sections) = @_; + local *myData = $self; + local $_; + +### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?) + + ##--------------------------------------------------------------------- + ## The following is a blatant hack for backward compatibility, and for + ## implementing add_selection(). If the *first* *argument* is the + ## string "+", then the remaining section specifications are *added* + ## to the current set of selections; otherwise the given section + ## specifications will *replace* the current set of selections. + ## + ## This should probably be fixed someday, but for the present time, + ## it seems incredibly unlikely that "+" would ever correspond to + ## a legitimate section heading + ##--------------------------------------------------------------------- + my $add = ($sections[0] eq '+') ? shift(@sections) : ''; + + ## Reset the set of sections to use + unless (@sections) { + delete $myData{_SELECTED_SECTIONS} unless ($add); + return; + } + $myData{_SELECTED_SECTIONS} = [] + unless ($add && exists $myData{_SELECTED_SECTIONS}); + local *selected_sections = $myData{_SELECTED_SECTIONS}; + + ## Compile each spec + for my $spec (@sections) { + if ( defined($_ = _compile_section_spec($spec)) ) { + ## Store them in our sections array + push(@selected_sections, $_); + } + else { + carp qq{Ignoring section spec "$spec"!\n}; + } + } +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->add_selection($section_spec1,$section_spec2,...); + +This method is used to add to the currently selected sections and +subsections of POD documentation that are to be printed and/or +processed. See for replacing the currently selected sections. + +Each of the C<$section_spec> arguments should be a section specification +as described in L<"SECTION SPECIFICATIONS">. The section specifications +are parsed by this method and the resulting regular expressions are +stored in the invoking object. + +This method should I normally be overridden by subclasses. + +=cut + +sub add_selection { + my $self = shift; + return $self->select('+', @_); +} + +##--------------------------------------------------------------------------- + +=head1 B + + $parser->clear_selections(); + +This method takes no arguments, it has the exact same effect as invoking + with no arguments. + +=cut + +sub clear_selections { + my $self = shift; + return $self->select(); +} + +##--------------------------------------------------------------------------- + +=head1 B + + $boolean = $parser->match_section($heading1,$heading2,...); + +Returns a value of true if the given section and subsection heading +titles match any of the currently selected section specifications in +effect from prior calls to B and B (or if +there are no explicitly selected/deselected sections). + +The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of +the corresponding sections, subsections, etc. to try and match. If +C<$headingN> is omitted then it defaults to the current corresponding +section heading title in the input. + +This method should I normally be overridden by subclasses. + +=cut + +sub match_section { + my $self = shift; + my (@headings) = @_; + local *myData = $self; + + ## Return true if no restrictions were explicitly specified + my $selections = (exists $myData{_SELECTED_SECTIONS}) + ? $myData{_SELECTED_SECTIONS} : undef; + return 1 unless ((defined $selections) && @{$selections}); + + ## Default any unspecified sections to the current one + my @current_headings = $self->curr_headings(); + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + (defined $headings[$i]) or $headings[$i] = $current_headings[$i]; + } + + ## Look for a match against the specified section expressions + for my $section_spec ( @{$selections} ) { + ##------------------------------------------------------ + ## Each portion of this spec must match in order for + ## the spec to be matched. So we will start with a + ## match-value of 'true' and logically 'and' it with + ## the results of matching a given element of the spec. + ##------------------------------------------------------ + my $match = 1; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + my $regex = $section_spec->[$i]; + my $negated = ($regex =~ s/^\!//); + $match &= ($negated ? ($headings[$i] !~ /${regex}/) + : ($headings[$i] =~ /${regex}/)); + last unless ($match); + } + return 1 if ($match); + } + return 0; ## no match +} + +##--------------------------------------------------------------------------- + +=head1 B + + $boolean = $parser->is_selected($paragraph); + +This method is used to determine if the block of text given in +C<$paragraph> falls within the currently selected set of POD sections +and subsections to be printed or processed. This method is also +responsible for keeping track of the current input section and +subsections. It is assumed that C<$paragraph> is the most recently read +(but not yet processed) input paragraph. + +The value returned will be true if the C<$paragraph> and the rest of the +text in the same section as C<$paragraph> should be selected (included) +for processing; otherwise a false value is returned. + +=cut + +sub is_selected { + my ($self, $paragraph) = @_; + local $_; + local *myData = $self; + + $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS}); + + ## Keep track of current sections levels and headings + $_ = $paragraph; + if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/) + { + ## This is a section heading command + my ($level, $heading) = ($2, $3); + $level = 1 + (length($1) / 3) if ((! length $level) || (length $1)); + ## Reset the current section heading at this level + $myData{_SECTION_HEADINGS}->[$level - 1] = $heading; + ## Reset subsection headings of this one to empty + for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) { + $myData{_SECTION_HEADINGS}->[$i] = ''; + } + } + + return $self->match_section(); +} + +############################################################################# + +=head1 EXPORTED FUNCTIONS + +The following functions are exported by this module. Please note that +these are functions (not methods) and therefore C take an +implicit first argument. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B + + podselect(\%options,@filelist); + +B will print the raw (untranslated) POD paragraphs of all +POD sections in the given input files specified by C<@filelist> +according to the given options. + +If any argument to B is a reference to a hash +(associative array) then the values with the following keys are +processed as follows: + +=over 4 + +=item B<-output> + +A string corresponding to the desired output file (or ">&STDOUT" +or ">&STDERR"). The default is to use standard output. + +=item B<-sections> + +A reference to an array of sections specifications (as described in +L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD +sections and subsections to be selected from input. If no section +specifications are given, then all sections of the PODs are used. + +=begin _NOT_IMPLEMENTED_ + +=item B<-ranges> + +A reference to an array of range specifications (as described in +L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD +paragraphs to be selected from the desired input sections. If no range +specifications are given, then all paragraphs of the desired sections +are used. + +=end _NOT_IMPLEMENTED_ + +=back + +All other arguments should correspond to the names of input files +containing POD sections. A file name of "-" or "<&STDIN" will +be interpreted to mean standard input (which is the default if no +filenames are given). + +=cut + +sub podselect { + my(@argv) = @_; + my %defaults = (); + my $pod_parser = new Pod::Select(%defaults); + my $num_inputs = 0; + my $output = '>&STDOUT'; + my %opts; + local $_; + for (@argv) { + if (ref($_)) { + next unless (ref($_) eq 'HASH'); + %opts = (%defaults, %{$_}); + + ##------------------------------------------------------------- + ## Need this for backward compatibility since we formerly used + ## options that were all uppercase words rather than ones that + ## looked like Unix command-line options. + ## to be uppercase keywords) + ##------------------------------------------------------------- + %opts = map { + my ($key, $val) = (lc $_, $opts{$_}); + $key =~ s/^(?=\w)/-/; + $key =~ /^-se[cl]/ and $key = '-sections'; + #! $key eq '-range' and $key .= 's'; + ($key => $val); + } (keys %opts); + + ## Process the options + (exists $opts{'-output'}) and $output = $opts{'-output'}; + + ## Select the desired sections + $pod_parser->select(@{ $opts{'-sections'} }) + if ( (defined $opts{'-sections'}) + && ((ref $opts{'-sections'}) eq 'ARRAY') ); + + #! ## Select the desired paragraph ranges + #! $pod_parser->select(@{ $opts{'-ranges'} }) + #! if ( (defined $opts{'-ranges'}) + #! && ((ref $opts{'-ranges'}) eq 'ARRAY') ); + } + else { + $pod_parser->parse_from_file($_, $output); + ++$num_inputs; + } + } + $pod_parser->parse_from_file('-') unless ($num_inputs > 0); +} + +############################################################################# + +=head1 PRIVATE METHODS AND DATA + +B makes uses a number of internal methods and data fields +which clients should not need to see or use. For the sake of avoiding +name collisions with client data and methods, these methods and fields +are briefly discussed here. Determined hackers may obtain further +information about them by reading the B source code. + +Private data fields are stored in the hash-object whose reference is +returned by the B constructor for this class. The names of all +private methods and data-fields used by B begin with a +prefix of "_" and match the regular expression C. + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_compile_section_spec()> + + $listref = $parser->_compile_section_spec($section_spec); + +This function (note it is a function and I a method) takes a +section specification (as described in L<"SECTION SPECIFICATIONS">) +given in C<$section_sepc>, and compiles it into a list of regular +expressions. If C<$section_spec> has no syntax errors, then a reference +to the list (array) of corresponding regular expressions is returned; +otherwise C is returned and an error message is printed (using +B) for each invalid regex. + +=end _PRIVATE_ + +=cut + +sub _compile_section_spec { + my ($section_spec) = @_; + my (@regexs, $negated); + + ## Compile the spec into a list of regexs + local $_ = $section_spec; + s{\\\\}{\001}g; ## handle escaped backward slashes + s{\\/}{\002}g; ## handle escaped forward slashes + + ## Parse the regexs for the heading titles + @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); + + ## Set default regex for ommitted levels + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $regexs[$i] = '.*' unless ((defined $regexs[$i]) + && (length $regexs[$i])); + } + ## Modify the regexs as needed and validate their syntax + my $bad_regexs = 0; + for (@regexs) { + $_ .= '.+' if ($_ eq '!'); + s{\001}{\\\\}g; ## restore escaped backward slashes + s{\002}{\\/}g; ## restore escaped forward slashes + $negated = s/^\!//; ## check for negation + eval "m{$_}"; ## check regex syntax + if ($@) { + ++$bad_regexs; + carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; + } + else { + ## Add the forward and rear anchors (and put the negator back) + $_ = '^' . $_ unless (/^\^/); + $_ = $_ . '$' unless (/\$$/); + $_ = '!' . $_ if ($negated); + } + } + return (! $bad_regexs) ? [ @regexs ] : undef; +} + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head2 $self->{_SECTION_HEADINGS} + +A reference to an array of the current section heading titles for each +heading level (note that the first heading level title is at index 0). + +=end _PRIVATE_ + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head2 $self->{_SELECTED_SECTIONS} + +A reference to an array of references to arrays. Each subarray is a list +of anchored regular expressions (preceded by a "!" if the expression is to +be negated). The index of the expression in the subarray should correspond +to the index of the heading title in C<$self-E{_SECTION_HEADINGS}> +that it is to be matched against. + +=end _PRIVATE_ + +=cut + +############################################################################# + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +B is part of the L distribution. + +=cut + +1; +# vim: ts=4 sw=4 et diff --git a/cpan/Pod-Parser/lib/Pod/Usage.pm b/cpan/Pod-Parser/lib/Pod/Usage.pm deleted file mode 100644 index d060b275d1..0000000000 --- a/cpan/Pod-Parser/lib/Pod/Usage.pm +++ /dev/null @@ -1,747 +0,0 @@ -############################################################################# -# Pod/Usage.pm -- print usage messages for the running script. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Usage; -use strict; - -use vars qw($VERSION @ISA @EXPORT); -$VERSION = '1.51'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -=head1 NAME - -Pod::Usage, pod2usage() - print a usage message from embedded pod documentation - -=head1 SYNOPSIS - - use Pod::Usage - - my $message_text = "This text precedes the usage message."; - my $exit_status = 2; ## The exit status to use - my $verbose_level = 0; ## The verbose level to use - my $filehandle = \*STDERR; ## The filehandle to write to - - pod2usage($message_text); - - pod2usage($exit_status); - - pod2usage( { -message => $message_text , - -exitval => $exit_status , - -verbose => $verbose_level, - -output => $filehandle } ); - - pod2usage( -msg => $message_text , - -exitval => $exit_status , - -verbose => $verbose_level, - -output => $filehandle ); - - pod2usage( -verbose => 2, - -noperldoc => 1 ) - -=head1 ARGUMENTS - -B should be given either a single argument, or a list of -arguments corresponding to an associative array (a "hash"). When a single -argument is given, it should correspond to exactly one of the following: - -=over 4 - -=item * - -A string containing the text of a message to print I printing -the usage message - -=item * - -A numeric value corresponding to the desired exit status - -=item * - -A reference to a hash - -=back - -If more than one argument is given then the entire argument list is -assumed to be a hash. If a hash is supplied (either as a reference or -as a list) it should contain one or more elements with the following -keys: - -=over 4 - -=item C<-message> - -=item C<-msg> - -The text of a message to print immediately prior to printing the -program's usage message. - -=item C<-exitval> - -The desired exit status to pass to the B function. -This should be an integer, or else the string "NOEXIT" to -indicate that control should simply be returned without -terminating the invoking process. - -=item C<-verbose> - -The desired level of "verboseness" to use when printing the usage -message. If the corresponding value is 0, then only the "SYNOPSIS" -section of the pod documentation is printed. If the corresponding value -is 1, then the "SYNOPSIS" section, along with any section entitled -"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the -corresponding value is 2 or more then the entire manpage is printed. - -The special verbosity level 99 requires to also specify the -sections -parameter; then these sections are extracted (see L) -and printed. - -=item C<-sections> - -A string representing a selection list for sections to be printed -when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. - -Alternatively, an array reference of section specifications can be used: - - pod2usage(-verbose => 99, - -sections => [ qw(fred fred/subsection) ] ); - -=item C<-output> - -A reference to a filehandle, or the pathname of a file to which the -usage message should be written. The default is C<\*STDERR> unless the -exit value is less than 2 (in which case the default is C<\*STDOUT>). - -=item C<-input> - -A reference to a filehandle, or the pathname of a file from which the -invoking script's pod documentation should be read. It defaults to the -file indicated by C<$0> (C<$PROGRAM_NAME> for users of F). - -If you are calling B from a module and want to display -that module's POD, you can use this: - - use Pod::Find qw(pod_where); - pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) ); - -=item C<-pathlist> - -A list of directory paths. If the input file does not exist, then it -will be searched for in the given directory list (in the order the -directories appear in the list). It defaults to the list of directories -implied by C<$ENV{PATH}>. The list may be specified either by a reference -to an array, or by a string of directory paths which use the same path -separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for -MSWin32 and DOS). - -=item C<-noperldoc> - -By default, Pod::Usage will call L when -verbose >= 2 is -specified. This does not work well e.g. if the script was packed -with L. The -noperldoc option suppresses the external call to -L and uses the simple text formatter (L) to -output the POD. - -=back - -=head2 Pass-through options - -The following options are passed through to the underlying text formatter -(L or L for Perl versions E 5.005_58). See -the manual pages of these modules for more information. - - alt code indent loose margin quotes sentence stderr utf8 width - -=head1 DESCRIPTION - -B will print a usage message for the invoking script (using -its embedded pod documentation) and then exit the script with the -desired exit status. The usage message printed may have any one of three -levels of "verboseness": If the verbose level is 0, then only a synopsis -is printed. If the verbose level is 1, then the synopsis is printed -along with a description (if present) of the command line options and -arguments. If the verbose level is 2, then the entire manual page is -printed. - -Unless they are explicitly specified, the default values for the exit -status, verbose level, and output stream to use are determined as -follows: - -=over 4 - -=item * - -If neither the exit status nor the verbose level is specified, then the -default is to use an exit status of 2 with a verbose level of 0. - -=item * - -If an exit status I specified but the verbose level is I, then the -verbose level will default to 1 if the exit status is less than 2 and -will default to 0 otherwise. - -=item * - -If an exit status is I specified but verbose level I given, then -the exit status will default to 2 if the verbose level is 0 and will -default to 1 otherwise. - -=item * - -If the exit status used is less than 2, then output is printed on -C. Otherwise output is printed on C. - -=back - -Although the above may seem a bit confusing at first, it generally does -"the right thing" in most situations. This determination of the default -values to use is based upon the following typical Unix conventions: - -=over 4 - -=item * - -An exit status of 0 implies "success". For example, B exits -with a status of 0 if the two files have the same contents. - -=item * - -An exit status of 1 implies possibly abnormal, but non-defective, program -termination. For example, B exits with a status of 1 if -it did I find a matching line for the given regular expression. - -=item * - -An exit status of 2 or more implies a fatal error. For example, B -exits with a status of 2 if you specify an illegal (unknown) option on -the command line. - -=item * - -Usage messages issued as a result of bad command-line syntax should go -to C. However, usage messages issued due to an explicit request -to print usage (like specifying B<-help> on the command line) should go -to C, just in case the user wants to pipe the output to a pager -(such as B). - -=item * - -If program usage has been explicitly requested by the user, it is often -desirable to exit with a status of 1 (as opposed to 0) after issuing -the user-requested usage message. It is also desirable to give a -more verbose description of program usage in this case. - -=back - -B doesn't force the above conventions upon you, but it will -use them by default if you don't expressly tell it to do otherwise. The -ability of B to accept a single number or a string makes it -convenient to use as an innocent looking error message handling function: - - use Pod::Usage; - use Getopt::Long; - - ## Parse options - GetOptions("help", "man", "flag1") || pod2usage(2); - pod2usage(1) if ($opt_help); - pod2usage(-verbose => 2) if ($opt_man); - - ## Check for too many filenames - pod2usage("$0: Too many files given.\n") if (@ARGV > 1); - -Some user's however may feel that the above "economy of expression" is -not particularly readable nor consistent and may instead choose to do -something more like the following: - - use Pod::Usage; - use Getopt::Long; - - ## Parse options - GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); - pod2usage(-verbose => 1) if ($opt_help); - pod2usage(-verbose => 2) if ($opt_man); - - ## Check for too many filenames - pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") - if (@ARGV > 1); - -As with all things in Perl, I, and -B adheres to this philosophy. If you are interested in -seeing a number of different ways to invoke B (although by no -means exhaustive), please refer to L<"EXAMPLES">. - -=head1 EXAMPLES - -Each of the following invocations of C will print just the -"SYNOPSIS" section to C and will exit with a status of 2: - - pod2usage(); - - pod2usage(2); - - pod2usage(-verbose => 0); - - pod2usage(-exitval => 2); - - pod2usage({-exitval => 2, -output => \*STDERR}); - - pod2usage({-verbose => 0, -output => \*STDERR}); - - pod2usage(-exitval => 2, -verbose => 0); - - pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR); - -Each of the following invocations of C will print a message -of "Syntax error." (followed by a newline) to C, immediately -followed by just the "SYNOPSIS" section (also printed to C) and -will exit with a status of 2: - - pod2usage("Syntax error."); - - pod2usage(-message => "Syntax error.", -verbose => 0); - - pod2usage(-msg => "Syntax error.", -exitval => 2); - - pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR}); - - pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR}); - - pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0); - - pod2usage(-message => "Syntax error.", - -exitval => 2, - -verbose => 0, - -output => \*STDERR); - -Each of the following invocations of C will print the -"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to -C and will exit with a status of 1: - - pod2usage(1); - - pod2usage(-verbose => 1); - - pod2usage(-exitval => 1); - - pod2usage({-exitval => 1, -output => \*STDOUT}); - - pod2usage({-verbose => 1, -output => \*STDOUT}); - - pod2usage(-exitval => 1, -verbose => 1); - - pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT}); - -Each of the following invocations of C will print the -entire manual page to C and will exit with a status of 1: - - pod2usage(-verbose => 2); - - pod2usage({-verbose => 2, -output => \*STDOUT}); - - pod2usage(-exitval => 1, -verbose => 2); - - pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT}); - -=head2 Recommended Use - -Most scripts should print some type of usage message to C when a -command line syntax error is detected. They should also provide an -option (usually C<-H> or C<-help>) to print a (possibly more verbose) -usage message to C. Some scripts may even wish to go so far as to -provide a means of printing their complete documentation to C -(perhaps by allowing a C<-man> option). The following complete example -uses B in combination with B to do all of these -things: - - use Getopt::Long; - use Pod::Usage; - - my $man = 0; - my $help = 0; - ## Parse options and print usage if there is a syntax error, - ## or if usage was explicitly requested. - GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); - pod2usage(1) if $help; - pod2usage(-verbose => 2) if $man; - - ## If no arguments were given, then allow STDIN to be used only - ## if it's not connected to a terminal (otherwise print usage) - pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); - __END__ - - =head1 NAME - - sample - Using GetOpt::Long and Pod::Usage - - =head1 SYNOPSIS - - sample [options] [file ...] - - Options: - -help brief help message - -man full documentation - - =head1 OPTIONS - - =over 8 - - =item B<-help> - - Print a brief help message and exits. - - =item B<-man> - - Prints the manual page and exits. - - =back - - =head1 DESCRIPTION - - B will read the given input file(s) and do something - useful with the contents thereof. - - =cut - -=head1 CAVEATS - -By default, B will use C<$0> as the path to the pod input -file. Unfortunately, not all systems on which Perl runs will set C<$0> -properly (although if C<$0> isn't found, B will search -C<$ENV{PATH}> or else the list specified by the C<-pathlist> option). -If this is the case for your system, you may need to explicitly specify -the path to the pod docs for the invoking script using something -similar to the following: - - pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); - -In the pathological case that a script is called via a relative path -I the script itself changes the current working directory -(see L) I calling pod2usage, Pod::Usage will -fail even on robust platforms. Don't do that. - -=head1 AUTHOR - -Please report bugs using L. - -Marek Rouchal Emarekr@cpan.orgE - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=head1 ACKNOWLEDGMENTS - -Steven McDougall Eswmcd@world.std.comE for his help and patience -with re-writing this manpage. - -=head1 SEE ALSO - -B is part of the L distribution. - -L, L, L - -=cut - -############################################################################# - -#use diagnostics; -use Carp; -use Config; -use Exporter; -use File::Spec; - -@EXPORT = qw(&pod2usage); -BEGIN { - if ( $] >= 5.005_58 ) { - require Pod::Text; - @ISA = qw( Pod::Text ); - } - else { - require Pod::PlainText; - @ISA = qw( Pod::PlainText ); - } -} - -require Pod::Select; - -##--------------------------------------------------------------------------- - -##--------------------------------- -## Function definitions begin here -##--------------------------------- - -sub pod2usage { - local($_) = shift; - my %opts; - ## Collect arguments - if (@_ > 0) { - ## Too many arguments - assume that this is a hash and - ## the user forgot to pass a reference to it. - %opts = ($_, @_); - } - elsif (!defined $_) { - $_ = ''; - } - elsif (ref $_) { - ## User passed a ref to a hash - %opts = %{$_} if (ref($_) eq 'HASH'); - } - elsif (/^[-+]?\d+$/) { - ## User passed in the exit value to use - $opts{'-exitval'} = $_; - } - else { - ## User passed in a message to print before issuing usage. - $_ and $opts{'-message'} = $_; - } - - ## Need this for backward compatibility since we formerly used - ## options that were all uppercase words rather than ones that - ## looked like Unix command-line options. - ## to be uppercase keywords) - %opts = map { - my ($key, $val) = ($_, $opts{$_}); - $key =~ s/^(?=\w)/-/; - $key =~ /^-msg/i and $key = '-message'; - $key =~ /^-exit/i and $key = '-exitval'; - lc($key) => $val; - } (keys %opts); - - ## Now determine default -exitval and -verbose values to use - if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { - $opts{'-exitval'} = 2; - $opts{'-verbose'} = 0; - } - elsif (! defined $opts{'-exitval'}) { - $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; - } - elsif (! defined $opts{'-verbose'}) { - $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || - $opts{'-exitval'} < 2); - } - - ## Default the output file - $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || - $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR - unless (defined $opts{'-output'}); - ## Default the input file - $opts{'-input'} = $0 unless (defined $opts{'-input'}); - - ## Look up input file in path if it doesnt exist. - unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { - my $basename = $opts{'-input'}; - my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' - : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); - my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; - - my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); - for my $dirname (@paths) { - $_ = File::Spec->catfile($dirname, $basename) if length; - last if (-e $_) && ($opts{'-input'} = $_); - } - } - - ## Now create a pod reader and constrain it to the desired sections. - my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); - if ($opts{'-verbose'} == 0) { - $parser->select('(?:SYNOPSIS|USAGE)\s*'); - } - elsif ($opts{'-verbose'} == 1) { - my $opt_re = '(?i)' . - '(?:OPTIONS|ARGUMENTS)' . - '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; - $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); - } - elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { - $parser->select('.*'); - } - elsif ($opts{'-verbose'} == 99) { - my $sections = $opts{'-sections'}; - $parser->select( (ref $sections) ? @$sections : $sections ); - $opts{'-verbose'} = 1; - } - - ## Now translate the pod document and then exit with the desired status - if ( !$opts{'-noperldoc'} - and $opts{'-verbose'} >= 2 - and !ref($opts{'-input'}) - and $opts{'-output'} == \*STDOUT ) - { - ## spit out the entire PODs. Might as well invoke perldoc - my $progpath = File::Spec->catfile($Config{scriptdirexp} - || $Config{scriptdir}, 'perldoc'); - print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); - if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { - # the perldocs back to 5.005 should all have -F - # without -F there are warnings in -T scripts - system($progpath, '-F', $1); - if($?) { - # RT16091: fall back to more if perldoc failed - system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); - } - } else { - croak "Unspecified input file or insecure argument.\n"; - } - } - else { - $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); - } - - exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); -} - -##--------------------------------------------------------------------------- - -##------------------------------- -## Method definitions begin here -##------------------------------- - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - if ($self->can('initialize')) { - $self->initialize(); - } else { - # pass through options to Pod::Text - my %opts; - for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) { - my $val = $params{USAGE_OPTIONS}{"-$_"}; - $opts{$_} = $val if defined $val; - } - $self = $self->SUPER::new(%opts); - %$self = (%$self, %params); - } - return $self; -} - -sub select { - my ($self, @sections) = @_; - if ($ISA[0]->can('select')) { - $self->SUPER::select(@sections); - } else { - # we're using Pod::Simple - need to mimic the behavior of Pod::Select - my $add = ($sections[0] eq '+') ? shift(@sections) : ''; - ## Reset the set of sections to use - unless (@sections) { - delete $self->{USAGE_SELECT} unless ($add); - return; - } - $self->{USAGE_SELECT} = [] - unless ($add && $self->{USAGE_SELECT}); - my $sref = $self->{USAGE_SELECT}; - ## Compile each spec - for my $spec (@sections) { - my $cs = Pod::Select::_compile_section_spec($spec); - if ( defined $cs ) { - ## Store them in our sections array - push(@$sref, $cs); - } else { - carp qq{Ignoring section spec "$spec"!\n}; - } - } - } -} - -# Override Pod::Text->seq_i to return just "arg", not "*arg*". -sub seq_i { return $_[1] } - -# This overrides the Pod::Text method to do something very akin to what -# Pod::Select did as well as the work done below by preprocess_paragraph. -# Note that the below is very, very specific to Pod::Text. -sub _handle_element_end { - my ($self, $element) = @_; - if ($element eq 'head1') { - $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; - if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { - $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; - } - } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 - my $idx = $1 - 1; - $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); - $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; - } - if ($element =~ /^head\d+$/) { - $$self{USAGE_SKIPPING} = 1; - if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { - $$self{USAGE_SKIPPING} = 0; - } else { - my @headings = @{$$self{USAGE_HEADINGS}}; - for my $section_spec ( @{$$self{USAGE_SELECT}} ) { - my $match = 1; - for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) { - $headings[$i] = '' unless defined $headings[$i]; - my $regex = $section_spec->[$i]; - my $negated = ($regex =~ s/^\!//); - $match &= ($negated ? ($headings[$i] !~ /${regex}/) - : ($headings[$i] =~ /${regex}/)); - last unless ($match); - } # end heading levels - if ($match) { - $$self{USAGE_SKIPPING} = 0; - last; - } - } # end sections - } - - # Try to do some lowercasing instead of all-caps in headings, and use - # a colon to end all headings. - if($self->{USAGE_OPTIONS}->{-verbose} < 2) { - local $_ = $$self{PENDING}[-1][1]; - s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; - s/\s*$/:/ unless (/:\s*$/); - $_ .= "\n"; - $$self{PENDING}[-1][1] = $_; - } - } - if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { - pop @{ $$self{PENDING} }; - } else { - $self->SUPER::_handle_element_end($element); - } -} - -# required for Pod::Simple API -sub start_document { - my $self = shift; - $self->SUPER::start_document(); - my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; - my $out_fh = $self->output_fh(); - print $out_fh "$msg\n"; -} - -# required for old Pod::Parser API -sub begin_pod { - my $self = shift; - $self->SUPER::begin_pod(); ## Have to call superclass - my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; - my $out_fh = $self->output_handle(); - print $out_fh "$msg\n"; -} - -sub preprocess_paragraph { - my $self = shift; - local $_ = shift; - my $line = shift; - ## See if this is a heading and we arent printing the entire manpage. - if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { - ## Change the title of the SYNOPSIS section to USAGE - s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; - ## Try to do some lowercasing instead of all-caps in headings - s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; - ## Use a colon to end all headings - s/\s*$/:/ unless (/:\s*$/); - $_ .= "\n"; - } - return $self->SUPER::preprocess_paragraph($_); -} - -1; # keep require happy diff --git a/cpan/Pod-Parser/scripts/pod2usage.PL b/cpan/Pod-Parser/scripts/pod2usage.PL deleted file mode 100644 index b9e6c772c2..0000000000 --- a/cpan/Pod-Parser/scripts/pod2usage.PL +++ /dev/null @@ -1,180 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; -chdir(dirname($0)); -$file = basename($0, '.PL'); -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; - -############################################################################# -# pod2usage -- command to print usage messages from embedded pod docs -# -# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -use strict; -#use diagnostics; - -=head1 NAME - -pod2usage - print usage messages from embedded pod docs in files - -=head1 SYNOPSIS - -=over 12 - -=item B - -[B<-help>] -[B<-man>] -[B<-exit>S< >I] -[B<-output>S< >I] -[B<-verbose> I] -[B<-pathlist> I] -I - -=back - -=head1 OPTIONS AND ARGUMENTS - -=over 8 - -=item B<-help> - -Print a brief help message and exit. - -=item B<-man> - -Print this command's manual page and exit. - -=item B<-exit> I - -The exit status value to return. - -=item B<-output> I - -The output file to print to. If the special names "-" or ">&1" or ">&STDOUT" -are used then standard output is used. If ">&2" or ">&STDERR" is used then -standard error is used. - -=item B<-verbose> I - -The desired level of verbosity to use: - - 1 : print SYNOPSIS only - 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections - 3 : print the entire manpage (similar to running pod2text) - -=item B<-pathlist> I - -Specifies one or more directories to search for the input file if it -was not supplied with an absolute path. Each directory path in the given -list should be separated by a ':' on Unix (';' on MSWin32 and DOS). - -=item I - -The pathname of a file containing pod documentation to be output in -usage message format (defaults to standard input). - -=back - -=head1 DESCRIPTION - -B will read the given input file looking for pod -documentation and will print the corresponding usage message. -If no input file is specified then standard input is read. - -B invokes the B function in the B -module. Please see L. - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=cut - -use Pod::Usage; -use Getopt::Long; - -## Define options -my %options = (); -my @opt_specs = ( - 'help', - 'man', - 'exit=i', - 'output=s', - 'pathlist=s', - 'verbose=i', -); - -## Parse options -GetOptions(\%options, @opt_specs) || pod2usage(2); -pod2usage(1) if ($options{help}); -pod2usage(VERBOSE => 2) if ($options{man}); - -## Dont default to STDIN if connected to a terminal -pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); - -@ARGV = ('-') unless (@ARGV); -if (@ARGV > 1) { - print STDERR "pod2usage: Too many filenames given\n\n"; - pod2usage(2); -} - -my %usage = (); -$usage{-input} = shift(@ARGV); -$usage{-exitval} = $options{'exit'} if (defined $options{'exit'}); -$usage{-output} = $options{'output'} if (defined $options{'output'}); -$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'}); -$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'}); - -pod2usage(\%usage); - - -!NO!SUBS! - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; diff --git a/cpan/Pod-Parser/scripts/podchecker.PL b/cpan/Pod-Parser/scripts/podchecker.PL deleted file mode 100644 index 75c316d26e..0000000000 --- a/cpan/Pod-Parser/scripts/podchecker.PL +++ /dev/null @@ -1,186 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2' or $^O eq 'dos'); # "case-forgiving" -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; -############################################################################# -# podchecker -- command to invoke the podchecker function in Pod::Checker -# -# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -use strict; -#use diagnostics; - -=head1 NAME - -podchecker - check the syntax of POD format documentation files - -=head1 SYNOPSIS - -B [B<-help>] [B<-man>] [B<-(no)warnings>] [IS< >...] - -=head1 OPTIONS AND ARGUMENTS - -=over 8 - -=item B<-help> - -Print a brief help message and exit. - -=item B<-man> - -Print the manual page and exit. - -=item B<-warnings> B<-nowarnings> - -Turn on/off printing of warnings. Repeating B<-warnings> increases the -warning level, i.e. more warnings are printed. Currently increasing to -level two causes flagging of unescaped "E,E" characters. - -=item I - -The pathname of a POD file to syntax-check (defaults to standard input). - -=back - -=head1 DESCRIPTION - -B will read the given input files looking for POD -syntax errors in the POD documentation and will print any errors -it find to STDERR. At the end, it will print a status message -indicating the number of errors found. - -Directories are ignored, an appropriate warning message is printed. - -B invokes the B function exported by B -Please see L for more details. - -=head1 RETURN VALUE - -B returns a 0 (zero) exit status if all specified -POD files are ok. - -=head1 ERRORS - -B returns the exit status 1 if at least one of -the given POD files has syntax errors. - -The status 2 indicates that at least one of the specified -files does not contain I POD commands. - -Status 1 overrides status 2. If you want unambiguous -results, call B with one single argument only. - -=head1 SEE ALSO - -L and L - -=head1 AUTHORS - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE, -Marek Rouchal Emarekr@cpan.orgE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=cut - - -use Pod::Checker; -use Pod::Usage; -use Getopt::Long; - -## Define options -my %options; - -## Parse options -GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2); -pod2usage(1) if ($options{help}); -pod2usage(-verbose => 2) if ($options{man}); - -if($options{nowarnings}) { - $options{warnings} = 0; -} -elsif(!defined $options{warnings}) { - $options{warnings} = 1; # default is warnings on -} - -## Dont default to STDIN if connected to a terminal -pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); - -## Invoke podchecker() -my $status = 0; -@ARGV = qw(-) unless(@ARGV); -for my $podfile (@ARGV) { - if($podfile eq '-') { - $podfile = '<&STDIN'; - } - elsif(-d $podfile) { - warn "podchecker: Warning: Ignoring directory '$podfile'\n"; - next; - } - my $errors = - podchecker($podfile, undef, '-warnings' => $options{warnings}); - if($errors > 0) { - # errors occurred - $status = 1; - printf STDERR ("%s has %d pod syntax %s.\n", - $podfile, $errors, - ($errors == 1) ? 'error' : 'errors'); - } - elsif($errors < 0) { - # no pod found - $status = 2 unless($status); - print STDERR "$podfile does not contain any pod commands.\n"; - } - else { - print STDERR "$podfile pod syntax OK.\n"; - } -} -exit $status; - -!NO!SUBS! - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; diff --git a/cpan/Pod-Parser/scripts/podselect.PL b/cpan/Pod-Parser/scripts/podselect.PL index 7fadd7366c..16e2d985be 100644 --- a/cpan/Pod-Parser/scripts/podselect.PL +++ b/cpan/Pod-Parser/scripts/podselect.PL @@ -1,143 +1,143 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; -chdir(dirname($0)); -$file = basename($0, '.PL'); -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; - -############################################################################# -# podselect -- command to invoke the podselect function in Pod::Select -# -# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -use strict; -#use diagnostics; - -=head1 NAME - -podselect - print selected sections of pod documentation on standard output - -=head1 SYNOPSIS - -B [B<-help>] [B<-man>] [B<-section>S< >I] -[IS< >...] - -=head1 OPTIONS AND ARGUMENTS - -=over 8 - -=item B<-help> - -Print a brief help message and exit. - -=item B<-man> - -Print the manual page and exit. - -=item B<-section>S< >I - -Specify a section to include in the output. -See L -for the format to use for I. -This option may be given multiple times on the command line. - -=item I - -The pathname of a file from which to select sections of pod -documentation (defaults to standard input). - -=back - -=head1 DESCRIPTION - -B will read the given input files looking for pod -documentation and will print out (in raw pod format) all sections that -match one ore more of the given section specifications. If no section -specifications are given than all pod sections encountered are output. - -B invokes the B function exported by B -Please see L for more details. - -=head1 SEE ALSO - -L and L - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=cut - -use Pod::Select; -use Pod::Usage; -use Getopt::Long; - -## Define options -my %options = ( - 'help' => 0, - 'man' => 0, - 'sections' => [], -); - -## Parse options -GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2); -pod2usage(1) if ($options{help}); -pod2usage(-verbose => 2) if ($options{man}); - -## Dont default to STDIN if connected to a terminal -pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); - -## Invoke podselect(). -if (@{ $options{'sections'} } > 0) { - podselect({ -sections => $options{'sections'} }, @ARGV); -} -else { - podselect(@ARGV); -} - - -!NO!SUBS! - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir(dirname($0)); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +############################################################################# +# podselect -- command to invoke the podselect function in Pod::Select +# +# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +use strict; +#use diagnostics; + +=head1 NAME + +podselect - print selected sections of pod documentation on standard output + +=head1 SYNOPSIS + +B [B<-help>] [B<-man>] [B<-section>S< >I] +[IS< >...] + +=head1 OPTIONS AND ARGUMENTS + +=over 8 + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print the manual page and exit. + +=item B<-section>S< >I + +Specify a section to include in the output. +See L +for the format to use for I. +This option may be given multiple times on the command line. + +=item I + +The pathname of a file from which to select sections of pod +documentation (defaults to standard input). + +=back + +=head1 DESCRIPTION + +B will read the given input files looking for pod +documentation and will print out (in raw pod format) all sections that +match one ore more of the given section specifications. If no section +specifications are given than all pod sections encountered are output. + +B invokes the B function exported by B +Please see L for more details. + +=head1 SEE ALSO + +L and L + +=head1 AUTHOR + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +=cut + +use Pod::Select; +use Pod::Usage; +use Getopt::Long; + +## Define options +my %options = ( + 'help' => 0, + 'man' => 0, + 'sections' => [], +); + +## Parse options +GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2); +pod2usage(1) if ($options{help}); +pod2usage(-verbose => 2) if ($options{man}); + +## Dont default to STDIN if connected to a terminal +pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); + +## Invoke podselect(). +if (@{ $options{'sections'} } > 0) { + podselect({ -sections => $options{'sections'} }, @ARGV); +} +else { + podselect(@ARGV); +} + + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/cpan/Pod-Parser/t/pod/contains_bad_pod.xr b/cpan/Pod-Parser/t/pod/contains_bad_pod.xr index ad65663e22..c7907963d9 100644 --- a/cpan/Pod-Parser/t/pod/contains_bad_pod.xr +++ b/cpan/Pod-Parser/t/pod/contains_bad_pod.xr @@ -1,5 +1,5 @@ -=head foo - -bar baz. - -=cut +=head foo + +bar baz. + +=cut diff --git a/cpan/Pod-Parser/t/pod/contains_pod.t b/cpan/Pod-Parser/t/pod/contains_pod.t index 6326e72eb3..96cdb95bb1 100644 --- a/cpan/Pod-Parser/t/pod/contains_pod.t +++ b/cpan/Pod-Parser/t/pod/contains_pod.t @@ -1,19 +1,19 @@ -#!/usr/bin/env perl - -# Copyright (C) 2005 Joshua Hoblitt -# -# $Id$ - -use strict; - -use Test::More tests => 2; - -use Pod::Find qw( contains_pod ); - -{ - ok(contains_pod('t/pod/contains_pod.xr'), "contains pod"); -} - -{ - ok(contains_pod('t/pod/contains_bad_pod.xr'), "contains bad pod"); -} +#!/usr/bin/env perl + +# Copyright (C) 2005 Joshua Hoblitt +# +# $Id$ + +use strict; + +use Test::More tests => 2; + +use Pod::Find qw( contains_pod ); + +{ + ok(contains_pod('t/pod/contains_pod.xr'), "contains pod"); +} + +{ + ok(contains_pod('t/pod/contains_bad_pod.xr'), "contains bad pod"); +} diff --git a/cpan/Pod-Parser/t/pod/contains_pod.xr b/cpan/Pod-Parser/t/pod/contains_pod.xr index 7ea408de46..b79591a95c 100644 --- a/cpan/Pod-Parser/t/pod/contains_pod.xr +++ b/cpan/Pod-Parser/t/pod/contains_pod.xr @@ -1,5 +1,5 @@ -=head1 foo - -bar baz. - -=cut +=head1 foo + +bar baz. + +=cut diff --git a/cpan/Pod-Parser/t/pod/emptycmd.t b/cpan/Pod-Parser/t/pod/emptycmd.t index 59e395ea04..53d1046345 100644 --- a/cpan/Pod-Parser/t/pod/emptycmd.t +++ b/cpan/Pod-Parser/t/pod/emptycmd.t @@ -1,21 +1,21 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - -__END__ - -=pod - -= this is a test -of the emergency -broadcast system - -=cut +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + +__END__ + +=pod + += this is a test +of the emergency +broadcast system + +=cut diff --git a/cpan/Pod-Parser/t/pod/emptycmd.xr b/cpan/Pod-Parser/t/pod/emptycmd.xr index f06d2dbb09..dd474a1a44 100644 --- a/cpan/Pod-Parser/t/pod/emptycmd.xr +++ b/cpan/Pod-Parser/t/pod/emptycmd.xr @@ -1,2 +1,2 @@ - = this is a test of the emergency broadcast system - + = this is a test of the emergency broadcast system + diff --git a/cpan/Pod-Parser/t/pod/find.t b/cpan/Pod-Parser/t/pod/find.t index 27d48953dc..7cfd7ae613 100644 --- a/cpan/Pod-Parser/t/pod/find.t +++ b/cpan/Pod-Parser/t/pod/find.t @@ -1,103 +1,101 @@ -# Testing of Pod::Find -# Author: Marek Rouchal - -$| = 1; - -BEGIN { - if ($^O eq 'VMS') { - print "1..0 # needs upstream patch from https://rt.cpan.org/Ticket/Display.html?id=55121"; - exit 0; - } -} - -use strict; -use Test::More tests => 4; - -BEGIN { - # 1. load successful - use_ok('Pod::Find', qw(pod_find pod_where)); -} - -use File::Spec; - -require Cwd; -my $THISDIR = Cwd::cwd(); -my $VERBOSE = $ENV{PERL_CORE} ? 0 : ($ENV{TEST_VERBOSE} || 0); -my $lib_dir = File::Spec->catdir($THISDIR,'lib'); - -if ($^O eq 'VMS') { - $lib_dir = VMS::Filespec::unixify($lib_dir); -} - -print "### 2. searching $lib_dir\n"; -my %pods = pod_find($lib_dir); -my @results = values %pods; -print "### found @results\n"; -my @compare = qw( - Pod::Checker - Pod::Find - Pod::InputObjects - Pod::ParseUtils - Pod::Parser - Pod::PlainText - Pod::Select - Pod::Usage -); -if (File::Spec->case_tolerant || $^O eq 'dos') { - # must downcase before sorting - map {$_ = lc $_} @compare; - map {$_ = lc $_} @results; -} -my $compare = join(',', sort @compare); -my $result = join(',', sort @results); -is($result, $compare); - -print "### 3. searching for File::Find\n"; -$result = pod_where({ -inc => 1, -verbose => $VERBOSE }, 'File::Find') - || 'undef - pod not found!'; -print "### found $result\n"; - -require Config; -$compare = $ENV{PERL_CORE} ? - File::Spec->catfile(File::Spec->updir, File::Spec->updir, 'lib','File','Find.pm') - : File::Spec->catfile($Config::Config{privlibexp},"File","Find.pm"); -my $resfile = _canon($result); -my $cmpfile = _canon($compare); -if($^O =~ /dos|win32/i && $resfile =~ /~\d(?=\\|$)/) { - # we have ~1 short filenames - $resfile = quotemeta($resfile); - $resfile =~ s/\\~\d(?=\\|$)/[^\\\\]+/g; - ok($cmpfile =~ /^$resfile$/, "pod_where found File::Find (with long filename matching)") || - diag("'$cmpfile' does not match /^$resfile\$/"); -} else { - is($resfile,$cmpfile,"pod_where found File::Find"); -} - -# Search for a documentation pod rather than a module -my $searchpod = 'Stuff'; -print "### 4. searching for $searchpod.pod\n"; -$result = pod_where( - { -dirs => [ File::Spec->catdir( qw(t), 'pod', 'testpods', 'lib', 'Pod') ], - -verbose => $VERBOSE }, $searchpod) - || "undef - $searchpod.pod not found!"; -print "### found $result\n"; - -$compare = File::Spec->catfile( - qw(t), 'pod', 'testpods', 'lib', 'Pod' ,'Stuff.pm'); -is(_canon($result),_canon($compare)); - - -# make the path as generic as possible -sub _canon -{ - my ($path) = @_; - $path = File::Spec->canonpath($path); - my @comp = File::Spec->splitpath($path); - my @dir = File::Spec->splitdir($comp[1]); - $comp[1] = File::Spec->catdir(@dir); - $path = File::Spec->catpath(@comp); - $path = uc($path) if File::Spec->case_tolerant; - print "### general path: $path\n" if $VERBOSE; - $path; -} - +# Testing of Pod::Find +# Author: Marek Rouchal + +$| = 1; + +BEGIN { + if ($^O eq 'VMS') { + print "1..0 # needs upstream patch from https://rt.cpan.org/Ticket/Display.html?id=55121"; + exit 0; + } +} + +use strict; +use Test::More tests => 4; + +BEGIN { + # 1. load successful + use_ok('Pod::Find', qw(pod_find pod_where)); +} + +use File::Spec; + +require Cwd; +my $THISDIR = Cwd::cwd(); +my $VERBOSE = $ENV{PERL_CORE} ? 0 : ($ENV{TEST_VERBOSE} || 0); +my $lib_dir = File::Spec->catdir($THISDIR,'lib'); + +if ($^O eq 'VMS') { + $lib_dir = VMS::Filespec::unixify($lib_dir); +} + +print "### 2. searching $lib_dir\n"; +my %pods = pod_find($lib_dir); +my @results = values %pods; +print "### found @results\n"; +my @compare = qw( + Pod::Find + Pod::InputObjects + Pod::ParseUtils + Pod::Parser + Pod::PlainText + Pod::Select +); +if (File::Spec->case_tolerant || $^O eq 'dos') { + # must downcase before sorting + map {$_ = lc $_} @compare; + map {$_ = lc $_} @results; +} +my $compare = join(',', sort @compare); +my $result = join(',', sort @results); +is($result, $compare); + +print "### 3. searching for File::Find\n"; +$result = pod_where({ -inc => 1, -verbose => $VERBOSE }, 'File::Find') + || 'undef - pod not found!'; +print "### found $result\n"; + +require Config; +$compare = $ENV{PERL_CORE} ? + File::Spec->catfile(File::Spec->updir, File::Spec->updir, 'lib','File','Find.pm') + : File::Spec->catfile($Config::Config{privlibexp},"File","Find.pm"); +my $resfile = _canon($result); +my $cmpfile = _canon($compare); +if($^O =~ /dos|win32/i && $resfile =~ /~\d(?=\\|$)/) { + # we have ~1 short filenames + $resfile = quotemeta($resfile); + $resfile =~ s/\\~\d(?=\\|$)/[^\\\\]+/g; + ok($cmpfile =~ /^$resfile$/, "pod_where found File::Find (with long filename matching)") || + diag("'$cmpfile' does not match /^$resfile\$/"); +} else { + is($resfile,$cmpfile,"pod_where found File::Find"); +} + +# Search for a documentation pod rather than a module +my $searchpod = 'Stuff'; +print "### 4. searching for $searchpod.pod\n"; +$result = pod_where( + { -dirs => [ File::Spec->catdir( qw(t), 'pod', 'testpods', 'lib', 'Pod') ], + -verbose => $VERBOSE }, $searchpod) + || "undef - $searchpod.pod not found!"; +print "### found $result\n"; + +$compare = File::Spec->catfile( + qw(t), 'pod', 'testpods', 'lib', 'Pod' ,'Stuff.pm'); +is(_canon($result),_canon($compare)); + + +# make the path as generic as possible +sub _canon +{ + my ($path) = @_; + $path = File::Spec->canonpath($path); + my @comp = File::Spec->splitpath($path); + my @dir = File::Spec->splitdir($comp[1]); + $comp[1] = File::Spec->catdir(@dir); + $path = File::Spec->catpath(@comp); + $path = uc($path) if File::Spec->case_tolerant; + print "### general path: $path\n" if $VERBOSE; + $path; +} + diff --git a/cpan/Pod-Parser/t/pod/for.t b/cpan/Pod-Parser/t/pod/for.t index 44af44f17d..12ba3392c0 100644 --- a/cpan/Pod-Parser/t/pod/for.t +++ b/cpan/Pod-Parser/t/pod/for.t @@ -1,59 +1,59 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -This is a test - -=for theloveofpete -You shouldn't see this -or this -or this - -=for text -pod2text should see this -and this -and this - -and everything should see this! - -=begin text - -Similarly, this line ... - -and this one ... - -as well this one, - -should all be in pod2text output - -=end text - -Tweedley-deedley-dee, Im as happy as can be! -Tweedley-deedley-dum, cuz youre my honey sugar plum! - -=begin atthebeginning - -But I expect to see neither hide ... - -nor tail ... - -of this text - -=end atthebeginning - -The rest of this should show up in everything. - +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This is a test + +=for theloveofpete +You shouldn't see this +or this +or this + +=for text +pod2text should see this +and this +and this + +and everything should see this! + +=begin text + +Similarly, this line ... + +and this one ... + +as well this one, + +should all be in pod2text output + +=end text + +Tweedley-deedley-dee, Im as happy as can be! +Tweedley-deedley-dum, cuz youre my honey sugar plum! + +=begin atthebeginning + +But I expect to see neither hide ... + +nor tail ... + +of this text + +=end atthebeginning + +The rest of this should show up in everything. + diff --git a/cpan/Pod-Parser/t/pod/for.xr b/cpan/Pod-Parser/t/pod/for.xr index 5f6b8b2ce8..b616bf2cb2 100644 --- a/cpan/Pod-Parser/t/pod/for.xr +++ b/cpan/Pod-Parser/t/pod/for.xr @@ -1,21 +1,21 @@ - This is a test - - pod2text should see this - and this - and this - - and everything should see this! - -Similarly, this line ... - -and this one ... - -as well this one, - -should all be in pod2text output - - Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley-dum, cuz - youre my honey sugar plum! - - The rest of this should show up in everything. - + This is a test + + pod2text should see this + and this + and this + + and everything should see this! + +Similarly, this line ... + +and this one ... + +as well this one, + +should all be in pod2text output + + Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley-dum, cuz + youre my honey sugar plum! + + The rest of this should show up in everything. + diff --git a/cpan/Pod-Parser/t/pod/headings.t b/cpan/Pod-Parser/t/pod/headings.t index 78608d0fd9..4688272231 100644 --- a/cpan/Pod-Parser/t/pod/headings.t +++ b/cpan/Pod-Parser/t/pod/headings.t @@ -1,140 +1,140 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -################################################################# - use Pod::Usage; - pod2usage( VERBOSE => 2, EXIT => 1 ); - -=pod - -=head1 NAME - -B - insert an rdb table into a PostgreSQL database - -=head1 SYNOPSIS - -B [I=I ...] - -=head1 PARAMETERS - -B uses an IRAF-compatible parameter interface. -A template parameter file is in F. - -=over 4 - -=item B I - -The B file to insert into the database. If the given name -is the string C, it reads from the UNIX standard input stream. - - -=back - -=head1 DESCRIPTION - -B will enter the data from an B database into a -PostgreSQL database table, optionally creating the database and the -table if they do not exist. It automatically determines the -PostgreSQL data type from the column definition in the B file, -but may be overriden via a series of definition files or directly -via one of its parameters. - -The target database and table are specified by the C and C -parameters. If they do not exist, and the C parameter is -set, they will be created. Table field definitions are determined -in the following order: - -=cut - -################################################################# - -results in: - - -################################################################# - - rdb2pg - insert an rdb table into a PostgreSQL database - - rdb2pg [*param*=*value* ...] - - rdb2pg uses an IRAF-compatible parameter interface. A template - parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - The RDB file to insert into the database. If the given name is - the string `stdin', it reads from the UNIX standard input - stream. - - rdb2pg will enter the data from an RDB database into a - PostgreSQL database table, optionally creating the database and - the table if they do not exist. It automatically determines the - PostgreSQL data type from the column definition in the RDB file, - but may be overriden via a series of definition files or - directly via one of its parameters. - - The target database and table are specified by the `db' and - `table' parameters. If they do not exist, and the `createdb' - parameter is set, they will be created. Table field definitions - are determined in the following order: - - -################################################################# - -while the original version of Text (using pod2text) gives - -################################################################# - -NAME - rdb2pg - insert an rdb table into a PostgreSQL database - -SYNOPSIS - rdb2pg [*param*=*value* ...] - -PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template - parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - input *file* - The RDB file to insert into the database. If the given name - is the string `stdin', it reads from the UNIX standard input - stream. - -DESCRIPTION - rdb2pg will enter the data from an RDB database into a - PostgreSQL database table, optionally creating the database and - the table if they do not exist. It automatically determines the - PostgreSQL data type from the column definition in the RDB file, - but may be overriden via a series of definition files or - directly via one of its parameters. - - The target database and table are specified by the `db' and - `table' parameters. If they do not exist, and the `createdb' - parameter is set, they will be created. Table field definitions - are determined in the following order: - - -################################################################# - - -Thanks for any help. If, as your email indicates, you've not much -time to look at this, I can work around things by calling pod2text() -directly using the official Text.pm. - -Diab - -------------- -Diab Jerius -djerius@cfa.harvard.edu - +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +################################################################# + use Pod::Usage; + pod2usage( VERBOSE => 2, EXIT => 1 ); + +=pod + +=head1 NAME + +B - insert an rdb table into a PostgreSQL database + +=head1 SYNOPSIS + +B [I=I ...] + +=head1 PARAMETERS + +B uses an IRAF-compatible parameter interface. +A template parameter file is in F. + +=over 4 + +=item B I + +The B file to insert into the database. If the given name +is the string C, it reads from the UNIX standard input stream. + + +=back + +=head1 DESCRIPTION + +B will enter the data from an B database into a +PostgreSQL database table, optionally creating the database and the +table if they do not exist. It automatically determines the +PostgreSQL data type from the column definition in the B file, +but may be overriden via a series of definition files or directly +via one of its parameters. + +The target database and table are specified by the C and C
          +parameters. If they do not exist, and the C parameter is +set, they will be created. Table field definitions are determined +in the following order: + +=cut + +################################################################# + +results in: + + +################################################################# + + rdb2pg - insert an rdb table into a PostgreSQL database + + rdb2pg [*param*=*value* ...] + + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + The RDB file to insert into the database. If the given name is + the string `stdin', it reads from the UNIX standard input + stream. + + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + + +################################################################# + +while the original version of Text (using pod2text) gives + +################################################################# + +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name + is the string `stdin', it reads from the UNIX standard input + stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + + +################################################################# + + +Thanks for any help. If, as your email indicates, you've not much +time to look at this, I can work around things by calling pod2text() +directly using the official Text.pm. + +Diab + +------------- +Diab Jerius +djerius@cfa.harvard.edu + diff --git a/cpan/Pod-Parser/t/pod/headings.xr b/cpan/Pod-Parser/t/pod/headings.xr index fb37a2b0cf..f92efb5ecf 100644 --- a/cpan/Pod-Parser/t/pod/headings.xr +++ b/cpan/Pod-Parser/t/pod/headings.xr @@ -1,26 +1,26 @@ -NAME - rdb2pg - insert an rdb table into a PostgreSQL database - -SYNOPSIS - rdb2pg [*param*=*value* ...] - -PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template parameter - file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - input *file* - The RDB file to insert into the database. If the given name is the - string `stdin', it reads from the UNIX standard input stream. - -DESCRIPTION - rdb2pg will enter the data from an RDB database into a PostgreSQL - database table, optionally creating the database and the table if they - do not exist. It automatically determines the PostgreSQL data type from - the column definition in the RDB file, but may be overriden via a series - of definition files or directly via one of its parameters. - - The target database and table are specified by the `db' and `table' - parameters. If they do not exist, and the `createdb' parameter is set, - they will be created. Table field definitions are determined in the - following order: - +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template parameter + file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name is the + string `stdin', it reads from the UNIX standard input stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a PostgreSQL + database table, optionally creating the database and the table if they + do not exist. It automatically determines the PostgreSQL data type from + the column definition in the RDB file, but may be overriden via a series + of definition files or directly via one of its parameters. + + The target database and table are specified by the `db' and `table' + parameters. If they do not exist, and the `createdb' parameter is set, + they will be created. Table field definitions are determined in the + following order: + diff --git a/cpan/Pod-Parser/t/pod/include.t b/cpan/Pod-Parser/t/pod/include.t index 4e73b78356..9edb47864c 100644 --- a/cpan/Pod-Parser/t/pod/include.t +++ b/cpan/Pod-Parser/t/pod/include.t @@ -1,36 +1,36 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -This file tries to demonstrate a simple =include directive -for pods. It is used as follows: - - =include filename - -where "filename" is expected to be an absolute pathname, or else -reside be relative to the directory in which the current processed -podfile resides, or be relative to the current directory. - -Lets try it out with the file "included.t" shall we. - -***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** - -=include included.t - -***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** - -So how did we do??? +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This file tries to demonstrate a simple =include directive +for pods. It is used as follows: + + =include filename + +where "filename" is expected to be an absolute pathname, or else +reside be relative to the directory in which the current processed +podfile resides, or be relative to the current directory. + +Lets try it out with the file "included.t" shall we. + +***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** + +=include included.t + +***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** + +So how did we do??? diff --git a/cpan/Pod-Parser/t/pod/include.xr b/cpan/Pod-Parser/t/pod/include.xr index 624ee44447..187653b741 100644 --- a/cpan/Pod-Parser/t/pod/include.xr +++ b/cpan/Pod-Parser/t/pod/include.xr @@ -1,22 +1,22 @@ - This file tries to demonstrate a simple =include directive for pods. It - is used as follows: - - =include filename - - where "filename" is expected to be an absolute pathname, or else reside - be relative to the directory in which the current processed podfile - resides, or be relative to the current directory. - - Lets try it out with the file "included.t" shall we. - - ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** - -###### begin =include included.t ##### - This is the text of the included file named "included.t". It should - appear in the final pod document from pod2xxx - -###### end =include included.t ##### - ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** - - So how did we do??? - + This file tries to demonstrate a simple =include directive for pods. It + is used as follows: + + =include filename + + where "filename" is expected to be an absolute pathname, or else reside + be relative to the directory in which the current processed podfile + resides, or be relative to the current directory. + + Lets try it out with the file "included.t" shall we. + + ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** + +###### begin =include included.t ##### + This is the text of the included file named "included.t". It should + appear in the final pod document from pod2xxx + +###### end =include included.t ##### + ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** + + So how did we do??? + diff --git a/cpan/Pod-Parser/t/pod/included.t b/cpan/Pod-Parser/t/pod/included.t index 4f171c454b..d6e4a50431 100644 --- a/cpan/Pod-Parser/t/pod/included.t +++ b/cpan/Pod-Parser/t/pod/included.t @@ -1,35 +1,35 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -##------------------------------------------------------------ -# This file is =included by "include.t" -# -# This text should NOT be in the resultant pod document -# because we havent seen an =xxx pod directive in this file! -##------------------------------------------------------------ - -=pod - -This is the text of the included file named "included.t". -It should appear in the final pod document from pod2xxx - -=cut - -##------------------------------------------------------------ -# This text should NOT be in the resultant pod document -# because it is *after* an =cut an no other pod directives -# proceed it! -##------------------------------------------------------------ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +##------------------------------------------------------------ +# This file is =included by "include.t" +# +# This text should NOT be in the resultant pod document +# because we havent seen an =xxx pod directive in this file! +##------------------------------------------------------------ + +=pod + +This is the text of the included file named "included.t". +It should appear in the final pod document from pod2xxx + +=cut + +##------------------------------------------------------------ +# This text should NOT be in the resultant pod document +# because it is *after* an =cut an no other pod directives +# proceed it! +##------------------------------------------------------------ diff --git a/cpan/Pod-Parser/t/pod/included.xr b/cpan/Pod-Parser/t/pod/included.xr index 54142fa0d3..16a65cd358 100644 --- a/cpan/Pod-Parser/t/pod/included.xr +++ b/cpan/Pod-Parser/t/pod/included.xr @@ -1,3 +1,3 @@ - This is the text of the included file named "included.t". It should - appear in the final pod document from pod2xxx - + This is the text of the included file named "included.t". It should + appear in the final pod document from pod2xxx + diff --git a/cpan/Pod-Parser/t/pod/lref.t b/cpan/Pod-Parser/t/pod/lref.t index 02e2c9e307..33a0a7ca9f 100644 --- a/cpan/Pod-Parser/t/pod/lref.t +++ b/cpan/Pod-Parser/t/pod/lref.t @@ -1,66 +1,66 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -Try out I of different ways of specifying references: - -Reference the L - -Reference the L - -Reference the L - -Reference the L - -Reference the L<"manpage/section"> - -Reference the L<"manpage"/section> - -Reference the L - -Reference the L - -Reference the L - -Now try it using the new "|" stuff ... - -Reference the L - -Reference the L - -Reference the L - -Reference the L - -Reference the L - -Reference the L - -Reference the L - -Reference the L - -Reference the L - +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +Try out I of different ways of specifying references: + +Reference the L + +Reference the L + +Reference the L + +Reference the L + +Reference the L<"manpage/section"> + +Reference the L<"manpage"/section> + +Reference the L + +Reference the L + +Reference the L + +Now try it using the new "|" stuff ... + +Reference the L + +Reference the L + +Reference the L + +Reference the L + +Reference the L + +Reference the L + +Reference the L + +Reference the L + +Reference the L + diff --git a/cpan/Pod-Parser/t/pod/lref.xr b/cpan/Pod-Parser/t/pod/lref.xr index 297053b1ac..c287cf5a6d 100644 --- a/cpan/Pod-Parser/t/pod/lref.xr +++ b/cpan/Pod-Parser/t/pod/lref.xr @@ -1,40 +1,40 @@ - Try out *LOTS* of different ways of specifying references: - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section on "manpage/section" - - Reference the the section entry in the "manpage" manpage - - Reference the the section on "section" in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Now try it using the new "|" stuff ... - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - + Try out *LOTS* of different ways of specifying references: + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section on "manpage/section" + + Reference the the section entry in the "manpage" manpage + + Reference the the section on "section" in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Now try it using the new "|" stuff ... + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + diff --git a/cpan/Pod-Parser/t/pod/multiline_items.t b/cpan/Pod-Parser/t/pod/multiline_items.t index 0fe410a4e6..98ad34222e 100644 --- a/cpan/Pod-Parser/t/pod/multiline_items.t +++ b/cpan/Pod-Parser/t/pod/multiline_items.t @@ -1,31 +1,31 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=head1 Test multiline item lists - -This is a test to ensure that multiline =item paragraphs -get indented appropriately. - -=over 4 - -=item This -is -a -test. - -=back - -=cut +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 Test multiline item lists + +This is a test to ensure that multiline =item paragraphs +get indented appropriately. + +=over 4 + +=item This +is +a +test. + +=back + +=cut diff --git a/cpan/Pod-Parser/t/pod/multiline_items.xr b/cpan/Pod-Parser/t/pod/multiline_items.xr index 9eea63a8f0..cda163b7f5 100644 --- a/cpan/Pod-Parser/t/pod/multiline_items.xr +++ b/cpan/Pod-Parser/t/pod/multiline_items.xr @@ -1,6 +1,6 @@ -Test multiline item lists - This is a test to ensure that multiline =item paragraphs get indented - appropriately. - - This is a test. - +Test multiline item lists + This is a test to ensure that multiline =item paragraphs get indented + appropriately. + + This is a test. + diff --git a/cpan/Pod-Parser/t/pod/nested_items.t b/cpan/Pod-Parser/t/pod/nested_items.t index c8e9b22427..f60a67f1ab 100644 --- a/cpan/Pod-Parser/t/pod/nested_items.t +++ b/cpan/Pod-Parser/t/pod/nested_items.t @@ -1,64 +1,64 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=head1 Test nested item lists - -This is a test to ensure the nested =item paragraphs -get indented appropriately. - -=over 2 - -=item 1 - -First section. - -=over 2 - -=item a - -this is item a - -=item b - -this is item b - -=back - -=item 2 - -Second section. - -=over 2 - -=item a - -this is item a - -=item b - -this is item b - -=item c - -=item d - -This is item c & d. - -=back - -=back - -=cut +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 Test nested item lists + +This is a test to ensure the nested =item paragraphs +get indented appropriately. + +=over 2 + +=item 1 + +First section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=back + +=item 2 + +Second section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=item c + +=item d + +This is item c & d. + +=back + +=back + +=cut diff --git a/cpan/Pod-Parser/t/pod/nested_items.xr b/cpan/Pod-Parser/t/pod/nested_items.xr index dd1adac127..30834e9ca6 100644 --- a/cpan/Pod-Parser/t/pod/nested_items.xr +++ b/cpan/Pod-Parser/t/pod/nested_items.xr @@ -1,19 +1,19 @@ -Test nested item lists - This is a test to ensure the nested =item paragraphs get indented - appropriately. - - 1 First section. - - a this is item a - - b this is item b - - 2 Second section. - - a this is item a - - b this is item b - - c - d This is item c & d. - +Test nested item lists + This is a test to ensure the nested =item paragraphs get indented + appropriately. + + 1 First section. + + a this is item a + + b this is item b + + 2 Second section. + + a this is item a + + b this is item b + + c + d This is item c & d. + diff --git a/cpan/Pod-Parser/t/pod/nested_seqs.t b/cpan/Pod-Parser/t/pod/nested_seqs.t index 8559f1f25f..6f7ae67e99 100644 --- a/cpan/Pod-Parser/t/pod/nested_seqs.t +++ b/cpan/Pod-Parser/t/pod/nested_seqs.t @@ -1,23 +1,23 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -The statement: C hour!> is a parody of a -quotation from Winston Churchill. - -=cut - +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +The statement: C hour!> is a parody of a +quotation from Winston Churchill. + +=cut + diff --git a/cpan/Pod-Parser/t/pod/nested_seqs.xr b/cpan/Pod-Parser/t/pod/nested_seqs.xr index f981061f94..4d2e09e499 100644 --- a/cpan/Pod-Parser/t/pod/nested_seqs.xr +++ b/cpan/Pod-Parser/t/pod/nested_seqs.xr @@ -1,3 +1,3 @@ - The statement: `This is dog kind's *finest* hour!' is a parody of a - quotation from Winston Churchill. - + The statement: `This is dog kind's *finest* hour!' is a parody of a + quotation from Winston Churchill. + diff --git a/cpan/Pod-Parser/t/pod/oneline_cmds.t b/cpan/Pod-Parser/t/pod/oneline_cmds.t index 28bd1d09e5..65df35271b 100644 --- a/cpan/Pod-Parser/t/pod/oneline_cmds.t +++ b/cpan/Pod-Parser/t/pod/oneline_cmds.t @@ -1,46 +1,46 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -==head1 NAME -B - insert an rdb table into a PostgreSQL database - -==head1 SYNOPSIS -B [I=I ...] - -==head1 PARAMETERS -B uses an IRAF-compatible parameter interface. -A template parameter file is in F. - -==over 4 -==item B I -The B file to insert into the database. If the given name -is the string C, it reads from the UNIX standard input stream. - -==back - -==head1 DESCRIPTION -B will enter the data from an B database into a -PostgreSQL database table, optionally creating the database and the -table if they do not exist. It automatically determines the -PostgreSQL data type from the column definition in the B file, -but may be overriden via a series of definition files or directly -via one of its parameters. - -The target database and table are specified by the C and C
          -parameters. If they do not exist, and the C parameter is -set, they will be created. Table field definitions are determined -in the following order: - +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +==head1 NAME +B - insert an rdb table into a PostgreSQL database + +==head1 SYNOPSIS +B [I=I ...] + +==head1 PARAMETERS +B uses an IRAF-compatible parameter interface. +A template parameter file is in F. + +==over 4 +==item B I +The B file to insert into the database. If the given name +is the string C, it reads from the UNIX standard input stream. + +==back + +==head1 DESCRIPTION +B will enter the data from an B database into a +PostgreSQL database table, optionally creating the database and the +table if they do not exist. It automatically determines the +PostgreSQL data type from the column definition in the B file, +but may be overriden via a series of definition files or directly +via one of its parameters. + +The target database and table are specified by the C and C
          +parameters. If they do not exist, and the C parameter is +set, they will be created. Table field definitions are determined +in the following order: + diff --git a/cpan/Pod-Parser/t/pod/oneline_cmds.xr b/cpan/Pod-Parser/t/pod/oneline_cmds.xr index fb37a2b0cf..f92efb5ecf 100644 --- a/cpan/Pod-Parser/t/pod/oneline_cmds.xr +++ b/cpan/Pod-Parser/t/pod/oneline_cmds.xr @@ -1,26 +1,26 @@ -NAME - rdb2pg - insert an rdb table into a PostgreSQL database - -SYNOPSIS - rdb2pg [*param*=*value* ...] - -PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template parameter - file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - input *file* - The RDB file to insert into the database. If the given name is the - string `stdin', it reads from the UNIX standard input stream. - -DESCRIPTION - rdb2pg will enter the data from an RDB database into a PostgreSQL - database table, optionally creating the database and the table if they - do not exist. It automatically determines the PostgreSQL data type from - the column definition in the RDB file, but may be overriden via a series - of definition files or directly via one of its parameters. - - The target database and table are specified by the `db' and `table' - parameters. If they do not exist, and the `createdb' parameter is set, - they will be created. Table field definitions are determined in the - following order: - +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template parameter + file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name is the + string `stdin', it reads from the UNIX standard input stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a PostgreSQL + database table, optionally creating the database and the table if they + do not exist. It automatically determines the PostgreSQL data type from + the column definition in the RDB file, but may be overriden via a series + of definition files or directly via one of its parameters. + + The target database and table are specified by the `db' and `table' + parameters. If they do not exist, and the `createdb' parameter is set, + they will be created. Table field definitions are determined in the + following order: + diff --git a/cpan/Pod-Parser/t/pod/p2u_data.pl b/cpan/Pod-Parser/t/pod/p2u_data.pl deleted file mode 100644 index ec0e3a7e50..0000000000 --- a/cpan/Pod-Parser/t/pod/p2u_data.pl +++ /dev/null @@ -1,18 +0,0 @@ -use Pod::Usage; -pod2usage(-verbose => 2, -exit => 17, -input => \*DATA); - -__DATA__ -=head1 NAME - -Test - -=head1 SYNOPSIS - -perl podusagetest.pl - -=head1 DESCRIPTION - -This is a test. - -=cut - diff --git a/cpan/Pod-Parser/t/pod/pod2usage.t b/cpan/Pod-Parser/t/pod/pod2usage.t deleted file mode 100644 index cf2c31b83f..0000000000 --- a/cpan/Pod-Parser/t/pod/pod2usage.t +++ /dev/null @@ -1,18 +0,0 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - -=include pod2usage.PL - - diff --git a/cpan/Pod-Parser/t/pod/pod2usage.xr b/cpan/Pod-Parser/t/pod/pod2usage.xr deleted file mode 100644 index b7c3da563e..0000000000 --- a/cpan/Pod-Parser/t/pod/pod2usage.xr +++ /dev/null @@ -1,57 +0,0 @@ -###### begin =include pod2usage.PL ##### -NAME - pod2usage - print usage messages from embedded pod docs in files - -SYNOPSIS - pod2usage [-help] [-man] [-exit *exitval*] [-output *outfile*] - [-verbose *level*] [-pathlist *dirlist*] *file* - -OPTIONS AND ARGUMENTS - -help Print a brief help message and exit. - - -man Print this command's manual page and exit. - - -exit *exitval* - The exit status value to return. - - -output *outfile* - The output file to print to. If the special names "-" or ">&1" - or ">&STDOUT" are used then standard output is used. If ">&2" or - ">&STDERR" is used then standard error is used. - - -verbose *level* - The desired level of verbosity to use: - - 1 : print SYNOPSIS only - 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections - 3 : print the entire manpage (similar to running pod2text) - - -pathlist *dirlist* - Specifies one or more directories to search for the input file - if it was not supplied with an absolute path. Each directory - path in the given list should be separated by a ':' on Unix (';' - on MSWin32 and DOS). - - *file* The pathname of a file containing pod documentation to be output - in usage message format (defaults to standard input). - -DESCRIPTION - pod2usage will read the given input file looking for pod documentation - and will print the corresponding usage message. If no input file is - specified then standard input is read. - - pod2usage invokes the pod2usage() function in the Pod::Usage module. - Please see the pod2usage() entry in the Pod::Usage manpage. - -SEE ALSO - the Pod::Usage manpage, the pod2text(1) manpage - -AUTHOR - Please report bugs using http://rt.cpan.org. - - Brad Appleton - - Based on code for pod2text(1) written by Tom Christiansen - - -###### end =include pod2usage.PL ##### diff --git a/cpan/Pod-Parser/t/pod/pod2usage2.t b/cpan/Pod-Parser/t/pod/pod2usage2.t deleted file mode 100644 index 80678a019f..0000000000 --- a/cpan/Pod-Parser/t/pod/pod2usage2.t +++ /dev/null @@ -1,357 +0,0 @@ -#!/usr/bin/perl -w - -use Test::More; -use strict; - -BEGIN { - if ($^O eq 'MSWin32' || $^O eq 'VMS') { - plan skip_all => "Not portable on Win32 or VMS\n"; - } - else { - plan tests => 34; - } - use_ok ("Pod::Usage"); -} - -sub getoutput -{ - my ($code) = @_; - my $pid = open(TEST_IN, "-|"); - unless(defined $pid) { - die "Cannot fork: $!"; - } - if($pid) { - # parent - my @out = ; - close(TEST_IN); - my $exit = $?>>8; - s/^/#/ for @out; - local $" = ""; - print "#EXIT=$exit OUTPUT=+++#@out#+++\n"; - return($exit, join("",@out)); - } - # child - open(STDERR, ">&STDOUT"); - Test::More->builder->no_ending(1); - &$code; - print "--NORMAL-RETURN--\n"; - exit 0; -} - -sub compare -{ - my ($left,$right) = @_; - $left =~ s/^#\s+/#/gm; - $right =~ s/^#\s+/#/gm; - $left =~ s/\s+/ /gm; - $right =~ s/\s+/ /gm; - $left eq $right; -} - -SKIP: { -if('Pod::Usage'->isa('Pod::Text') && $Pod::Text::VERSION < 2.18) { - skip("Formatting with Pod::Text $Pod::Text::VERSION not reliable", 33); -} - -my ($exit, $text) = getoutput( sub { pod2usage() } ); -is ($exit, 2, "Exit status pod2usage ()"); -ok (compare ($text, <<'EOT'), "Output test pod2usage ()"); -#Usage: -# frobnicate [ -r | --recursive ] [ -f | --force ] file ... -# -EOT - -($exit, $text) = getoutput( sub { pod2usage( - -message => 'You naughty person, what did you say?', - -verbose => 1 ) }); -is ($exit, 1, "Exit status pod2usage (-message => '...', -verbose => 1)"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)") or diag("Got:\n$text\n"); -#You naughty person, what did you say? -# Usage: -# frobnicate [ -r | --recursive ] [ -f | --force ] file ... -# -# Options: -# -r | --recursive -# Run recursively. -# -# -f | --force -# Just do it! -# -# -n number -# Specify number of frobs, default is 42. -# -EOT - -($exit, $text) = getoutput( sub { pod2usage( - -verbose => 2, -exit => 42 ) } ); -is ($exit, 42, "Exit status pod2usage (-verbose => 2, -exit => 42)"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -exit => 42)"); -#NAME -# frobnicate - do what I mean -# -# SYNOPSIS -# frobnicate [ -r | --recursive ] [ -f | --force ] file ... -# -# DESCRIPTION -# frobnicate does foo and bar and what not. -# -# OPTIONS -# -r | --recursive -# Run recursively. -# -# -f | --force -# Just do it! -# -# -n number -# Specify number of frobs, default is 42. -# -EOT - -($exit, $text) = getoutput( sub { pod2usage(0) } ); -is ($exit, 0, "Exit status pod2usage (0)"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (0)"); -#Usage: -# frobnicate [ -r | --recursive ] [ -f | --force ] file ... -# -# Options: -# -r | --recursive -# Run recursively. -# -# -f | --force -# Just do it! -# -# -n number -# Specify number of frobs, default is 42. -# -EOT - -($exit, $text) = getoutput( sub { pod2usage(42) } ); -is ($exit, 42, "Exit status pod2usage (42)"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (42)"); -#Usage: -# frobnicate [ -r | --recursive ] [ -f | --force ] file ... -# -EOT - -($exit, $text) = getoutput( sub { pod2usage(-verbose => 0, -exit => 'NOEXIT') } ); -is ($exit, 0, "Exit status pod2usage (-verbose => 0, -exit => 'NOEXIT')"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 0, -exit => 'NOEXIT')"); -#Usage: -# frobnicate [ -r | --recursive ] [ -f | --force ] file ... -# -# --NORMAL-RETURN-- -EOT - -($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION') } ); -is ($exit, 1, "Exit status pod2usage (-verbose => 99, -sections => 'DESCRIPTION')"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 99, -sections => 'DESCRIPTION')"); -#Description: -# frobnicate does foo and bar and what not. -# -EOT - -# does the __DATA__ work ok as input -my (@blib, $test_script, $pod_file1, , $pod_file2); -if (!$ENV{PERL_CORE}) { - @blib = '-Mblib'; -} -$test_script = File::Spec->catfile(qw(t pod p2u_data.pl)); -$pod_file1 = File::Spec->catfile(qw(t pod usage.pod)); -$pod_file2 = File::Spec->catfile(qw(t pod usage2.pod)); - - -($exit, $text) = getoutput( sub { system($^X, @blib, $test_script); exit($? >> 8); } ); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 17, "Exit status pod2usage (-verbose => 2, -input => \*DATA)"); -ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -input => \*DATA)") or diag "Got:\n$text\n"; -#NAME -# Test -# -#SYNOPSIS -# perl podusagetest.pl -# -#DESCRIPTION -# This is a test. -# -EOT - -# test that SYNOPSIS and USAGE are printed -($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1, - -exitval => 0, -verbose => 0); }); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with USAGE"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE") or diag "Got:\n$text\n"; -#Usage: -# This is a test for CPAN#33020 -# -#Usage: -# And this will be also printed. -# -EOT - -# test that SYNOPSIS and USAGE are printed with options -($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1, - -exitval => 0, -verbose => 1); }); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with USAGE and verbose=1"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=1") or diag "Got:\n$text\n"; -#Usage: -# This is a test for CPAN#33020 -# -#Usage: -# And this will be also printed. -# -#Options: -# And this with verbose == 1 -# -EOT - -# test that only USAGE is printed when requested -($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1, - -exitval => 0, -verbose => 99, -sections => 'USAGE'); }); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with USAGE and verbose=99"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n"; -#Usage: -# This is a test for CPAN#33020 -# -EOT - -# test with pod_where -use_ok('Pod::Find', qw(pod_where)); - -($exit, $text) = getoutput( sub { pod2usage( -input => pod_where({-inc => 1}, 'Pod::Usage'), - -exitval => 0, -verbose => 0) } ); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with Pod::Find"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with Pod::Find") or diag "Got:\n$text\n"; -#Usage: -# use Pod::Usage -# -# my $message_text = "This text precedes the usage message."; -# my $exit_status = 2; ## The exit status to use -# my $verbose_level = 0; ## The verbose level to use -# my $filehandle = \*STDERR; ## The filehandle to write to -# -# pod2usage($message_text); -# -# pod2usage($exit_status); -# -# pod2usage( { -message => $message_text , -# -exitval => $exit_status , -# -verbose => $verbose_level, -# -output => $filehandle } ); -# -# pod2usage( -msg => $message_text , -# -exitval => $exit_status , -# -verbose => $verbose_level, -# -output => $filehandle ); -# -# pod2usage( -verbose => 2, -# -noperldoc => 1 ) -# -EOT - -# verify that sections are correctly found after nested headings -($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file2, - -exitval => 0, -verbose => 99, - -sections => [qw(BugHeader BugHeader/.*')]) }); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with nested headings"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with nested headings") or diag "Got:\n$text\n"; -#BugHeader: -# Some text -# -# BugHeader2: -# More -# Still More -# -EOT - -# Verify that =over =back work OK -($exit, $text) = getoutput( sub { - pod2usage(-input => $pod_file2, - -exitval => 0, -verbose => 99, -sections => 'BugHeader/BugHeader2') } ); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with over/back"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with over/back") or diag "Got:\n$text\n"; -# BugHeader2: -# More -# Still More -# -EOT - -# new array API for -sections -($exit, $text) = getoutput( sub { - pod2usage(-input => $pod_file2, - -exitval => 0, -verbose => 99, -sections => [qw(Heading-1/!.+ Heading-2/.+)]) } ); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -is ($exit, 0, "Exit status pod2usage with -sections => []"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with -sections => []") or diag "Got:\n$text\n"; -#Heading-1: -# One -# Two -# -# Heading-2.2: -# More text. -# -EOT - -# allow subheadings in OPTIONS and ARGUMENTS -($exit, $text) = getoutput( sub { - pod2usage(-input => $pod_file2, - -exitval => 0, -verbose => 1) } ); -$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR -$text =~ s{[*](destination|files)[*]}{$1}g; # strip * chars -is ($exit, 0, "Exit status pod2usage with subheadings in OPTIONS"); -ok (compare ($text, <<'EOT'), "Output test pod2usage with subheadings in OPTIONS") or diag "Got:\n$text\n"; -#Options and Arguments: -# Arguments: -# The required arguments (which typically follow any options on the -# command line) are: -# -# destination -# files -# -# Options: -# Options may be abbreviated. Options which take values may be separated -# from the values by whitespace or the "=" character. -# -EOT -} # end SKIP - -__END__ - -=head1 NAME - -frobnicate - do what I mean - -=head1 SYNOPSIS - -B S<[ B<-r> | B<--recursive> ]> S<[ B<-f> | B<--force> ]> - file ... - -=head1 DESCRIPTION - -B does foo and bar and what not. - -=head1 OPTIONS - -=over 4 - -=item B<-r> | B<--recursive> - -Run recursively. - -=item B<-f> | B<--force> - -Just do it! - -=item B<-n> number - -Specify number of frobs, default is 42. - -=back - -=cut - diff --git a/cpan/Pod-Parser/t/pod/podchkenc.t b/cpan/Pod-Parser/t/pod/podchkenc.t deleted file mode 100644 index ccc2421a5a..0000000000 --- a/cpan/Pod-Parser/t/pod/podchkenc.t +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/perl -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testpchk.pl"; - import TestPodChecker; -} - -# this tests Pod::Checker accepts =encoding directive - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodchecker \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - -__END__ - -=encoding utf8 - -=encode utf8 - -dummy error - -=head1 An example. - -'Twas brillig, and the slithy toves did gyre and gimble in the wabe. - -=cut - diff --git a/cpan/Pod-Parser/t/pod/podchkenc.xr b/cpan/Pod-Parser/t/pod/podchkenc.xr deleted file mode 100644 index 45ec573fa2..0000000000 --- a/cpan/Pod-Parser/t/pod/podchkenc.xr +++ /dev/null @@ -1 +0,0 @@ -*** ERROR: Unknown command 'encode' at line 20 in file t/pod/podchkenc.t diff --git a/cpan/Pod-Parser/t/pod/poderrs.t b/cpan/Pod-Parser/t/pod/poderrs.t deleted file mode 100644 index 03ecc5b73b..0000000000 --- a/cpan/Pod-Parser/t/pod/poderrs.t +++ /dev/null @@ -1,241 +0,0 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testpchk.pl"; - import TestPodChecker; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodchecker \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - -### Deliberately throw in some blank but non-empty lines - -### The above line should contain spaces - - -__END__ - -=head2 This should cause a warning - -=head1 NAME - -poderrors.t - test Pod::Checker on some pod syntax errors - -=unknown1 this is an unknown command with two N -and D interior sequences. - -This is some paragraph text with some unknown interior sequences, -such as Q, -A, -and Y>. - -Now try some unterminated sequences like -I>> - -=head2 Garbled entities - -E -E> -E> -E<0x100> -E<07777> -E<300> - -=head2 Unresolved internal links - -L -L<"end with begin"> -L - -=head2 Some links with problems - -L -L<> -L< aha> -L -L<"Warnings"> this one is ok -L ok too, this POD has an X of the same name -L this is OK -L this is also OK - -=head2 Warnings - -L -L should give warnings as hell - -=over 4 - -=item bla - -=back 200 - -the 200 is evil - -=begin html - -What? - -=end xml - -Xsee these unescaped < and > in the text? - -=head2 Misc - -Z should be empty - -X<> should not be empty - -=over four - -This paragrapgh is misplaced - it ought to be an item. - -=item four should be numeric! - -=item - -=item blah - -=item previous is all empty!!! - -=back - -All empty over/back: - -=over 4 - -=back - -item w/o name - -=cut - -=pod bla - -bla is evil - -=cut blub - -blub is evil - -=head2 reoccurence - -=over 4 - -=item Misc - -we already have a head Misc - -=back - -=head2 some heading - -=head2 another one - -=head2 the next line should be empty -=head2 ... but there is a command instead - -And here is some text -=head2 again followed by a command - - verbatim -=item line missing - -previous section is empty! - -=head1 LINK TESTS - -Due to bug reported by Rafael Garcia-Suarez "rgarciasuarez@free.fr": - -The following hyperlinks : -L<"I/O Operators"> -L -trigger a podchecker warning (using bleadperl) : - node 'I/O Operators' contains non-escaped | or / - -=cut - -=pod - -=head1 ON-OFF tests - -The above =pod is OK. The following =cut is ok, the one after not. - -=cut - -# some comment or code here, not POD - -=cut - -# more code - -=head2 This opens POD - -=pod - -And the =pod above is too much. - -=cut - diff --git a/cpan/Pod-Parser/t/pod/poderrs.xr b/cpan/Pod-Parser/t/pod/poderrs.xr deleted file mode 100644 index 8c16609b20..0000000000 --- a/cpan/Pod-Parser/t/pod/poderrs.xr +++ /dev/null @@ -1,53 +0,0 @@ -*** WARNING: =head2 without preceding higher level at line 20 in file t/pod/poderrs.t -*** WARNING: empty section in previous paragraph at line 22 in file t/pod/poderrs.t -*** ERROR: Unknown command 'unknown1' at line 26 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Q' at line 30 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'A' at line 31 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Y' at line 32 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'V' at line 32 in file t/pod/poderrs.t -*** ERROR: unterminated B<...> at line 36 in file t/pod/poderrs.t -*** ERROR: unterminated I<...> at line 35 in file t/pod/poderrs.t -*** ERROR: unterminated C<...> at line 38 in file t/pod/poderrs.t -*** WARNING: line containing nothing but whitespace in paragraph at line 46 in file t/pod/poderrs.t -*** ERROR: =item without previous =over at line 53 in file t/pod/poderrs.t -*** ERROR: =back without previous =over at line 57 in file t/pod/poderrs.t -*** ERROR: =over on line 61 without closing =back (at head2) at line 65 in file t/pod/poderrs.t -*** ERROR: =end without =begin at line 67 in file t/pod/poderrs.t -*** ERROR: Nested =begin's (first at line 71:html) at line 73 in file t/pod/poderrs.t -*** ERROR: =end without =begin at line 77 in file t/pod/poderrs.t -*** ERROR: No argument for =begin at line 83 in file t/pod/poderrs.t -*** ERROR: =for without formatter specification at line 89 in file t/pod/poderrs.t -*** WARNING: nested commands C<...C<...>...> at line 95 in file t/pod/poderrs.t -*** ERROR: garbled entity E at line 99 in file t/pod/poderrs.t -*** ERROR: garbled entity E> at line 100 in file t/pod/poderrs.t -*** ERROR: garbled entity E> at line 101 in file t/pod/poderrs.t -*** ERROR: Entity number out of range E<0x100> at line 102 in file t/pod/poderrs.t -*** ERROR: Entity number out of range E<07777> at line 103 in file t/pod/poderrs.t -*** ERROR: Entity number out of range E<300> at line 104 in file t/pod/poderrs.t -*** ERROR: malformed link L<> : empty link at line 116 in file t/pod/poderrs.t -*** WARNING: ignoring leading whitespace in link at line 117 in file t/pod/poderrs.t -*** WARNING: ignoring trailing whitespace in link at line 118 in file t/pod/poderrs.t -*** WARNING: (section) in 'passwd(5)' deprecated at line 126 in file t/pod/poderrs.t -*** WARNING: node '$|' contains non-escaped | or / at line 127 in file t/pod/poderrs.t -*** WARNING: alternative text '$|' contains non-escaped | or / at line 127 in file t/pod/poderrs.t -*** ERROR: Spurious character(s) after =back at line 133 in file t/pod/poderrs.t -*** ERROR: Nonempty Z<> at line 147 in file t/pod/poderrs.t -*** ERROR: Empty X<> at line 149 in file t/pod/poderrs.t -*** WARNING: preceding non-item paragraph(s) at line 155 in file t/pod/poderrs.t -*** WARNING: No argument for =item at line 157 in file t/pod/poderrs.t -*** WARNING: previous =item has no contents at line 159 in file t/pod/poderrs.t -*** WARNING: No items in =over (at line 167) / =back list at line 169 in file t/pod/poderrs.t -*** ERROR: Spurious text after =pod at line 175 in file t/pod/poderrs.t -*** ERROR: Spurious text after =cut at line 179 in file t/pod/poderrs.t -*** WARNING: empty section in previous paragraph at line 195 in file t/pod/poderrs.t -*** ERROR: Apparent command =head2 not preceded by blank line at line 198 in file t/pod/poderrs.t -*** WARNING: empty section in previous paragraph at line 197 in file t/pod/poderrs.t -*** ERROR: Apparent command =head2 not preceded by blank line at line 201 in file t/pod/poderrs.t -*** ERROR: Apparent command =item not preceded by blank line at line 204 in file t/pod/poderrs.t -*** ERROR: Spurious =cut command at line 230 in file t/pod/poderrs.t -*** ERROR: Spurious =pod command at line 236 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'begin or begin' at line 108 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'end with begin' at line 109 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'OoPs' at line 110 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'abc def' at line 114 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'I/O Operators' at line 213 in file t/pod/poderrs.t diff --git a/cpan/Pod-Parser/t/pod/podselect.t b/cpan/Pod-Parser/t/pod/podselect.t index 0004548cb7..2d8e6b4f58 100644 --- a/cpan/Pod-Parser/t/pod/podselect.t +++ b/cpan/Pod-Parser/t/pod/podselect.t @@ -1,18 +1,18 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - -=include podselect.PL - - +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + +=include podselect.PL + + diff --git a/cpan/Pod-Parser/t/pod/podselect.xr b/cpan/Pod-Parser/t/pod/podselect.xr index c288e91280..00b977491c 100644 --- a/cpan/Pod-Parser/t/pod/podselect.xr +++ b/cpan/Pod-Parser/t/pod/podselect.xr @@ -1,44 +1,44 @@ -###### begin =include podselect.PL ##### -NAME - podselect - print selected sections of pod documentation on standard - output - -SYNOPSIS - podselect [-help] [-man] [-section *section-spec*] [*file* ...] - -OPTIONS AND ARGUMENTS - -help Print a brief help message and exit. - - -man Print the manual page and exit. - - -section *section-spec* - Specify a section to include in the output. See the section on - "SECTION SPECIFICATIONS" in the Pod::Parser manpage for the - format to use for *section-spec*. This option may be given - multiple times on the command line. - - *file* The pathname of a file from which to select sections of pod - documentation (defaults to standard input). - -DESCRIPTION - podselect will read the given input files looking for pod documentation - and will print out (in raw pod format) all sections that match one ore - more of the given section specifications. If no section specifications - are given than all pod sections encountered are output. - - podselect invokes the podselect() function exported by Pod::Select - Please see the podselect() entry in the Pod::Select manpage for more - details. - -SEE ALSO - the Pod::Parser manpage and the Pod::Select manpage - -AUTHOR - Please report bugs using http://rt.cpan.org. - - Brad Appleton - - Based on code for Pod::Text::pod2text(1) written by Tom Christiansen - - -###### end =include podselect.PL ##### +###### begin =include podselect.PL ##### +NAME + podselect - print selected sections of pod documentation on standard + output + +SYNOPSIS + podselect [-help] [-man] [-section *section-spec*] [*file* ...] + +OPTIONS AND ARGUMENTS + -help Print a brief help message and exit. + + -man Print the manual page and exit. + + -section *section-spec* + Specify a section to include in the output. See the section on + "SECTION SPECIFICATIONS" in the Pod::Parser manpage for the + format to use for *section-spec*. This option may be given + multiple times on the command line. + + *file* The pathname of a file from which to select sections of pod + documentation (defaults to standard input). + +DESCRIPTION + podselect will read the given input files looking for pod documentation + and will print out (in raw pod format) all sections that match one ore + more of the given section specifications. If no section specifications + are given than all pod sections encountered are output. + + podselect invokes the podselect() function exported by Pod::Select + Please see the podselect() entry in the Pod::Select manpage for more + details. + +SEE ALSO + the Pod::Parser manpage and the Pod::Select manpage + +AUTHOR + Please report bugs using http://rt.cpan.org. + + Brad Appleton + + Based on code for Pod::Text::pod2text(1) written by Tom Christiansen + + +###### end =include podselect.PL ##### diff --git a/cpan/Pod-Parser/t/pod/selfcheck.t b/cpan/Pod-Parser/t/pod/selfcheck.t index d170570c6c..17df68e301 100644 --- a/cpan/Pod-Parser/t/pod/selfcheck.t +++ b/cpan/Pod-Parser/t/pod/selfcheck.t @@ -1,45 +1,53 @@ -#!/usr/bin/perl -use File::Basename; -use File::Spec; -use strict; -my $THISDIR; -BEGIN { - $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testpchk.pl"; - import TestPodChecker qw(testpodcheck); -} - -# test that our POD is correct! -my $path = File::Spec->catfile($THISDIR,(File::Spec->updir()) x 2, 'lib', 'Pod', '*.pm'); -print "THISDIR=$THISDIR PATH=$path\n"; -my @pods = glob($path); -print "PODS=@pods\n"; - -print "1..",scalar(@pods),"\n"; - -my $errs = 0; -my $testnum = 1; -foreach my $pod (@pods) { - my $out = File::Spec->catfile($THISDIR, basename($pod)); - $out =~ s{\.pm}{.OUT}; - my %options = ( -Out => $out ); - my $failmsg = testpodcheck(-In => $pod, -Out => $out, -Cmp => "$THISDIR/empty.xr"); - if($failmsg) { - if(open(IN, "<$out")) { - while() { - warn "podchecker: $_"; - } - close(IN); - } else { - warn "Error: Cannot read output file $out: $!\n"; - } - print "not ok $testnum\n"; - $errs++; - } else { - print "ok $testnum\n"; - } - $testnum++; -} -exit( ($errs == 0) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - +#!/usr/bin/perl +use Test::More; +use File::Basename; +use File::Spec; +use strict; +my $THISDIR; +BEGIN { + $THISDIR = dirname $0; + unshift @INC, $THISDIR; + eval { + require "testpchk.pl"; + import TestPodChecker qw(testpodcheck); + }; + warn $@ if $@; +}; + +my @pods; +unless($Pod::Checker::VERSION && $Pod::Checker::VERSION > 1.40) { + plan skip_all => "we do not have a good Pod::Checker around"; +} else { + my $path = File::Spec->catfile($THISDIR,(File::Spec->updir()) x 2, 'lib', 'Pod', '*.pm'); + print "THISDIR=$THISDIR PATH=$path\n"; + @pods = glob($path); + print "PODS=@pods\n"; + plan tests => scalar(@pods); +} + +# test that our POD is correct! +my $errs = 0; + +foreach my $pod (@pods) { + my $out = File::Spec->catfile($THISDIR, basename($pod)); + $out =~ s{\.pm}{.OUT}; + my %options = ( -Out => $out ); + my $failmsg = testpodcheck(-In => $pod, -Out => $out, -Cmp => "$THISDIR/empty.xr"); + if($failmsg) { + if(open(IN, "<$out")) { + while() { + warn "podchecker: $_"; + } + close(IN); + } else { + warn "Error: Cannot read output file $out: $!\n"; + } + ok(0, $pod); + $errs++; + } else { + ok(1, $pod); + } +} + +exit( ($errs == 0) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + diff --git a/cpan/Pod-Parser/t/pod/special_seqs.t b/cpan/Pod-Parser/t/pod/special_seqs.t index ecd99ecde8..f1399ccf77 100644 --- a/cpan/Pod-Parser/t/pod/special_seqs.t +++ b/cpan/Pod-Parser/t/pod/special_seqs.t @@ -1,46 +1,46 @@ -BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -This is a test to see if I can do not only C<$self> and C, but -also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and -C<< $Foo <=> $Bar >> without resorting to escape sequences. If -I want to refer to the right-shift operator I can do something -like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>. - -Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>. -And I also want to make sure that newlines work like this -C<<< -$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b] ->>> - -Of course I should still be able to do all this I escape sequences -too: C<$self-Emethod()> and C<$self-E{FIELDNAME}> and C<{FOO=EBAR}>. - -Dont forget C<$self-Emethod()-E{FIELDNAME} = {FOO=EBAR}>. - -And make sure that C<0> works too! - -Now, if I use << or >> as my delimiters, then I have to use whitespace. -So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end -up doing what you might expect since the first > will still terminate -the first < seen. - -Lets make sure these work for empty ones too, like C<< >> and C<< >> >> -(just to be obnoxious) - -=cut +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This is a test to see if I can do not only C<$self> and C, but +also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and +C<< $Foo <=> $Bar >> without resorting to escape sequences. If +I want to refer to the right-shift operator I can do something +like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>. + +Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>. +And I also want to make sure that newlines work like this +C<<< +$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b] +>>> + +Of course I should still be able to do all this I escape sequences +too: C<$self-Emethod()> and C<$self-E{FIELDNAME}> and C<{FOO=EBAR}>. + +Dont forget C<$self-Emethod()-E{FIELDNAME} = {FOO=EBAR}>. + +And make sure that C<0> works too! + +Now, if I use << or >> as my delimiters, then I have to use whitespace. +So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end +up doing what you might expect since the first > will still terminate +the first < seen. + +Lets make sure these work for empty ones too, like C<< >> and C<< >> >> +(just to be obnoxious) + +=cut diff --git a/cpan/Pod-Parser/t/pod/special_seqs.xr b/cpan/Pod-Parser/t/pod/special_seqs.xr index a8c715ae0a..4d6c55e5a1 100644 --- a/cpan/Pod-Parser/t/pod/special_seqs.xr +++ b/cpan/Pod-Parser/t/pod/special_seqs.xr @@ -1,25 +1,25 @@ - This is a test to see if I can do not only `$self' and `method()', but - also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar' - without resorting to escape sequences. If I want to refer to the - right-shift operator I can do something like `$x >> 3' or even `$y >> - 5'. - - Now for the grand finale of `$self->method()->{FIELDNAME} = {FOO=>BAR}'. - And I also want to make sure that newlines work like this - `$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]' - - Of course I should still be able to do all this *with* escape sequences - too: `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}'. - - Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'. - - And make sure that `0' works too! - - Now, if I use << or >> as my delimiters, then I have to use whitespace. - So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end - up doing what you might expect since the first > will still terminate - the first < seen. - - Lets make sure these work for empty ones too, like and `>>' (just to be - obnoxious) - + This is a test to see if I can do not only `$self' and `method()', but + also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar' + without resorting to escape sequences. If I want to refer to the + right-shift operator I can do something like `$x >> 3' or even `$y >> + 5'. + + Now for the grand finale of `$self->method()->{FIELDNAME} = {FOO=>BAR}'. + And I also want to make sure that newlines work like this + `$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]' + + Of course I should still be able to do all this *with* escape sequences + too: `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}'. + + Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'. + + And make sure that `0' works too! + + Now, if I use << or >> as my delimiters, then I have to use whitespace. + So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end + up doing what you might expect since the first > will still terminate + the first < seen. + + Lets make sure these work for empty ones too, like and `>>' (just to be + obnoxious) + diff --git a/cpan/Pod-Parser/t/pod/testcmp.pl b/cpan/Pod-Parser/t/pod/testcmp.pl index 17f0b0b4c2..b8592fcc2a 100644 --- a/cpan/Pod-Parser/t/pod/testcmp.pl +++ b/cpan/Pod-Parser/t/pod/testcmp.pl @@ -1,94 +1,94 @@ -package TestCompare; - -use vars qw(@ISA @EXPORT $MYPKG); -#use strict; -#use diagnostics; -use Carp; -use Exporter; -use File::Basename; -use File::Spec; -use FileHandle; - -@ISA = qw(Exporter); -@EXPORT = qw(&testcmp); -$MYPKG = eval { (caller)[0] }; - -##-------------------------------------------------------------------------- - -=head1 NAME - -testcmp -- compare two files line-by-line - -=head1 SYNOPSIS - - $is_diff = testcmp($file1, $file2); - -or - - $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); - -=head2 DESCRIPTION - -Compare two text files line-by-line and return 0 if they are the -same, 1 if they differ. Each of $file1 and $file2 may be a filenames, -or a filehandles (in which case it must already be open for reading). - -If the first argument is a hashref, then the B<-cmplines> key in the -hash may have a subroutine reference as its corresponding value. -The referenced user-defined subroutine should be a line-comparator -function that takes two pre-chomped text-lines as its arguments -(the first is from $file1 and the second is from $file2). It should -return 0 if it considers the two lines equivalent, and non-zero -otherwise. - -=cut - -##-------------------------------------------------------------------------- - -sub testcmp( $ $ ; $) { - my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); - my ($file1, $file2) = @_; - my ($fh1, $fh2) = ($file1, $file2); - unless (ref $fh1) { - $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; - } - unless (ref $fh2) { - $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; - } - - my $cmplines = $opts{'-cmplines'} || undef; - my ($f1text, $f2text) = ("", ""); - my ($line, $diffs) = (0, 0); - - while ( defined($f1text) and defined($f2text) ) { - defined($f1text = <$fh1>) and chomp($f1text); - defined($f2text = <$fh2>) and chomp($f2text); - ++$line; - last unless ( defined($f1text) and defined($f2text) ); - # kill any extra line endings - $f1text =~ s/[\r\n]+$//s; - $f2text =~ s/[\r\n]+$//s; - $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) - : ($f1text ne $f2text); - last if $diffs; - } - close($fh1) unless (ref $file1); - close($fh2) unless (ref $file2); - - $diffs = 1 if (defined($f1text) or defined($f2text)); - if ( defined($f1text) and defined($f2text) ) { - ## these two lines must be different - warn "$file1 and $file2 differ at line $line\n"; - } - elsif (defined($f1text) and (! defined($f1text))) { - ## file1 must be shorter - warn "$file1 is shorter than $file2\n"; - } - elsif (defined $f2text) { - ## file2 must be longer - warn "$file1 is shorter than $file2\n"; - } - return $diffs; -} - -1; +package TestCompare; + +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +use File::Basename; +use File::Spec; +use FileHandle; + +@ISA = qw(Exporter); +@EXPORT = qw(&testcmp); +$MYPKG = eval { (caller)[0] }; + +##-------------------------------------------------------------------------- + +=head1 NAME + +testcmp -- compare two files line-by-line + +=head1 SYNOPSIS + + $is_diff = testcmp($file1, $file2); + +or + + $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); + +=head2 DESCRIPTION + +Compare two text files line-by-line and return 0 if they are the +same, 1 if they differ. Each of $file1 and $file2 may be a filenames, +or a filehandles (in which case it must already be open for reading). + +If the first argument is a hashref, then the B<-cmplines> key in the +hash may have a subroutine reference as its corresponding value. +The referenced user-defined subroutine should be a line-comparator +function that takes two pre-chomped text-lines as its arguments +(the first is from $file1 and the second is from $file2). It should +return 0 if it considers the two lines equivalent, and non-zero +otherwise. + +=cut + +##-------------------------------------------------------------------------- + +sub testcmp( $ $ ; $) { + my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); + my ($file1, $file2) = @_; + my ($fh1, $fh2) = ($file1, $file2); + unless (ref $fh1) { + $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; + } + unless (ref $fh2) { + $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; + } + + my $cmplines = $opts{'-cmplines'} || undef; + my ($f1text, $f2text) = ("", ""); + my ($line, $diffs) = (0, 0); + + while ( defined($f1text) and defined($f2text) ) { + defined($f1text = <$fh1>) and chomp($f1text); + defined($f2text = <$fh2>) and chomp($f2text); + ++$line; + last unless ( defined($f1text) and defined($f2text) ); + # kill any extra line endings + $f1text =~ s/[\r\n]+$//s; + $f2text =~ s/[\r\n]+$//s; + $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) + : ($f1text ne $f2text); + last if $diffs; + } + close($fh1) unless (ref $file1); + close($fh2) unless (ref $file2); + + $diffs = 1 if (defined($f1text) or defined($f2text)); + if ( defined($f1text) and defined($f2text) ) { + ## these two lines must be different + warn "$file1 and $file2 differ at line $line\n"; + } + elsif (defined($f1text) and (! defined($f1text))) { + ## file1 must be shorter + warn "$file1 is shorter than $file2\n"; + } + elsif (defined $f2text) { + ## file2 must be longer + warn "$file1 is shorter than $file2\n"; + } + return $diffs; +} + +1; diff --git a/cpan/Pod-Parser/t/pod/testp2pt.pl b/cpan/Pod-Parser/t/pod/testp2pt.pl index 308cd1ccd6..5c17300b50 100644 --- a/cpan/Pod-Parser/t/pod/testp2pt.pl +++ b/cpan/Pod-Parser/t/pod/testp2pt.pl @@ -1,192 +1,192 @@ -package TestPodIncPlainText; - -BEGIN { - use File::Basename; - use File::Spec; - use Cwd qw(abs_path); - push @INC, '..'; - my $THISDIR = abs_path(dirname $0); - unshift @INC, $THISDIR; - require "testcmp.pl"; - import TestCompare; - my $PARENTDIR = dirname $THISDIR; - push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); -} - -#use strict; -#use diagnostics; -use Carp; -use Exporter; -#use File::Compare; -#use Cwd qw(abs_path); - -use vars qw($MYPKG @EXPORT @ISA); -$MYPKG = eval { (caller)[0] }; -@EXPORT = qw(&testpodplaintext); -BEGIN { - require Pod::PlainText; - @ISA = qw( Pod::PlainText ); - require VMS::Filespec if $^O eq 'VMS'; -} - -## Hardcode settings for TERMCAP and COLUMNS so we can try to get -## reproducible results between environments -@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); - -sub catfile(@) { File::Spec->catfile(@_); } - -my $INSTDIR = abs_path(dirname $0); -$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; -$INSTDIR =~ s#/$## if $^O eq 'VMS'; -$INSTDIR =~ s#:$## if $^O eq 'MacOS'; -$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); -$INSTDIR =~ s#:$## if $^O eq 'MacOS'; -$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); -my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), - catfile($INSTDIR, 'scripts'), - catfile($INSTDIR, 'pod'), - catfile($INSTDIR, 't', 'pod') - ); - -# FIXME - we should make the core capable of finding utilities built in -# locations in ext. -push @PODINCDIRS, catfile((File::Spec->updir()) x 2, 'pod') if $ENV{PERL_CORE}; - -## Find the path to the file to =include -sub findinclude { - my $self = shift; - my $incname = shift; - - ## See if its already found w/out any "searching; - return $incname if (-r $incname); - - ## Need to search for it. Look in the following directories ... - ## 1. the directory containing this pod file - my $thispoddir = dirname $self->input_file; - ## 2. the parent directory of the above - my $parentdir = dirname $thispoddir; - my @podincdirs = ($thispoddir, $parentdir, @PODINCDIRS); - - for (@podincdirs) { - my $incfile = catfile($_, $incname); - return $incfile if (-r $incfile); - } - warn("*** Can't find =include file $incname in @podincdirs\n"); - return ""; -} - -sub command { - my $self = shift; - my ($cmd, $text, $line_num, $pod_para) = @_; - $cmd = '' unless (defined $cmd); - local $_ = $text || ''; - my $out_fh = $self->output_handle; - - ## Defer to the superclass for everything except '=include' - return $self->SUPER::command(@_) unless ($cmd eq "include"); - - ## We have an '=include' command - my $incdebug = 1; ## debugging - my @incargs = split; - if (@incargs == 0) { - warn("*** No filename given for '=include'\n"); - return; - } - my $incfile = $self->findinclude(shift @incargs) or return; - my $incbase = basename $incfile; - print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); - $self->parse_from_file( {-cutting => 1}, $incfile ); - print $out_fh "###### end =include $incbase #####\n" if ($incdebug); -} - -sub begin_input { - $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS'; -} - -sub podinc2plaintext( $ $ ) { - my ($infile, $outfile) = @_; - local $_; - my $text_parser = $MYPKG->new; - $text_parser->parse_from_file($infile, $outfile); -} - -sub testpodinc2plaintext( @ ) { - my %args = @_; - my $infile = $args{'-In'} || croak "No input file given!"; - my $outfile = $args{'-Out'} || croak "No output file given!"; - my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; - - my $different = ''; - my $testname = basename $cmpfile, '.t', '.xr'; - - unless (-e $cmpfile) { - my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; - warn "$msg\n"; - return $msg; - } - - print "# Running testpodinc2plaintext for '$testname'...\n"; - ## Compare the output against the expected result - podinc2plaintext($infile, $outfile); - if ( testcmp($outfile, $cmpfile) ) { - $different = "$outfile is different from $cmpfile"; - } - else { - unlink($outfile); - } - return $different; -} - -sub testpodplaintext( @ ) { - my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); - my @testpods = @_; - my ($testname, $testdir) = ("", ""); - my ($podfile, $cmpfile) = ("", ""); - my ($outfile, $errfile) = ("", ""); - my $passes = 0; - my $failed = 0; - local $_; - - print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); - - for $podfile (@testpods) { - ($testname, $_) = fileparse($podfile); - $testdir ||= $_; - $testname =~ s/\.t$//; - $cmpfile = $testdir . $testname . '.xr'; - $outfile = $testdir . $testname . '.OUT'; - - if ($opts{'-xrgen'}) { - if ($opts{'-force'} or ! -e $cmpfile) { - ## Create the comparison file - print "# Creating expected result for \"$testname\"" . - " pod2plaintext test ...\n"; - podinc2plaintext($podfile, $cmpfile); - } - else { - print "# File $cmpfile already exists" . - " (use '-force' to regenerate it).\n"; - } - next; - } - - my $failmsg = testpodinc2plaintext - -In => $podfile, - -Out => $outfile, - -Cmp => $cmpfile; - if ($failmsg) { - ++$failed; - print "#\tFAILED. ($failmsg)\n"; - print "not ok ", $failed+$passes, "\n"; - } - else { - ++$passes; - unlink($outfile); - print "#\tPASSED.\n"; - print "ok ", $failed+$passes, "\n"; - } - } - return $passes; -} - -1; +package TestPodIncPlainText; + +BEGIN { + use File::Basename; + use File::Spec; + use Cwd qw(abs_path); + push @INC, '..'; + my $THISDIR = abs_path(dirname $0); + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); +} + +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; +#use Cwd qw(abs_path); + +use vars qw($MYPKG @EXPORT @ISA); +$MYPKG = eval { (caller)[0] }; +@EXPORT = qw(&testpodplaintext); +BEGIN { + require Pod::PlainText; + @ISA = qw( Pod::PlainText ); + require VMS::Filespec if $^O eq 'VMS'; +} + +## Hardcode settings for TERMCAP and COLUMNS so we can try to get +## reproducible results between environments +@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); + +sub catfile(@) { File::Spec->catfile(@_); } + +my $INSTDIR = abs_path(dirname $0); +$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; +$INSTDIR =~ s#/$## if $^O eq 'VMS'; +$INSTDIR =~ s#:$## if $^O eq 'MacOS'; +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); +$INSTDIR =~ s#:$## if $^O eq 'MacOS'; +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); +my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), + catfile($INSTDIR, 'scripts'), + catfile($INSTDIR, 'pod'), + catfile($INSTDIR, 't', 'pod') + ); + +# FIXME - we should make the core capable of finding utilities built in +# locations in ext. +push @PODINCDIRS, catfile((File::Spec->updir()) x 2, 'pod') if $ENV{PERL_CORE}; + +## Find the path to the file to =include +sub findinclude { + my $self = shift; + my $incname = shift; + + ## See if its already found w/out any "searching; + return $incname if (-r $incname); + + ## Need to search for it. Look in the following directories ... + ## 1. the directory containing this pod file + my $thispoddir = dirname $self->input_file; + ## 2. the parent directory of the above + my $parentdir = dirname $thispoddir; + my @podincdirs = ($thispoddir, $parentdir, @PODINCDIRS); + + for (@podincdirs) { + my $incfile = catfile($_, $incname); + return $incfile if (-r $incfile); + } + warn("*** Can't find =include file $incname in @podincdirs\n"); + return ""; +} + +sub command { + my $self = shift; + my ($cmd, $text, $line_num, $pod_para) = @_; + $cmd = '' unless (defined $cmd); + local $_ = $text || ''; + my $out_fh = $self->output_handle; + + ## Defer to the superclass for everything except '=include' + return $self->SUPER::command(@_) unless ($cmd eq "include"); + + ## We have an '=include' command + my $incdebug = 1; ## debugging + my @incargs = split; + if (@incargs == 0) { + warn("*** No filename given for '=include'\n"); + return; + } + my $incfile = $self->findinclude(shift @incargs) or return; + my $incbase = basename $incfile; + print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); + $self->parse_from_file( {-cutting => 1}, $incfile ); + print $out_fh "###### end =include $incbase #####\n" if ($incdebug); +} + +sub begin_input { + $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS'; +} + +sub podinc2plaintext( $ $ ) { + my ($infile, $outfile) = @_; + local $_; + my $text_parser = $MYPKG->new; + $text_parser->parse_from_file($infile, $outfile); +} + +sub testpodinc2plaintext( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $cmpfile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "# Running testpodinc2plaintext for '$testname'...\n"; + ## Compare the output against the expected result + podinc2plaintext($infile, $outfile); + if ( testcmp($outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodplaintext( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "# Creating expected result for \"$testname\"" . + " pod2plaintext test ...\n"; + podinc2plaintext($podfile, $cmpfile); + } + else { + print "# File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodinc2plaintext + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "#\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "#\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/cpan/Pod-Parser/t/pod/testpchk.pl b/cpan/Pod-Parser/t/pod/testpchk.pl index aeb0be333d..0464a9a0fc 100644 --- a/cpan/Pod-Parser/t/pod/testpchk.pl +++ b/cpan/Pod-Parser/t/pod/testpchk.pl @@ -1,130 +1,130 @@ -package TestPodChecker; - -BEGIN { - use File::Basename; - use File::Spec; - push @INC, '..'; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testcmp.pl"; - import TestCompare; - my $PARENTDIR = dirname $THISDIR; - push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); - require VMS::Filespec if $^O eq 'VMS'; -} - -use Pod::Checker; -use vars qw(@ISA @EXPORT $MYPKG); -#use strict; -#use diagnostics; -use Carp; -use Exporter; -#use File::Compare; - -@ISA = qw(Exporter); -@EXPORT = qw(&testpodchecker); -@EXPORT_OK = qw(&testpodcheck); -$MYPKG = eval { (caller)[0] }; - -sub stripname( $ ) { - local $_ = shift; - return /(\w[.\w]*)\s*$/ ? $1 : $_; -} - -sub msgcmp( $ $ ) { - ## filter out platform-dependent aspects of error messages - my ($line1, $line2) = @_; - for ($line1, $line2) { - ## remove filenames from error messages to avoid any - ## filepath naming differences between OS platforms - s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/; - s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/; - } - return ($line1 ne $line2); -} - -sub testpodcheck( @ ) { - my %args = @_; - my $infile = $args{'-In'} || croak "No input file given!"; - my $outfile = $args{'-Out'} || croak "No output file given!"; - my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; - - my $different = ''; - my $testname = basename $infile, '.t', '.xr'; - - unless (-e $cmpfile) { - my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; - warn "$msg\n"; - return $msg; - } - - print "# Running podchecker for '$testname'...\n"; - ## Compare the output against the expected result - if ($^O eq 'VMS') { - for ($infile, $outfile, $cmpfile) { - $_ = VMS::Filespec::unixify($_) unless ref; - } - } - podchecker($infile, $outfile); - if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { - $different = "$outfile is different from $cmpfile"; - } - else { - unlink($outfile); - } - return $different; -} - -sub testpodchecker( @ ) { - my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); - my @testpods = @_; - my ($testname, $testdir) = ("", ""); - my ($podfile, $cmpfile) = ("", ""); - my ($outfile, $errfile) = ("", ""); - my $passes = 0; - my $failed = 0; - local $_; - - print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); - - for $podfile (@testpods) { - ($testname, $_) = fileparse($podfile); - $testdir ||= $_; - $testname =~ s/\.t$//; - $cmpfile = $testdir . $testname . '.xr'; - $outfile = $testdir . $testname . '.OUT'; - - if ($opts{'-xrgen'}) { - if ($opts{'-force'} or ! -e $cmpfile) { - ## Create the comparison file - print "# Creating expected result for \"$testname\"" . - " podchecker test ...\n"; - podchecker($podfile, $cmpfile); - } - else { - print "# File $cmpfile already exists" . - " (use '-force' to regenerate it).\n"; - } - next; - } - - my $failmsg = testpodcheck - -In => $podfile, - -Out => $outfile, - -Cmp => $cmpfile; - if ($failmsg) { - ++$failed; - print "#\tFAILED. ($failmsg)\n"; - print "not ok ", $failed+$passes, "\n"; - } - else { - ++$passes; - unlink($outfile); - print "#\tPASSED.\n"; - print "ok ", $failed+$passes, "\n"; - } - } - return $passes; -} - -1; +package TestPodChecker; + +BEGIN { + use File::Basename; + use File::Spec; + push @INC, '..'; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); + require VMS::Filespec if $^O eq 'VMS'; +} + +use Pod::Checker; +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; + +@ISA = qw(Exporter); +@EXPORT = qw(&testpodchecker); +@EXPORT_OK = qw(&testpodcheck); +$MYPKG = eval { (caller)[0] }; + +sub stripname( $ ) { + local $_ = shift; + return /(\w[.\w]*)\s*$/ ? $1 : $_; +} + +sub msgcmp( $ $ ) { + ## filter out platform-dependent aspects of error messages + my ($line1, $line2) = @_; + for ($line1, $line2) { + ## remove filenames from error messages to avoid any + ## filepath naming differences between OS platforms + s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/; + s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/; + } + return ($line1 ne $line2); +} + +sub testpodcheck( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $infile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "# Running podchecker for '$testname'...\n"; + ## Compare the output against the expected result + if ($^O eq 'VMS') { + for ($infile, $outfile, $cmpfile) { + $_ = VMS::Filespec::unixify($_) unless ref; + } + } + podchecker($infile, $outfile); + if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodchecker( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "# Creating expected result for \"$testname\"" . + " podchecker test ...\n"; + podchecker($podfile, $cmpfile); + } + else { + print "# File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodcheck + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "#\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "#\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm b/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm index d5c1120303..00a719c656 100644 --- a/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm +++ b/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm @@ -1,20 +1,20 @@ -=head1 NAME - -Pod::Stuff - dummy testing pod - -=head1 DESCRIPTION - -This isn't really anything, its just some dummy pod code. -And stuff. - -Lots of stuff. - -=head2 STUFF - -For all your stuff [tm] - -Stuffit - -Mmmm, stuffed pizza bread. - -=cut +=head1 NAME + +Pod::Stuff - dummy testing pod + +=head1 DESCRIPTION + +This isn't really anything, its just some dummy pod code. +And stuff. + +Lots of stuff. + +=head2 STUFF + +For all your stuff [tm] + +Stuffit + +Mmmm, stuffed pizza bread. + +=cut diff --git a/cpan/Pod-Parser/t/pod/twice.t b/cpan/Pod-Parser/t/pod/twice.t index 098bc3c628..ffb957dadd 100644 --- a/cpan/Pod-Parser/t/pod/twice.t +++ b/cpan/Pod-Parser/t/pod/twice.t @@ -1,36 +1,36 @@ -use strict; -use Test; -use File::Spec; - -BEGIN { plan tests => 1 } - -use Pod::Parser; -use Carp; -$SIG{__DIE__} = \&Carp::confess; - -eval {require IO::String;}; -skip($@ ? 'no IO::String' : '', sub { - { - my $pod_string = 'some I text'; - my $handle = IO::String->new( \$pod_string ); - my $parser = Pod::Parser->new(); - $parser->parse_from_file( $0, $handle ); - } - # free the reference - { - my $parser = Pod::Parser->new(); - $parser->parse_from_file( $0, File::Spec->devnull ); - } - 1; -}); - -exit 0; - -__END__ - -=head1 EXAMPLE - -This test makes sure the parse_from_file is re-entrant - -=cut - +use strict; +use Test; +use File::Spec; + +BEGIN { plan tests => 1 } + +use Pod::Parser; +use Carp; +$SIG{__DIE__} = \&Carp::confess; + +eval {require IO::String;}; +skip($@ ? 'no IO::String' : '', sub { + { + my $pod_string = 'some I text'; + my $handle = IO::String->new( \$pod_string ); + my $parser = Pod::Parser->new(); + $parser->parse_from_file( $0, $handle ); + } + # free the reference + { + my $parser = Pod::Parser->new(); + $parser->parse_from_file( $0, File::Spec->devnull ); + } + 1; +}); + +exit 0; + +__END__ + +=head1 EXAMPLE + +This test makes sure the parse_from_file is re-entrant + +=cut + diff --git a/cpan/Pod-Parser/t/pod/usage.pod b/cpan/Pod-Parser/t/pod/usage.pod deleted file mode 100644 index c81cc82c51..0000000000 --- a/cpan/Pod-Parser/t/pod/usage.pod +++ /dev/null @@ -1,18 +0,0 @@ -=head1 NAME - -usage.pod - example for testing USAGE and SYNOPSIS - -=head1 USAGE - -This is a test for CPAN#33020 - -=head1 SYNOPSIS - -And this will be also printed. - -=head1 OPTIONS - -And this with verbose == 1 - -=cut - diff --git a/cpan/Pod-Parser/t/pod/usage2.pod b/cpan/Pod-Parser/t/pod/usage2.pod deleted file mode 100644 index 5c4817b8b1..0000000000 --- a/cpan/Pod-Parser/t/pod/usage2.pod +++ /dev/null @@ -1,56 +0,0 @@ -=head1 Heading-1 - -=over 100 - -=item One - -=item Two - -=back - -=head2 Heading 2 - -Some text - -=head1 BugHeader - -Some text - -=head2 BugHeader2 - -=over 4 - -=item More - -=item Still More - -=back - -=head1 Heading-2 - -=head2 Heading-2.2 - -More text. - -=head1 OPTIONS AND ARGUMENTS - -=head2 Arguments - -The required arguments (which typically follow any options on the -command line) are: - -=over - -=item I - -=item I - -=back - -=head2 Options - -Options may be abbreviated. Options which take values may be separated -from the values by whitespace or the "=" character. - -=cut - diff --git a/cpan/Pod-Usage/.gitignore b/cpan/Pod-Usage/.gitignore new file mode 100644 index 0000000000..523ffa1970 --- /dev/null +++ b/cpan/Pod-Usage/.gitignore @@ -0,0 +1 @@ +/pod2usage* diff --git a/cpan/Pod-Usage/lib/Pod/Usage.pm b/cpan/Pod-Usage/lib/Pod/Usage.pm new file mode 100644 index 0000000000..e09d69e89b --- /dev/null +++ b/cpan/Pod-Usage/lib/Pod/Usage.pm @@ -0,0 +1,767 @@ +############################################################################# +# Pod/Usage.pm -- print usage messages for the running script. +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Usage; +use strict; + +use vars qw($VERSION @ISA @EXPORT); +$VERSION = '1.61'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +#use diagnostics; +use Carp; +use Config; +use Exporter; +use File::Spec; + +@EXPORT = qw(&pod2usage); +BEGIN { + $Pod::Usage::Formatter ||= + ( $] >= 5.005_58 ? 'Pod::Text' : 'Pod::PlainText'); + eval "require $Pod::Usage::Formatter"; + die $@ if $@; + @ISA = ( $Pod::Usage::Formatter ); +} + +require Pod::Select; + +##--------------------------------------------------------------------------- + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub pod2usage { + local($_) = shift; + my %opts; + ## Collect arguments + if (@_ > 0) { + ## Too many arguments - assume that this is a hash and + ## the user forgot to pass a reference to it. + %opts = ($_, @_); + } + elsif (!defined $_) { + $_ = ''; + } + elsif (ref $_) { + ## User passed a ref to a hash + %opts = %{$_} if (ref($_) eq 'HASH'); + } + elsif (/^[-+]?\d+$/) { + ## User passed in the exit value to use + $opts{'-exitval'} = $_; + } + else { + ## User passed in a message to print before issuing usage. + $_ and $opts{'-message'} = $_; + } + + ## Need this for backward compatibility since we formerly used + ## options that were all uppercase words rather than ones that + ## looked like Unix command-line options. + ## to be uppercase keywords) + %opts = map { + my ($key, $val) = ($_, $opts{$_}); + $key =~ s/^(?=\w)/-/; + $key =~ /^-msg/i and $key = '-message'; + $key =~ /^-exit/i and $key = '-exitval'; + lc($key) => $val; + } (keys %opts); + + ## Now determine default -exitval and -verbose values to use + if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { + $opts{'-exitval'} = 2; + $opts{'-verbose'} = 0; + } + elsif (! defined $opts{'-exitval'}) { + $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; + } + elsif (! defined $opts{'-verbose'}) { + $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || + $opts{'-exitval'} < 2); + } + + ## Default the output file + $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || + $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR + unless (defined $opts{'-output'}); + ## Default the input file + $opts{'-input'} = $0 unless (defined $opts{'-input'}); + + ## Look up input file in path if it doesnt exist. + unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { + my $basename = $opts{'-input'}; + my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' + : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); + my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; + + my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); + for my $dirname (@paths) { + $_ = File::Spec->catfile($dirname, $basename) if length; + last if (-e $_) && ($opts{'-input'} = $_); + } + } + + ## Now create a pod reader and constrain it to the desired sections. + my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); + if ($opts{'-verbose'} == 0) { + $parser->select('(?:SYNOPSIS|USAGE)\s*'); + } + elsif ($opts{'-verbose'} == 1) { + my $opt_re = '(?i)' . + '(?:OPTIONS|ARGUMENTS)' . + '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; + $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); + } + elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { + $parser->select('.*'); + } + elsif ($opts{'-verbose'} == 99) { + my $sections = $opts{'-sections'}; + $parser->select( (ref $sections) ? @$sections : $sections ); + $opts{'-verbose'} = 1; + } + + ## Check for perldoc + my $progpath = File::Spec->catfile($Config{scriptdirexp} + || $Config{scriptdir}, 'perldoc'); + + my $version = sprintf("%vd",$^V); + if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) { + $progpath .= $version; + } + $opts{'-noperldoc'} = 1 unless -e $progpath; + + ## Now translate the pod document and then exit with the desired status + if ( !$opts{'-noperldoc'} + and $opts{'-verbose'} >= 2 + and !ref($opts{'-input'}) + and $opts{'-output'} == \*STDOUT ) + { + ## spit out the entire PODs. Might as well invoke perldoc + print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); + if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { + # the perldocs back to 5.005 should all have -F + # without -F there are warnings in -T scripts + system($progpath, '-F', $1); + if($?) { + # RT16091: fall back to more if perldoc failed + system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); + } + } else { + croak "Unspecified input file or insecure argument.\n"; + } + } + else { + $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); + } + + exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + if ($self->can('initialize')) { + $self->initialize(); + } else { + # pass through options to Pod::Text + my %opts; + for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) { + my $val = $params{USAGE_OPTIONS}{"-$_"}; + $opts{$_} = $val if defined $val; + } + $self = $self->SUPER::new(%opts); + %$self = (%$self, %params); + } + return $self; +} + +sub select { + my ($self, @sections) = @_; + if ($ISA[0]->can('select')) { + $self->SUPER::select(@sections); + } else { + # we're using Pod::Simple - need to mimic the behavior of Pod::Select + my $add = ($sections[0] eq '+') ? shift(@sections) : ''; + ## Reset the set of sections to use + unless (@sections) { + delete $self->{USAGE_SELECT} unless ($add); + return; + } + $self->{USAGE_SELECT} = [] + unless ($add && $self->{USAGE_SELECT}); + my $sref = $self->{USAGE_SELECT}; + ## Compile each spec + for my $spec (@sections) { + my $cs = Pod::Select::_compile_section_spec($spec); + if ( defined $cs ) { + ## Store them in our sections array + push(@$sref, $cs); + } else { + carp qq{Ignoring section spec "$spec"!\n}; + } + } + } +} + +# Override Pod::Text->seq_i to return just "arg", not "*arg*". +sub seq_i { return $_[1] } + +# This overrides the Pod::Text method to do something very akin to what +# Pod::Select did as well as the work done below by preprocess_paragraph. +# Note that the below is very, very specific to Pod::Text. +sub _handle_element_end { + my ($self, $element) = @_; + if ($element eq 'head1') { + $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; + if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { + $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; + } + } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 + my $idx = $1 - 1; + $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); + $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; + } + if ($element =~ /^head\d+$/) { + $$self{USAGE_SKIPPING} = 1; + if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { + $$self{USAGE_SKIPPING} = 0; + } else { + my @headings = @{$$self{USAGE_HEADINGS}}; + for my $section_spec ( @{$$self{USAGE_SELECT}} ) { + my $match = 1; + for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) { + $headings[$i] = '' unless defined $headings[$i]; + my $regex = $section_spec->[$i]; + my $negated = ($regex =~ s/^\!//); + $match &= ($negated ? ($headings[$i] !~ /${regex}/) + : ($headings[$i] =~ /${regex}/)); + last unless ($match); + } # end heading levels + if ($match) { + $$self{USAGE_SKIPPING} = 0; + last; + } + } # end sections + } + + # Try to do some lowercasing instead of all-caps in headings, and use + # a colon to end all headings. + if($self->{USAGE_OPTIONS}->{-verbose} < 2) { + local $_ = $$self{PENDING}[-1][1]; + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + s/\s*$/:/ unless (/:\s*$/); + $_ .= "\n"; + $$self{PENDING}[-1][1] = $_; + } + } + if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { + pop @{ $$self{PENDING} }; + } else { + $self->SUPER::_handle_element_end($element); + } +} + +# required for Pod::Simple API +sub start_document { + my $self = shift; + $self->SUPER::start_document(); + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_fh(); + print $out_fh "$msg\n"; +} + +# required for old Pod::Parser API +sub begin_pod { + my $self = shift; + $self->SUPER::begin_pod(); ## Have to call superclass + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_handle(); + print $out_fh "$msg\n"; +} + +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + my $line = shift; + ## See if this is a heading and we arent printing the entire manpage. + if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { + ## Change the title of the SYNOPSIS section to USAGE + s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; + ## Try to do some lowercasing instead of all-caps in headings + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + ## Use a colon to end all headings + s/\s*$/:/ unless (/:\s*$/); + $_ .= "\n"; + } + return $self->SUPER::preprocess_paragraph($_); +} + +1; # keep require happy + +__END__ + +=head1 NAME + +Pod::Usage, pod2usage() - print a usage message from embedded pod documentation + +=head1 SYNOPSIS + + use Pod::Usage + + my $message_text = "This text precedes the usage message."; + my $exit_status = 2; ## The exit status to use + my $verbose_level = 0; ## The verbose level to use + my $filehandle = \*STDERR; ## The filehandle to write to + + pod2usage($message_text); + + pod2usage($exit_status); + + pod2usage( { -message => $message_text , + -exitval => $exit_status , + -verbose => $verbose_level, + -output => $filehandle } ); + + pod2usage( -msg => $message_text , + -exitval => $exit_status , + -verbose => $verbose_level, + -output => $filehandle ); + + pod2usage( -verbose => 2, + -noperldoc => 1 ) + +=head1 ARGUMENTS + +B should be given either a single argument, or a list of +arguments corresponding to an associative array (a "hash"). When a single +argument is given, it should correspond to exactly one of the following: + +=over 4 + +=item * + +A string containing the text of a message to print I printing +the usage message + +=item * + +A numeric value corresponding to the desired exit status + +=item * + +A reference to a hash + +=back + +If more than one argument is given then the entire argument list is +assumed to be a hash. If a hash is supplied (either as a reference or +as a list) it should contain one or more elements with the following +keys: + +=over 4 + +=item C<-message> + +=item C<-msg> + +The text of a message to print immediately prior to printing the +program's usage message. + +=item C<-exitval> + +The desired exit status to pass to the B function. +This should be an integer, or else the string "NOEXIT" to +indicate that control should simply be returned without +terminating the invoking process. + +=item C<-verbose> + +The desired level of "verboseness" to use when printing the usage +message. If the corresponding value is 0, then only the "SYNOPSIS" +section of the pod documentation is printed. If the corresponding value +is 1, then the "SYNOPSIS" section, along with any section entitled +"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the +corresponding value is 2 or more then the entire manpage is printed. + +The special verbosity level 99 requires to also specify the -sections +parameter; then these sections are extracted (see L) +and printed. + +=item C<-sections> + +A string representing a selection list for sections to be printed +when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. + +Alternatively, an array reference of section specifications can be used: + + pod2usage(-verbose => 99, + -sections => [ qw(fred fred/subsection) ] ); + +=item C<-output> + +A reference to a filehandle, or the pathname of a file to which the +usage message should be written. The default is C<\*STDERR> unless the +exit value is less than 2 (in which case the default is C<\*STDOUT>). + +=item C<-input> + +A reference to a filehandle, or the pathname of a file from which the +invoking script's pod documentation should be read. It defaults to the +file indicated by C<$0> (C<$PROGRAM_NAME> for users of F). + +If you are calling B from a module and want to display +that module's POD, you can use this: + + use Pod::Find qw(pod_where); + pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) ); + +=item C<-pathlist> + +A list of directory paths. If the input file does not exist, then it +will be searched for in the given directory list (in the order the +directories appear in the list). It defaults to the list of directories +implied by C<$ENV{PATH}>. The list may be specified either by a reference +to an array, or by a string of directory paths which use the same path +separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for +MSWin32 and DOS). + +=item C<-noperldoc> + +By default, Pod::Usage will call L when -verbose >= 2 is +specified. This does not work well e.g. if the script was packed +with L. The -noperldoc option suppresses the external call to +L and uses the simple text formatter (L) to +output the POD. + +=back + +=head2 Formatting base class + +The default text formatter depends on the Perl version (L or +L for Perl versions E 5.005_58). The base class for +Pod::Usage can be defined by pre-setting C<$Pod::Usage::Formatter> I +loading Pod::Usage, e.g.: + + BEGIN { $Pod::Usage::Formatter = 'Pod::Text::Termcap'; } + use Pod::Usage qw(pod2usage); + +=head2 Pass-through options + +The following options are passed through to the underlying text formatter. +See the manual pages of these modules for more information. + + alt code indent loose margin quotes sentence stderr utf8 width + +=head1 DESCRIPTION + +B will print a usage message for the invoking script (using +its embedded pod documentation) and then exit the script with the +desired exit status. The usage message printed may have any one of three +levels of "verboseness": If the verbose level is 0, then only a synopsis +is printed. If the verbose level is 1, then the synopsis is printed +along with a description (if present) of the command line options and +arguments. If the verbose level is 2, then the entire manual page is +printed. + +Unless they are explicitly specified, the default values for the exit +status, verbose level, and output stream to use are determined as +follows: + +=over 4 + +=item * + +If neither the exit status nor the verbose level is specified, then the +default is to use an exit status of 2 with a verbose level of 0. + +=item * + +If an exit status I specified but the verbose level is I, then the +verbose level will default to 1 if the exit status is less than 2 and +will default to 0 otherwise. + +=item * + +If an exit status is I specified but verbose level I given, then +the exit status will default to 2 if the verbose level is 0 and will +default to 1 otherwise. + +=item * + +If the exit status used is less than 2, then output is printed on +C. Otherwise output is printed on C. + +=back + +Although the above may seem a bit confusing at first, it generally does +"the right thing" in most situations. This determination of the default +values to use is based upon the following typical Unix conventions: + +=over 4 + +=item * + +An exit status of 0 implies "success". For example, B exits +with a status of 0 if the two files have the same contents. + +=item * + +An exit status of 1 implies possibly abnormal, but non-defective, program +termination. For example, B exits with a status of 1 if +it did I find a matching line for the given regular expression. + +=item * + +An exit status of 2 or more implies a fatal error. For example, B +exits with a status of 2 if you specify an illegal (unknown) option on +the command line. + +=item * + +Usage messages issued as a result of bad command-line syntax should go +to C. However, usage messages issued due to an explicit request +to print usage (like specifying B<-help> on the command line) should go +to C, just in case the user wants to pipe the output to a pager +(such as B). + +=item * + +If program usage has been explicitly requested by the user, it is often +desirable to exit with a status of 1 (as opposed to 0) after issuing +the user-requested usage message. It is also desirable to give a +more verbose description of program usage in this case. + +=back + +B doesn't force the above conventions upon you, but it will +use them by default if you don't expressly tell it to do otherwise. The +ability of B to accept a single number or a string makes it +convenient to use as an innocent looking error message handling function: + + use Pod::Usage; + use Getopt::Long; + + ## Parse options + GetOptions("help", "man", "flag1") || pod2usage(2); + pod2usage(1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## Check for too many filenames + pod2usage("$0: Too many files given.\n") if (@ARGV > 1); + +Some user's however may feel that the above "economy of expression" is +not particularly readable nor consistent and may instead choose to do +something more like the following: + + use Pod::Usage; + use Getopt::Long; + + ## Parse options + GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); + pod2usage(-verbose => 1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## Check for too many filenames + pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") + if (@ARGV > 1); + +As with all things in Perl, I, and +B adheres to this philosophy. If you are interested in +seeing a number of different ways to invoke B (although by no +means exhaustive), please refer to L<"EXAMPLES">. + +=head1 EXAMPLES + +Each of the following invocations of C will print just the +"SYNOPSIS" section to C and will exit with a status of 2: + + pod2usage(); + + pod2usage(2); + + pod2usage(-verbose => 0); + + pod2usage(-exitval => 2); + + pod2usage({-exitval => 2, -output => \*STDERR}); + + pod2usage({-verbose => 0, -output => \*STDERR}); + + pod2usage(-exitval => 2, -verbose => 0); + + pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR); + +Each of the following invocations of C will print a message +of "Syntax error." (followed by a newline) to C, immediately +followed by just the "SYNOPSIS" section (also printed to C) and +will exit with a status of 2: + + pod2usage("Syntax error."); + + pod2usage(-message => "Syntax error.", -verbose => 0); + + pod2usage(-msg => "Syntax error.", -exitval => 2); + + pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR}); + + pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR}); + + pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0); + + pod2usage(-message => "Syntax error.", + -exitval => 2, + -verbose => 0, + -output => \*STDERR); + +Each of the following invocations of C will print the +"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to +C and will exit with a status of 1: + + pod2usage(1); + + pod2usage(-verbose => 1); + + pod2usage(-exitval => 1); + + pod2usage({-exitval => 1, -output => \*STDOUT}); + + pod2usage({-verbose => 1, -output => \*STDOUT}); + + pod2usage(-exitval => 1, -verbose => 1); + + pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT}); + +Each of the following invocations of C will print the +entire manual page to C and will exit with a status of 1: + + pod2usage(-verbose => 2); + + pod2usage({-verbose => 2, -output => \*STDOUT}); + + pod2usage(-exitval => 1, -verbose => 2); + + pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT}); + +=head2 Recommended Use + +Most scripts should print some type of usage message to C when a +command line syntax error is detected. They should also provide an +option (usually C<-H> or C<-help>) to print a (possibly more verbose) +usage message to C. Some scripts may even wish to go so far as to +provide a means of printing their complete documentation to C +(perhaps by allowing a C<-man> option). The following complete example +uses B in combination with B to do all of these +things: + + use Getopt::Long; + use Pod::Usage; + + my $man = 0; + my $help = 0; + ## Parse options and print usage if there is a syntax error, + ## or if usage was explicitly requested. + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-verbose => 2) if $man; + + ## If no arguments were given, then allow STDIN to be used only + ## if it's not connected to a terminal (otherwise print usage) + pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); + __END__ + + =head1 NAME + + sample - Using GetOpt::Long and Pod::Usage + + =head1 SYNOPSIS + + sample [options] [file ...] + + Options: + -help brief help message + -man full documentation + + =head1 OPTIONS + + =over 8 + + =item B<-help> + + Print a brief help message and exits. + + =item B<-man> + + Prints the manual page and exits. + + =back + + =head1 DESCRIPTION + + B will read the given input file(s) and do something + useful with the contents thereof. + + =cut + +=head1 CAVEATS + +By default, B will use C<$0> as the path to the pod input +file. Unfortunately, not all systems on which Perl runs will set C<$0> +properly (although if C<$0> isn't found, B will search +C<$ENV{PATH}> or else the list specified by the C<-pathlist> option). +If this is the case for your system, you may need to explicitly specify +the path to the pod docs for the invoking script using something +similar to the following: + + pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); + +In the pathological case that a script is called via a relative path +I the script itself changes the current working directory +(see L) I calling pod2usage, Pod::Usage will +fail even on robust platforms. Don't do that. Or use L to locate +the script: + + use FindBin; + pod2usage(-input => $FindBin::Bin . "/" . $FindBin::Script); + +=head1 AUTHOR + +Please report bugs using L. + +Marek Rouchal Emarekr@cpan.orgE + +Brad Appleton Ebradapp@enteract.comE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +=head1 ACKNOWLEDGMENTS + +Steven McDougall Eswmcd@world.std.comE for his help and patience +with re-writing this manpage. + +=head1 SEE ALSO + +B is now a standalone distribution. + +L, L, L, L, L, +L, L, L + +=cut + diff --git a/cpan/Pod-Usage/scripts/pod2usage.PL b/cpan/Pod-Usage/scripts/pod2usage.PL new file mode 100644 index 0000000000..0d8459072f --- /dev/null +++ b/cpan/Pod-Usage/scripts/pod2usage.PL @@ -0,0 +1,190 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir(dirname($0)); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +############################################################################# +# pod2usage -- command to print usage messages from embedded pod docs +# +# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +use strict; +#use diagnostics; + +=head1 NAME + +pod2usage - print usage messages from embedded pod docs in files + +=head1 SYNOPSIS + +=over 12 + +=item B + +[B<-help>] +[B<-man>] +[B<-exit>S< >I] +[B<-output>S< >I] +[B<-verbose> I] +[B<-pathlist> I] +[B<-formatter> I] +I + +=back + +=head1 OPTIONS AND ARGUMENTS + +=over 8 + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print this command's manual page and exit. + +=item B<-exit> I + +The exit status value to return. + +=item B<-output> I + +The output file to print to. If the special names "-" or ">&1" or ">&STDOUT" +are used then standard output is used. If ">&2" or ">&STDERR" is used then +standard error is used. + +=item B<-verbose> I + +The desired level of verbosity to use: + + 1 : print SYNOPSIS only + 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections + 3 : print the entire manpage (similar to running pod2text) + +=item B<-pathlist> I + +Specifies one or more directories to search for the input file if it +was not supplied with an absolute path. Each directory path in the given +list should be separated by a ':' on Unix (';' on MSWin32 and DOS). + +=item B<-formatter> I + +Which text formatter to use. Default is L, or for very old +Perl versions L. An alternative would be e.g. +L. + +=item I + +The pathname of a file containing pod documentation to be output in +usage message format (defaults to standard input). + +=back + +=head1 DESCRIPTION + +B will read the given input file looking for pod +documentation and will print the corresponding usage message. +If no input file is specified then standard input is read. + +B invokes the B function in the B +module. Please see L. + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Please report bugs using L. + +Brad Appleton Ebradapp@enteract.comE + +Based on code for B written by +Tom Christiansen Etchrist@mox.perl.comE + +=cut + +use Getopt::Long; + +## Define options +my %options = (); +my @opt_specs = ( + 'help', + 'man', + 'exit=i', + 'output=s', + 'pathlist=s', + 'formatter=s', + 'verbose=i', +); + +## Parse options +GetOptions(\%options, @opt_specs) || pod2usage(2); +$Pod::Usage::Formatter = $options{formatter} if $options{formatter}; +require Pod::Usage; +Pod::Usage->import(); +pod2usage(1) if ($options{help}); +pod2usage(VERBOSE => 2) if ($options{man}); + +## Dont default to STDIN if connected to a terminal +pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); + +@ARGV = ('-') unless (@ARGV); +if (@ARGV > 1) { + print STDERR "pod2usage: Too many filenames given\n\n"; + pod2usage(2); +} + +my %usage = (); +$usage{-input} = shift(@ARGV); +$usage{-exitval} = $options{'exit'} if (defined $options{'exit'}); +$usage{-output} = $options{'output'} if (defined $options{'output'}); +$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'}); +$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'}); + +pod2usage(\%usage); + + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/cpan/Pod-Usage/t/pod/p2u_data.pl b/cpan/Pod-Usage/t/pod/p2u_data.pl new file mode 100644 index 0000000000..858cc56cb2 --- /dev/null +++ b/cpan/Pod-Usage/t/pod/p2u_data.pl @@ -0,0 +1,18 @@ +use Pod::Usage; +pod2usage(-verbose => 2, -exit => 17, -input => \*DATA); + +__DATA__ +=head1 NAME + +Test + +=head1 SYNOPSIS + +perl podusagetest.pl + +=head1 DESCRIPTION + +This is a test. + +=cut + diff --git a/cpan/Pod-Usage/t/pod/pod2usage.t b/cpan/Pod-Usage/t/pod/pod2usage.t new file mode 100644 index 0000000000..98788fc399 --- /dev/null +++ b/cpan/Pod-Usage/t/pod/pod2usage.t @@ -0,0 +1,18 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + +=include pod2usage.PL + + diff --git a/cpan/Pod-Usage/t/pod/pod2usage.xr b/cpan/Pod-Usage/t/pod/pod2usage.xr new file mode 100644 index 0000000000..ceac4f1f82 --- /dev/null +++ b/cpan/Pod-Usage/t/pod/pod2usage.xr @@ -0,0 +1,63 @@ +###### begin =include pod2usage.PL ##### +NAME + pod2usage - print usage messages from embedded pod docs in files + +SYNOPSIS + pod2usage [-help] [-man] [-exit *exitval*] [-output *outfile*] + [-verbose *level*] [-pathlist *dirlist*] [-formatter + *module*] *file* + +OPTIONS AND ARGUMENTS + -help Print a brief help message and exit. + + -man Print this command's manual page and exit. + + -exit *exitval* + The exit status value to return. + + -output *outfile* + The output file to print to. If the special names "-" or ">&1" + or ">&STDOUT" are used then standard output is used. If ">&2" or + ">&STDERR" is used then standard error is used. + + -verbose *level* + The desired level of verbosity to use: + + 1 : print SYNOPSIS only + 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections + 3 : print the entire manpage (similar to running pod2text) + + -pathlist *dirlist* + Specifies one or more directories to search for the input file + if it was not supplied with an absolute path. Each directory + path in the given list should be separated by a ':' on Unix (';' + on MSWin32 and DOS). + + -formatter *module* + Which text formatter to use. Default is the Pod::Text manpage, + or for very old Perl versions the Pod::PlainText manpage. An + alternative would be e.g. the Pod::Text::Termcap manpage. + + *file* The pathname of a file containing pod documentation to be output + in usage message format (defaults to standard input). + +DESCRIPTION + pod2usage will read the given input file looking for pod documentation + and will print the corresponding usage message. If no input file is + specified then standard input is read. + + pod2usage invokes the pod2usage() function in the Pod::Usage module. + Please see the pod2usage() entry in the Pod::Usage manpage. + +SEE ALSO + the Pod::Usage manpage, the pod2text(1) manpage + +AUTHOR + Please report bugs using http://rt.cpan.org. + + Brad Appleton + + Based on code for pod2text(1) written by Tom Christiansen + + +###### end =include pod2usage.PL ##### diff --git a/cpan/Pod-Usage/t/pod/pod2usage2.t b/cpan/Pod-Usage/t/pod/pod2usage2.t new file mode 100644 index 0000000000..a2b0a32f97 --- /dev/null +++ b/cpan/Pod-Usage/t/pod/pod2usage2.t @@ -0,0 +1,357 @@ +#!/usr/bin/perl -w + +use Test::More; +use strict; + +BEGIN { + if ($^O eq 'MSWin32' || $^O eq 'VMS') { + plan skip_all => "Not portable on Win32 or VMS\n"; + } + else { + plan tests => 34; + } + use_ok ("Pod::Usage"); +} + +sub getoutput +{ + my ($code) = @_; + my $pid = open(TEST_IN, "-|"); + unless(defined $pid) { + die "Cannot fork: $!"; + } + if($pid) { + # parent + my @out = ; + close(TEST_IN); + my $exit = $?>>8; + s/^/#/ for @out; + local $" = ""; + print "#EXIT=$exit OUTPUT=+++#@out#+++\n"; + return($exit, join("",@out)); + } + # child + open(STDERR, ">&STDOUT"); + Test::More->builder->no_ending(1); + &$code; + print "--NORMAL-RETURN--\n"; + exit 0; +} + +sub compare +{ + my ($left,$right) = @_; + $left =~ s/^#\s+/#/gm; + $right =~ s/^#\s+/#/gm; + $left =~ s/\s+/ /gm; + $right =~ s/\s+/ /gm; + $left eq $right; +} + +SKIP: { +if('Pod::Usage'->isa('Pod::Text') && $Pod::Text::VERSION < 2.18) { + skip("Formatting with Pod::Text $Pod::Text::VERSION not reliable", 33); +} + +my ($exit, $text) = getoutput( sub { pod2usage() } ); +is ($exit, 2, "Exit status pod2usage ()"); +ok (compare ($text, <<'EOT'), "Output test pod2usage ()"); +#Usage: +# frobnicate [ -r | --recursive ] [ -f | --force ] file ... +# +EOT + +($exit, $text) = getoutput( sub { pod2usage( + -message => 'You naughty person, what did you say?', + -verbose => 1 ) }); +is ($exit, 1, "Exit status pod2usage (-message => '...', -verbose => 1)"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)") or diag("Got:\n$text\n"); +#You naughty person, what did you say? +# Usage: +# frobnicate [ -r | --recursive ] [ -f | --force ] file ... +# +# Options: +# -r | --recursive +# Run recursively. +# +# -f | --force +# Just do it! +# +# -n number +# Specify number of frobs, default is 42. +# +EOT + +($exit, $text) = getoutput( sub { pod2usage( + -verbose => 2, -exit => 42 ) } ); +is ($exit, 42, "Exit status pod2usage (-verbose => 2, -exit => 42)"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -exit => 42)"); +#NAME +# frobnicate - do what I mean +# +# SYNOPSIS +# frobnicate [ -r | --recursive ] [ -f | --force ] file ... +# +# DESCRIPTION +# frobnicate does foo and bar and what not. +# +# OPTIONS +# -r | --recursive +# Run recursively. +# +# -f | --force +# Just do it! +# +# -n number +# Specify number of frobs, default is 42. +# +EOT + +($exit, $text) = getoutput( sub { pod2usage(0) } ); +is ($exit, 0, "Exit status pod2usage (0)"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (0)"); +#Usage: +# frobnicate [ -r | --recursive ] [ -f | --force ] file ... +# +# Options: +# -r | --recursive +# Run recursively. +# +# -f | --force +# Just do it! +# +# -n number +# Specify number of frobs, default is 42. +# +EOT + +($exit, $text) = getoutput( sub { pod2usage(42) } ); +is ($exit, 42, "Exit status pod2usage (42)"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (42)"); +#Usage: +# frobnicate [ -r | --recursive ] [ -f | --force ] file ... +# +EOT + +($exit, $text) = getoutput( sub { pod2usage(-verbose => 0, -exit => 'NOEXIT') } ); +is ($exit, 0, "Exit status pod2usage (-verbose => 0, -exit => 'NOEXIT')"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 0, -exit => 'NOEXIT')"); +#Usage: +# frobnicate [ -r | --recursive ] [ -f | --force ] file ... +# +# --NORMAL-RETURN-- +EOT + +($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION') } ); +is ($exit, 1, "Exit status pod2usage (-verbose => 99, -sections => 'DESCRIPTION')"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 99, -sections => 'DESCRIPTION')"); +#Description: +# frobnicate does foo and bar and what not. +# +EOT + +# does the __DATA__ work ok as input +my (@blib, $test_script, $pod_file1, , $pod_file2); +if (!$ENV{PERL_CORE}) { + @blib = '-Mblib'; +} +$test_script = File::Spec->catfile(qw(t pod p2u_data.pl)); +$pod_file1 = File::Spec->catfile(qw(t pod usage.pod)); +$pod_file2 = File::Spec->catfile(qw(t pod usage2.pod)); + + +($exit, $text) = getoutput( sub { system($^X, @blib, $test_script); exit($? >> 8); } ); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 17, "Exit status pod2usage (-verbose => 2, -input => \*DATA)"); +ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -input => \*DATA)") or diag "Got:\n$text\n"; +#NAME +# Test +# +#SYNOPSIS +# perl podusagetest.pl +# +#DESCRIPTION +# This is a test. +# +EOT + +# test that SYNOPSIS and USAGE are printed +($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1, + -exitval => 0, -verbose => 0); }); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with USAGE"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE") or diag "Got:\n$text\n"; +#Usage: +# This is a test for CPAN#33020 +# +#Usage: +# And this will be also printed. +# +EOT + +# test that SYNOPSIS and USAGE are printed with options +($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1, + -exitval => 0, -verbose => 1); }); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with USAGE and verbose=1"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=1") or diag "Got:\n$text\n"; +#Usage: +# This is a test for CPAN#33020 +# +#Usage: +# And this will be also printed. +# +#Options: +# And this with verbose == 1 +# +EOT + +# test that only USAGE is printed when requested +($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1, + -exitval => 0, -verbose => 99, -sections => 'USAGE'); }); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with USAGE and verbose=99"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n"; +#Usage: +# This is a test for CPAN#33020 +# +EOT + +# test with pod_where +use_ok('Pod::Find', qw(pod_where)); + +($exit, $text) = getoutput( sub { pod2usage( -input => pod_where({-inc => 1}, 'Pod::Usage'), + -exitval => 0, -verbose => 0) } ); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with Pod::Find"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with Pod::Find") or diag "Got:\n$text\n"; +#Usage: +# use Pod::Usage +# +# my $message_text = "This text precedes the usage message."; +# my $exit_status = 2; ## The exit status to use +# my $verbose_level = 0; ## The verbose level to use +# my $filehandle = \*STDERR; ## The filehandle to write to +# +# pod2usage($message_text); +# +# pod2usage($exit_status); +# +# pod2usage( { -message => $message_text , +# -exitval => $exit_status , +# -verbose => $verbose_level, +# -output => $filehandle } ); +# +# pod2usage( -msg => $message_text , +# -exitval => $exit_status , +# -verbose => $verbose_level, +# -output => $filehandle ); +# +# pod2usage( -verbose => 2, +# -noperldoc => 1 ) +# +EOT + +# verify that sections are correctly found after nested headings +($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file2, + -exitval => 0, -verbose => 99, + -sections => [qw(BugHeader BugHeader/.*')]) }); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with nested headings"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with nested headings") or diag "Got:\n$text\n"; +#BugHeader: +# Some text +# +# BugHeader2: +# More +# Still More +# +EOT + +# Verify that =over =back work OK +($exit, $text) = getoutput( sub { + pod2usage(-input => $pod_file2, + -exitval => 0, -verbose => 99, -sections => 'BugHeader/BugHeader2') } ); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with over/back"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with over/back") or diag "Got:\n$text\n"; +# BugHeader2: +# More +# Still More +# +EOT + +# new array API for -sections +($exit, $text) = getoutput( sub { + pod2usage(-input => $pod_file2, + -exitval => 0, -verbose => 99, -sections => [qw(Heading-1/!.+ Heading-2/.+)]) } ); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +is ($exit, 0, "Exit status pod2usage with -sections => []"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with -sections => []") or diag "Got:\n$text\n"; +#Heading-1: +# One +# Two +# +# Heading-2.2: +# More text. +# +EOT + +# allow subheadings in OPTIONS and ARGUMENTS +($exit, $text) = getoutput( sub { + pod2usage(-input => $pod_file2, + -exitval => 0, -verbose => 1) } ); +$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR +$text =~ s{[*](destination|files)[*]}{$1}g; # strip * chars +is ($exit, 0, "Exit status pod2usage with subheadings in OPTIONS"); +ok (compare ($text, <<'EOT'), "Output test pod2usage with subheadings in OPTIONS") or diag "Got:\n$text\n"; +#Options and Arguments: +# Arguments: +# The required arguments (which typically follow any options on the +# command line) are: +# +# destination +# files +# +# Options: +# Options may be abbreviated. Options which take values may be separated +# from the values by whitespace or the "=" character. +# +EOT +} # end SKIP + +__END__ + +=head1 NAME + +frobnicate - do what I mean + +=head1 SYNOPSIS + +B S<[ B<-r> | B<--recursive> ]> S<[ B<-f> | B<--force> ]> + file ... + +=head1 DESCRIPTION + +B does foo and bar and what not. + +=head1 OPTIONS + +=over 4 + +=item B<-r> | B<--recursive> + +Run recursively. + +=item B<-f> | B<--force> + +Just do it! + +=item B<-n> number + +Specify number of frobs, default is 42. + +=back + +=cut + diff --git a/cpan/Pod-Usage/t/pod/testcmp.pl b/cpan/Pod-Usage/t/pod/testcmp.pl new file mode 100644 index 0000000000..b8592fcc2a --- /dev/null +++ b/cpan/Pod-Usage/t/pod/testcmp.pl @@ -0,0 +1,94 @@ +package TestCompare; + +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +use File::Basename; +use File::Spec; +use FileHandle; + +@ISA = qw(Exporter); +@EXPORT = qw(&testcmp); +$MYPKG = eval { (caller)[0] }; + +##-------------------------------------------------------------------------- + +=head1 NAME + +testcmp -- compare two files line-by-line + +=head1 SYNOPSIS + + $is_diff = testcmp($file1, $file2); + +or + + $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); + +=head2 DESCRIPTION + +Compare two text files line-by-line and return 0 if they are the +same, 1 if they differ. Each of $file1 and $file2 may be a filenames, +or a filehandles (in which case it must already be open for reading). + +If the first argument is a hashref, then the B<-cmplines> key in the +hash may have a subroutine reference as its corresponding value. +The referenced user-defined subroutine should be a line-comparator +function that takes two pre-chomped text-lines as its arguments +(the first is from $file1 and the second is from $file2). It should +return 0 if it considers the two lines equivalent, and non-zero +otherwise. + +=cut + +##-------------------------------------------------------------------------- + +sub testcmp( $ $ ; $) { + my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); + my ($file1, $file2) = @_; + my ($fh1, $fh2) = ($file1, $file2); + unless (ref $fh1) { + $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; + } + unless (ref $fh2) { + $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; + } + + my $cmplines = $opts{'-cmplines'} || undef; + my ($f1text, $f2text) = ("", ""); + my ($line, $diffs) = (0, 0); + + while ( defined($f1text) and defined($f2text) ) { + defined($f1text = <$fh1>) and chomp($f1text); + defined($f2text = <$fh2>) and chomp($f2text); + ++$line; + last unless ( defined($f1text) and defined($f2text) ); + # kill any extra line endings + $f1text =~ s/[\r\n]+$//s; + $f2text =~ s/[\r\n]+$//s; + $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) + : ($f1text ne $f2text); + last if $diffs; + } + close($fh1) unless (ref $file1); + close($fh2) unless (ref $file2); + + $diffs = 1 if (defined($f1text) or defined($f2text)); + if ( defined($f1text) and defined($f2text) ) { + ## these two lines must be different + warn "$file1 and $file2 differ at line $line\n"; + } + elsif (defined($f1text) and (! defined($f1text))) { + ## file1 must be shorter + warn "$file1 is shorter than $file2\n"; + } + elsif (defined $f2text) { + ## file2 must be longer + warn "$file1 is shorter than $file2\n"; + } + return $diffs; +} + +1; diff --git a/cpan/Pod-Usage/t/pod/testp2pt.pl b/cpan/Pod-Usage/t/pod/testp2pt.pl new file mode 100644 index 0000000000..5c17300b50 --- /dev/null +++ b/cpan/Pod-Usage/t/pod/testp2pt.pl @@ -0,0 +1,192 @@ +package TestPodIncPlainText; + +BEGIN { + use File::Basename; + use File::Spec; + use Cwd qw(abs_path); + push @INC, '..'; + my $THISDIR = abs_path(dirname $0); + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); +} + +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; +#use Cwd qw(abs_path); + +use vars qw($MYPKG @EXPORT @ISA); +$MYPKG = eval { (caller)[0] }; +@EXPORT = qw(&testpodplaintext); +BEGIN { + require Pod::PlainText; + @ISA = qw( Pod::PlainText ); + require VMS::Filespec if $^O eq 'VMS'; +} + +## Hardcode settings for TERMCAP and COLUMNS so we can try to get +## reproducible results between environments +@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); + +sub catfile(@) { File::Spec->catfile(@_); } + +my $INSTDIR = abs_path(dirname $0); +$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; +$INSTDIR =~ s#/$## if $^O eq 'VMS'; +$INSTDIR =~ s#:$## if $^O eq 'MacOS'; +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); +$INSTDIR =~ s#:$## if $^O eq 'MacOS'; +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); +my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), + catfile($INSTDIR, 'scripts'), + catfile($INSTDIR, 'pod'), + catfile($INSTDIR, 't', 'pod') + ); + +# FIXME - we should make the core capable of finding utilities built in +# locations in ext. +push @PODINCDIRS, catfile((File::Spec->updir()) x 2, 'pod') if $ENV{PERL_CORE}; + +## Find the path to the file to =include +sub findinclude { + my $self = shift; + my $incname = shift; + + ## See if its already found w/out any "searching; + return $incname if (-r $incname); + + ## Need to search for it. Look in the following directories ... + ## 1. the directory containing this pod file + my $thispoddir = dirname $self->input_file; + ## 2. the parent directory of the above + my $parentdir = dirname $thispoddir; + my @podincdirs = ($thispoddir, $parentdir, @PODINCDIRS); + + for (@podincdirs) { + my $incfile = catfile($_, $incname); + return $incfile if (-r $incfile); + } + warn("*** Can't find =include file $incname in @podincdirs\n"); + return ""; +} + +sub command { + my $self = shift; + my ($cmd, $text, $line_num, $pod_para) = @_; + $cmd = '' unless (defined $cmd); + local $_ = $text || ''; + my $out_fh = $self->output_handle; + + ## Defer to the superclass for everything except '=include' + return $self->SUPER::command(@_) unless ($cmd eq "include"); + + ## We have an '=include' command + my $incdebug = 1; ## debugging + my @incargs = split; + if (@incargs == 0) { + warn("*** No filename given for '=include'\n"); + return; + } + my $incfile = $self->findinclude(shift @incargs) or return; + my $incbase = basename $incfile; + print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); + $self->parse_from_file( {-cutting => 1}, $incfile ); + print $out_fh "###### end =include $incbase #####\n" if ($incdebug); +} + +sub begin_input { + $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS'; +} + +sub podinc2plaintext( $ $ ) { + my ($infile, $outfile) = @_; + local $_; + my $text_parser = $MYPKG->new; + $text_parser->parse_from_file($infile, $outfile); +} + +sub testpodinc2plaintext( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $cmpfile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "# Running testpodinc2plaintext for '$testname'...\n"; + ## Compare the output against the expected result + podinc2plaintext($infile, $outfile); + if ( testcmp($outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodplaintext( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "# Creating expected result for \"$testname\"" . + " pod2plaintext test ...\n"; + podinc2plaintext($podfile, $cmpfile); + } + else { + print "# File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodinc2plaintext + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "#\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "#\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/cpan/Pod-Usage/t/pod/usage.pod b/cpan/Pod-Usage/t/pod/usage.pod new file mode 100644 index 0000000000..c0fbbc528e --- /dev/null +++ b/cpan/Pod-Usage/t/pod/usage.pod @@ -0,0 +1,18 @@ +=head1 NAME + +usage.pod - example for testing USAGE and SYNOPSIS + +=head1 USAGE + +This is a test for CPAN#33020 + +=head1 SYNOPSIS + +And this will be also printed. + +=head1 OPTIONS + +And this with verbose == 1 + +=cut + diff --git a/cpan/Pod-Usage/t/pod/usage2.pod b/cpan/Pod-Usage/t/pod/usage2.pod new file mode 100644 index 0000000000..1e03b7dfc6 --- /dev/null +++ b/cpan/Pod-Usage/t/pod/usage2.pod @@ -0,0 +1,56 @@ +=head1 Heading-1 + +=over 100 + +=item One + +=item Two + +=back + +=head2 Heading 2 + +Some text + +=head1 BugHeader + +Some text + +=head2 BugHeader2 + +=over 4 + +=item More + +=item Still More + +=back + +=head1 Heading-2 + +=head2 Heading-2.2 + +More text. + +=head1 OPTIONS AND ARGUMENTS + +=head2 Arguments + +The required arguments (which typically follow any options on the +command line) are: + +=over + +=item I + +=item I + +=back + +=head2 Options + +Options may be abbreviated. Options which take values may be separated +from the values by whitespace or the "=" character. + +=cut + -- cgit v1.2.1