diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod')
60 files changed, 32412 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Checker.pm new file mode 100644 index 00000000000..a2305423b23 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Checker.pm @@ -0,0 +1,1268 @@ +############################################################################# +# 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.45'; ## 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<gt> I<val> + +Turn warnings on/off. I<val> is usually 1 for on, but higher values +trigger additional warnings. See L<"Warnings">. + +=back + +=head1 DESCRIPTION + +B<podchecker> will perform syntax checking of Perl5 POD format documentation. + +Curious/ambitious users are welcome to propose additional features they wish +to see in B<Pod::Checker> and B<podchecker> and verify that the checks are +consistent with L<perlpod>. + +The following checks are currently performed: + +=over 4 + +=item * + +Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences, +and unterminated interior sequences. + +=item * + +Check for proper balancing of C<=begin> and C<=end>. The contents of such +a block are generally ignored, i.e. no syntax checks are performed. + +=item * + +Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. + +=item * + +Check for same nested interior-sequences (e.g. +C<LE<lt>...LE<lt>...E<gt>...E<gt>>). + +=item * + +Check for malformed or non-existing entities C<EE<lt>...E<gt>>. + +=item * + +Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod> +for details. + +=item * + +Check for unresolved document-internal links. This check may also reveal +misspelled links that seem to be internal links but should be links +to something else. + +=back + +=head1 DIAGNOSTICS + +=head2 Errors + +=over 4 + +=item * empty =headn + +A heading (C<=head1> or C<=head2>) without any text? That ain't no +heading! + +=item * =over on line I<N> without closing =back + +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 * unresolved internal link I<NAME> + +The given link to I<NAME> does not have a matching node in the current +POD. This also happened when a single word node name is not enclosed in +C<"">. + +=item * Unknown command "I<CMD>" + +An invalid POD command has been found. Valid are C<=head1>, C<=head2>, +C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, +C<=for>, C<=pod>, C<=cut> + +=item * Unknown interior-sequence "I<SEQ>" + +An invalid markup command has been encountered. Valid are: +C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>, +C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>, +C<ZE<lt>E<gt>> + +=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt> + +Two nested identical markup commands have been found. Generally this +does not make sense. + +=item * garbled entity I<STRING> + +The I<STRING> 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 LE<lt>E<gt> + +The link found cannot be parsed because it does not conform to the +syntax described in L<perlpod>. + +=item * nonempty ZE<lt>E<gt> + +The C<ZE<lt>E<gt>> sequence is supposed to be empty. + +=item * empty XE<lt>E<gt> + +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 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<name> + +The POD file has some C<=item> and/or C<=head> commands that have +the same text. Potential hyperlinks to such a text cannot be unique then. +This warning is printed only with warning level greater than one. + +=item * line containing nothing but whitespace in paragraph + +There is some whitespace on a seemingly empty line. POD is very sensitive +to such things, so this is flagged. B<vi> users switch on the B<list> +option to avoid this problem. + +=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<one> vs. I<two>) + +A list started with e.g. a bullet-like C<=item> and continued with a +numbered one. This is obviously inconsistent. For most translators the +type of the I<first> C<=item> determines the type of the list. + +=item * I<N> unescaped C<E<lt>E<gt>> in paragraph + +Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>> +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<verbar> and C<sol>. + +=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<n> without preceding higher level + +For example if there is a C<=head2> in the POD file prior to a +C<=head1>. + +=back + +=head2 Hyperlinks + +There are some warnings with respect to malformed hyperlinks: + +=over 4 + +=item * ignoring leading/trailing whitespace in link + +There is whitespace at the beginning or the end of the contents of +LE<lt>...E<gt>. + +=item * (section) in '$page' deprecated + +There is a section detected in the page name of LE<lt>...E<gt>, e.g. +C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only. +Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able +to expand this to appropriate code. For links to (builtin) functions, +please say C<LE<lt>perlfunc/mkdirE<gt>>, without (). + +=item * alternative text/node '%s' contains non-escaped | or / + +The characters C<|> and C</> are special in the LE<lt>...E<gt> context. +Although the hyperlink parser does its best to determine which "/" is +text and which is a delimiter in case of doubt, one ought to escape +these literal characters like this: + + / E<sol> + | E<verbar> + +=back + +=head1 RETURN VALUE + +B<podchecker> returns the number of POD syntax errors found or -1 if +there were no POD commands at all found in the file. + +=head1 EXAMPLES + +See L</SYNOPSIS> + +=head1 INTERFACE + +While checking, this module collects document properties, e.g. the nodes +for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>). +POD translators can use this feature to syntax-check and get the nodes in +a first pass before actually starting to convert. This is expensive in terms +of execution time, but allows for very robust conversions. + +Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror> +method to print errors and warnings. The summary output (e.g. +"Pod syntax OK") has been dropped from the module and has been included in +B<podchecker> (the script). This allows users of B<Pod::Checker> to +control completely the output behavior. Users of B<podchecker> (the script) +get the well-known behavior. + +=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 C<Pod::Checker-E<gt>new( %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<gt> num> + Print warnings if C<num> is true. The higher the value of C<num>, +the more warnings are printed. Currently there are only levels 1 and 2. + +C<-quiet =E<gt> num> + If C<num> is true, do not print any errors/warnings. This is useful +when Pod::Checker is used to munge POD code into plain text from within +POD formatters. + +=cut + +## sub new { +## my $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-E<gt>poderror( @args )> + +=item C<$checker-E<gt>poderror( {%opts}, @args )> + +Internal method for printing errors and warnings. If no options are +given, simply prints "@_". The following options are recognized and used +to form the output: + + -msg + +A message to print prior to C<@args>. + + -line + +The line number the error occurred in. + + -file + +The file (name) the error occurred in. + + -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-E<gt>num_errors()> + +Set (if argument specified) and retrieve the number of errors found. + +=cut + +sub num_errors { + return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; +} + +################################## + +=item C<$checker-E<gt>num_warnings()> + +Set (if argument specified) and retrieve the number of warnings found. + +=cut + +sub num_warnings { + return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS}; +} + +################################## + +=item C<$checker-E<gt>name()> + +Set (if argument specified) and retrieve the canonical name of POD as +found in the C<=head1 NAME> section. + +=cut + +sub name { + return (@_ > 1 && $_[1]) ? + ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; +} + +################################## + +=item C<$checker-E<gt>node()> + +Add (if argument specified) and retrieve the nodes (as defined by C<=headX> +and C<=item>) of the current POD. The nodes are returned in the order of +their occurrence. They consist of plain text, each piece of whitespace is +collapsed to a single blank. + +=cut + +sub node { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_nodes}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_nodes}}; +} + +################################## + +=item C<$checker-E<gt>idx()> + +Add (if argument specified) and retrieve the index entries (as defined by +C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece +of whitespace is collapsed to a single blank. + +=cut + +# set/return index entries of current POD +sub idx { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_index}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_index}}; +} + +################################## + +=item C<$checker-E<gt>hyperlink()> + +Add (if argument specified) and retrieve the hyperlinks (as defined by +C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line +number and C<Pod::Hyperlink> 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<Tk::Pod/"DESCRIPTION"> + 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 + + ##### 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"}); + } + } + $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($nestlist =~ /$cmd/) { + $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); + + 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); + + # 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; + } + } +} + +1; + +__END__ + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version), +Marek Rouchal E<lt>marekr@cpan.orgE<gt> + +Based on code for B<Pod::Text::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Escapes.pm b/Master/tlpkg/tlperl/lib/Pod/Escapes.pm new file mode 100644 index 00000000000..de4d75a7b83 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Escapes.pm @@ -0,0 +1,721 @@ + +require 5; +# The documentation is at the end. +# Time-stamp: "2004-05-07 15:31:25 ADT" +package Pod::Escapes; +require Exporter; +@ISA = ('Exporter'); +$VERSION = '1.04'; +@EXPORT_OK = qw( + %Code2USASCII + %Name2character + %Name2character_number + %Latin1Code_to_fallback + %Latin1Char_to_fallback + e2char + e2charnum +); +%EXPORT_TAGS = ('ALL' => \@EXPORT_OK); + +#========================================================================== + +use strict; +use vars qw( + %Code2USASCII + %Name2character + %Name2character_number + %Latin1Code_to_fallback + %Latin1Char_to_fallback + $FAR_CHAR + $FAR_CHAR_NUMBER + $NOT_ASCII +); + +$FAR_CHAR = "?" unless defined $FAR_CHAR; +$FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER; + +$NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII; + +#-------------------------------------------------------------------------- +sub e2char { + my $in = $_[0]; + return undef unless defined $in and length $in; + + # Convert to decimal: + if($in =~ m/^(0[0-7]*)$/s ) { + $in = oct $in; + } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) { + $in = hex $1; + } # else it's decimal, or named + + if($NOT_ASCII) { + # We're in bizarro world of not-ASCII! + # Cope with US-ASCII codes, use fallbacks for Latin-1, or use FAR_CHAR. + unless($in =~ m/^\d+$/s) { + # It's a named character reference. Get its numeric Unicode value. + $in = $Name2character{$in}; + return undef unless defined $in; # (if there's no such name) + $in = ord $in; # (All ents must be one character long.) + # ...So $in holds the char's US-ASCII numeric value, which we'll + # now go get the local equivalent for. + } + + # It's numeric, whether by origin or by mutation from a known name + return $Code2USASCII{$in} # so "65" => "A" everywhere + || $Latin1Code_to_fallback{$in} # Fallback. + || $FAR_CHAR; # Fall further back + } + + # Normal handling: + if($in =~ m/^\d+$/s) { + if($] < 5.007 and $in > 255) { # can't be trusted with Unicode + return $FAR_CHAR; + } else { + return chr($in); + } + } else { + return $Name2character{$in}; # returns undef if unknown + } +} + +#-------------------------------------------------------------------------- +sub e2charnum { + my $in = $_[0]; + return undef unless defined $in and length $in; + + # Convert to decimal: + if($in =~ m/^(0[0-7]*)$/s ) { + $in = oct $in; + } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) { + $in = hex $1; + } # else it's decimal, or named + + if($in =~ m/^\d+$/s) { + return 0 + $in; + } else { + return $Name2character_number{$in}; # returns undef if unknown + } +} + +#-------------------------------------------------------------------------- + +%Name2character_number = ( + # General XML/XHTML: + 'lt' => 60, + 'gt' => 62, + 'quot' => 34, + 'amp' => 38, + 'apos' => 39, + + # POD-specific: + 'sol' => 47, + 'verbar' => 124, + + 'lchevron' => 171, # legacy for laquo + 'rchevron' => 187, # legacy for raquo + + # Remember, grave looks like \ (as in virtu\) + # acute looks like / (as in re/sume/) + # circumflex looks like ^ (as in papier ma^che/) + # umlaut/dieresis looks like " (as in nai"ve, Chloe") + + # From the XHTML 1 .ent files: + 'nbsp' , 160, + 'iexcl' , 161, + 'cent' , 162, + 'pound' , 163, + 'curren' , 164, + 'yen' , 165, + 'brvbar' , 166, + 'sect' , 167, + 'uml' , 168, + 'copy' , 169, + 'ordf' , 170, + 'laquo' , 171, + 'not' , 172, + 'shy' , 173, + 'reg' , 174, + 'macr' , 175, + 'deg' , 176, + 'plusmn' , 177, + 'sup2' , 178, + 'sup3' , 179, + 'acute' , 180, + 'micro' , 181, + 'para' , 182, + 'middot' , 183, + 'cedil' , 184, + 'sup1' , 185, + 'ordm' , 186, + 'raquo' , 187, + 'frac14' , 188, + 'frac12' , 189, + 'frac34' , 190, + 'iquest' , 191, + 'Agrave' , 192, + 'Aacute' , 193, + 'Acirc' , 194, + 'Atilde' , 195, + 'Auml' , 196, + 'Aring' , 197, + 'AElig' , 198, + 'Ccedil' , 199, + 'Egrave' , 200, + 'Eacute' , 201, + 'Ecirc' , 202, + 'Euml' , 203, + 'Igrave' , 204, + 'Iacute' , 205, + 'Icirc' , 206, + 'Iuml' , 207, + 'ETH' , 208, + 'Ntilde' , 209, + 'Ograve' , 210, + 'Oacute' , 211, + 'Ocirc' , 212, + 'Otilde' , 213, + 'Ouml' , 214, + 'times' , 215, + 'Oslash' , 216, + 'Ugrave' , 217, + 'Uacute' , 218, + 'Ucirc' , 219, + 'Uuml' , 220, + 'Yacute' , 221, + 'THORN' , 222, + 'szlig' , 223, + 'agrave' , 224, + 'aacute' , 225, + 'acirc' , 226, + 'atilde' , 227, + 'auml' , 228, + 'aring' , 229, + 'aelig' , 230, + 'ccedil' , 231, + 'egrave' , 232, + 'eacute' , 233, + 'ecirc' , 234, + 'euml' , 235, + 'igrave' , 236, + 'iacute' , 237, + 'icirc' , 238, + 'iuml' , 239, + 'eth' , 240, + 'ntilde' , 241, + 'ograve' , 242, + 'oacute' , 243, + 'ocirc' , 244, + 'otilde' , 245, + 'ouml' , 246, + 'divide' , 247, + 'oslash' , 248, + 'ugrave' , 249, + 'uacute' , 250, + 'ucirc' , 251, + 'uuml' , 252, + 'yacute' , 253, + 'thorn' , 254, + 'yuml' , 255, + + 'fnof' , 402, + 'Alpha' , 913, + 'Beta' , 914, + 'Gamma' , 915, + 'Delta' , 916, + 'Epsilon' , 917, + 'Zeta' , 918, + 'Eta' , 919, + 'Theta' , 920, + 'Iota' , 921, + 'Kappa' , 922, + 'Lambda' , 923, + 'Mu' , 924, + 'Nu' , 925, + 'Xi' , 926, + 'Omicron' , 927, + 'Pi' , 928, + 'Rho' , 929, + 'Sigma' , 931, + 'Tau' , 932, + 'Upsilon' , 933, + 'Phi' , 934, + 'Chi' , 935, + 'Psi' , 936, + 'Omega' , 937, + 'alpha' , 945, + 'beta' , 946, + 'gamma' , 947, + 'delta' , 948, + 'epsilon' , 949, + 'zeta' , 950, + 'eta' , 951, + 'theta' , 952, + 'iota' , 953, + 'kappa' , 954, + 'lambda' , 955, + 'mu' , 956, + 'nu' , 957, + 'xi' , 958, + 'omicron' , 959, + 'pi' , 960, + 'rho' , 961, + 'sigmaf' , 962, + 'sigma' , 963, + 'tau' , 964, + 'upsilon' , 965, + 'phi' , 966, + 'chi' , 967, + 'psi' , 968, + 'omega' , 969, + 'thetasym' , 977, + 'upsih' , 978, + 'piv' , 982, + 'bull' , 8226, + 'hellip' , 8230, + 'prime' , 8242, + 'Prime' , 8243, + 'oline' , 8254, + 'frasl' , 8260, + 'weierp' , 8472, + 'image' , 8465, + 'real' , 8476, + 'trade' , 8482, + 'alefsym' , 8501, + 'larr' , 8592, + 'uarr' , 8593, + 'rarr' , 8594, + 'darr' , 8595, + 'harr' , 8596, + 'crarr' , 8629, + 'lArr' , 8656, + 'uArr' , 8657, + 'rArr' , 8658, + 'dArr' , 8659, + 'hArr' , 8660, + 'forall' , 8704, + 'part' , 8706, + 'exist' , 8707, + 'empty' , 8709, + 'nabla' , 8711, + 'isin' , 8712, + 'notin' , 8713, + 'ni' , 8715, + 'prod' , 8719, + 'sum' , 8721, + 'minus' , 8722, + 'lowast' , 8727, + 'radic' , 8730, + 'prop' , 8733, + 'infin' , 8734, + 'ang' , 8736, + 'and' , 8743, + 'or' , 8744, + 'cap' , 8745, + 'cup' , 8746, + 'int' , 8747, + 'there4' , 8756, + 'sim' , 8764, + 'cong' , 8773, + 'asymp' , 8776, + 'ne' , 8800, + 'equiv' , 8801, + 'le' , 8804, + 'ge' , 8805, + 'sub' , 8834, + 'sup' , 8835, + 'nsub' , 8836, + 'sube' , 8838, + 'supe' , 8839, + 'oplus' , 8853, + 'otimes' , 8855, + 'perp' , 8869, + 'sdot' , 8901, + 'lceil' , 8968, + 'rceil' , 8969, + 'lfloor' , 8970, + 'rfloor' , 8971, + 'lang' , 9001, + 'rang' , 9002, + 'loz' , 9674, + 'spades' , 9824, + 'clubs' , 9827, + 'hearts' , 9829, + 'diams' , 9830, + 'OElig' , 338, + 'oelig' , 339, + 'Scaron' , 352, + 'scaron' , 353, + 'Yuml' , 376, + 'circ' , 710, + 'tilde' , 732, + 'ensp' , 8194, + 'emsp' , 8195, + 'thinsp' , 8201, + 'zwnj' , 8204, + 'zwj' , 8205, + 'lrm' , 8206, + 'rlm' , 8207, + 'ndash' , 8211, + 'mdash' , 8212, + 'lsquo' , 8216, + 'rsquo' , 8217, + 'sbquo' , 8218, + 'ldquo' , 8220, + 'rdquo' , 8221, + 'bdquo' , 8222, + 'dagger' , 8224, + 'Dagger' , 8225, + 'permil' , 8240, + 'lsaquo' , 8249, + 'rsaquo' , 8250, + 'euro' , 8364, +); + + +# Fill out %Name2character... +{ + %Name2character = (); + my($name, $number); + while( ($name, $number) = each %Name2character_number) { + if($] < 5.007 and $number > 255) { + $Name2character{$name} = $FAR_CHAR; + # substitute for Unicode characters, for perls + # that can't reliable handle them + } else { + $Name2character{$name} = chr $number; + # normal case + } + } + # So they resolve 'right' even in EBCDIC-land + $Name2character{'lt' } = '<'; + $Name2character{'gt' } = '>'; + $Name2character{'quot'} = '"'; + $Name2character{'amp' } = '&'; + $Name2character{'apos'} = "'"; + $Name2character{'sol' } = '/'; + $Name2character{'verbar'} = '|'; +} + +#-------------------------------------------------------------------------- + +%Code2USASCII = ( +# mostly generated by +# perl -e "printf qq{ \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)" + 32, ' ', + 33, '!', + 34, '"', + 35, '#', + 36, '$', + 37, '%', + 38, '&', + 39, "'", #! + 40, '(', + 41, ')', + 42, '*', + 43, '+', + 44, ',', + 45, '-', + 46, '.', + 47, '/', + 48, '0', + 49, '1', + 50, '2', + 51, '3', + 52, '4', + 53, '5', + 54, '6', + 55, '7', + 56, '8', + 57, '9', + 58, ':', + 59, ';', + 60, '<', + 61, '=', + 62, '>', + 63, '?', + 64, '@', + 65, 'A', + 66, 'B', + 67, 'C', + 68, 'D', + 69, 'E', + 70, 'F', + 71, 'G', + 72, 'H', + 73, 'I', + 74, 'J', + 75, 'K', + 76, 'L', + 77, 'M', + 78, 'N', + 79, 'O', + 80, 'P', + 81, 'Q', + 82, 'R', + 83, 'S', + 84, 'T', + 85, 'U', + 86, 'V', + 87, 'W', + 88, 'X', + 89, 'Y', + 90, 'Z', + 91, '[', + 92, "\\", #! + 93, ']', + 94, '^', + 95, '_', + 96, '`', + 97, 'a', + 98, 'b', + 99, 'c', + 100, 'd', + 101, 'e', + 102, 'f', + 103, 'g', + 104, 'h', + 105, 'i', + 106, 'j', + 107, 'k', + 108, 'l', + 109, 'm', + 110, 'n', + 111, 'o', + 112, 'p', + 113, 'q', + 114, 'r', + 115, 's', + 116, 't', + 117, 'u', + 118, 'v', + 119, 'w', + 120, 'x', + 121, 'y', + 122, 'z', + 123, '{', + 124, '|', + 125, '}', + 126, '~', +); + +#-------------------------------------------------------------------------- + +%Latin1Code_to_fallback = (); +@Latin1Code_to_fallback{0xA0 .. 0xFF} = ( +# Copied from Text/Unidecode/x00.pm: + +' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-}, +'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?}, +'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I', +'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss', +'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i', +'d', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y', + +); + +{ + # Now stuff %Latin1Char_to_fallback: + %Latin1Char_to_fallback = (); + my($k,$v); + while( ($k,$v) = each %Latin1Code_to_fallback) { + $Latin1Char_to_fallback{chr $k} = $v; + #print chr($k), ' => ', $v, "\n"; + } +} + +#-------------------------------------------------------------------------- +1; +__END__ + +=head1 NAME + +Pod::Escapes -- for resolving Pod EE<lt>...E<gt> sequences + +=head1 SYNOPSIS + + use Pod::Escapes qw(e2char); + ...la la la, parsing POD, la la la... + $text = e2char($e_node->label); + unless(defined $text) { + print "Unknown E sequence \"", $e_node->label, "\"!"; + } + ...else print/interpolate $text... + +=head1 DESCRIPTION + +This module provides things that are useful in decoding +Pod EE<lt>...E<gt> sequences. Presumably, it should be used +only by Pod parsers and/or formatters. + +By default, Pod::Escapes exports none of its symbols. But +you can request any of them to be exported. +Either request them individually, as with +C<use Pod::Escapes qw(symbolname symbolname2...);>, +or you can do C<use Pod::Escapes qw(:ALL);> to get all +exportable symbols. + +=head1 GOODIES + +=over + +=item e2char($e_content) + +Given a name or number that could appear in a +C<EE<lt>name_or_numE<gt>> sequence, this returns the string that +it stands for. For example, C<e2char('sol')>, C<e2char('47')>, +C<e2char('0x2F')>, and C<e2char('057')> all return "/", +because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>, +and C<EE<lt>057E<gt>>, all mean "/". If +the name has no known value (as with a name of "qacute") or is +syntactally invalid (as with a name of "1/4"), this returns undef. + +=item e2charnum($e_content) + +Given a name or number that could appear in a +C<EE<lt>name_or_numE<gt>> sequence, this returns the number of +the Unicode character that this stands for. For example, +C<e2char('sol')>, C<e2char('47')>, +C<e2char('0x2F')>, and C<e2char('057')> all return 47, +because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>, +and C<EE<lt>057E<gt>>, all mean "/", whose Unicode number is 47. If +the name has no known value (as with a name of "qacute") or is +syntactally invalid (as with a name of "1/4"), this returns undef. + +=item $Name2character{I<name>} + +Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol" +to the string that each stands for. Note that this does not +include numerics (like "64" or "x981c"). Under old Perl versions +(before 5.7) you get a "?" in place of characters whose Unicode +value is over 255. + +=item $Name2character_number{I<name>} + +Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol" +to the Unicode value that each stands for. For example, +C<$Name2character_number{'eacute'}> is 201, and +C<$Name2character_number{'eacute'}> is 8364. You get the correct +Unicode value, regardless of the version of Perl you're using -- +which differs from C<%Name2character>'s behavior under pre-5.7 Perls. + +Note that this hash does not +include numerics (like "64" or "x981c"). + +=item $Latin1Code_to_fallback{I<integer>} + +For numbers in the range 160 (0x00A0) to 255 (0x00FF), this maps +from the character code for a Latin-1 character (like 233 for +lowercase e-acute) to the US-ASCII character that best aproximates +it (like "e"). You may find this useful if you are rendering +POD in a format that you think deals well only with US-ASCII +characters. + +=item $Latin1Char_to_fallback{I<character>} + +Just as above, but maps from characters (like "\xE9", +lowercase e-acute) to characters (like "e"). + +=item $Code2USASCII{I<integer>} + +This maps from US-ASCII codes (like 32) to the corresponding +character (like space, for 32). Only characters 32 to 126 are +defined. This is meant for use by C<e2char($x)> when it senses +that it's running on a non-ASCII platform (where chr(32) doesn't +get you a space -- but $Code2USASCII{32} will). It's +documented here just in case you might find it useful. + +=back + +=head1 CAVEATS + +On Perl versions before 5.7, Unicode characters with a value +over 255 (like lambda or emdash) can't be conveyed. This +module does work under such early Perl versions, but in the +place of each such character, you get a "?". Latin-1 +characters (characters 160-255) are unaffected. + +Under EBCDIC platforms, C<e2char($n)> may not always be the +same as C<chr(e2charnum($n))>, and ditto for +C<$Name2character{$name}> and +C<chr($Name2character_number{$name})>. + +=head1 SEE ALSO + +L<perlpod|perlpod> + +L<perlpodspec|perlpodspec> + +L<Text::Unidecode|Text::Unidecode> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2001-2004 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +Portions of the data tables in this module are derived from the +entity declarations in the W3C XHTML specification. + +Currently (October 2001), that's these three: + + http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent + http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent + http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# What I used for reading the XHTML .ent files: + +use strict; +my(@norms, @good, @bad); +my $dir = 'c:/sgml/docbook/'; +my %escapes; +foreach my $file (qw( + xhtml-symbol.ent + xhtml-lat1.ent + xhtml-special.ent +)) { + open(IN, "<$dir$file") or die "can't read-open $dir$file: $!"; + print "Reading $file...\n"; + while(<IN>) { + if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) { + my($name, $value) = ($1,$2); + next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt'; + + $value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s; + print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s; + if($value > 255) { + push @good , sprintf " %-10s , chr(%s),\n", "'$name'", $value; + push @bad , sprintf " %-10s , \$bad,\n", "'$name'", $value; + } else { + push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value; + } + } elsif(m/<!ENT/) { + print "# Skipping $_"; + } + + } + close(IN); +} + +print @norms; +print "\n ( \$] .= 5.006001 ? (\n"; +print @good; +print " ) : (\n"; +print @bad; +print " )\n);\n"; + +__END__ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + diff --git a/Master/tlpkg/tlperl/lib/Pod/Find.pm b/Master/tlpkg/tlperl/lib/Pod/Find.pm new file mode 100644 index 00000000000..8d1103b6a1f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Find.pm @@ -0,0 +1,535 @@ +############################################################################# +# Pod/Find.pm -- finds files containing POD documentation +# +# Author: Marek Rouchal <marekr@cpan.org> +# +# 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.35'; ## 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<Pod::Find> 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<use> 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; + +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<pod_find( { %opts } , @directories )> + +The function B<pod_find> 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<MyModule>, +whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be +I<Myclass::Subclass>. 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<CPAN.pm> in different directories. This usually +indicates duplicate occurrences of modules in the I<@INC> search path. + +B<OPTIONS> The first argument for B<pod_find> 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<gt> 1> + +Print progress information while scanning. + +=item C<-perl =E<gt> 1> + +Apply Perl-specific heuristics to find the correct PODs. This includes +stripping Perl-like extensions, omitting subdirectories that are numeric +but do I<not> match the current Perl interpreter's version id, suppressing +F<site_perl> as a module hierarchy name etc. + +=item C<-script =E<gt> 1> + +Search for PODs in the current Perl interpreter's installation +B<scriptdir>. This is taken from the local L<Config|Config> module. + +=item C<-inc =E<gt> 1> + +Search for PODs in the current Perl interpreter's I<@INC> paths. This +automatically considers paths specified in the C<PERL5LIB> 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 { + push(@search, grep($_ ne File::Spec->curdir, @INC)); + } + + $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 + $try = File::Spec->canonpath($try) if ($^O ne 'VMS'); + $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS'); + 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/!; + 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//s; + $name =~ s/$SIMPLIFY_RX//s 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<simplify_name( $str )> + +The function B<simplify_name> is equivalent to B<basename>, 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 <t.jenness@jach.hawaii.edu> + +=head2 C<pod_where( { %opts }, $pod )> + +Returns the location of a pod document given a search directory +and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name. + +Options: + +=over 4 + +=item C<-inc =E<gt> 1> + +Search @INC for the pod and also the C<scriptdir> defined in the +L<Config|Config> module. + +=item C<-dirs =E<gt> [ $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<gt> 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<pod/> is also checked if it exists in any of the given +search directories. This ensures that e.g. L<perlfunc|perlfunc> 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); + 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<contains_pod( $file , $verbose )> + +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<http://rt.cpan.org>. + +Marek Rouchal E<lt>marekr@cpan.orgE<gt>, +heavily borrowing code from Nick Ing-Simmons' PodToHtml. + +Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided +C<pod_where> and C<contains_pod>. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Checker>, L<perldoc> + +=cut + +1; + diff --git a/Master/tlpkg/tlperl/lib/Pod/Functions.pm b/Master/tlpkg/tlperl/lib/Pod/Functions.pm new file mode 100644 index 00000000000..5181c3990bf --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Functions.pm @@ -0,0 +1,376 @@ +package Pod::Functions; +use strict; + +=head1 NAME + +Pod::Functions - Group Perl's functions a la perlfunc.pod + +=head1 SYNOPSIS + + use Pod::Functions; + + my @misc_ops = @{ $Kinds{ 'Misc' } }; + my $misc_dsc = $Type_Description{ 'Misc' }; + +or + + perl /path/to/lib/Pod/Functions.pm + +This will print a grouped list of Perl's functions, like the +L<perlfunc/"Perl Functions by Category"> section. + +=head1 DESCRIPTION + +It exports the following variables: + +=over 4 + +=item %Kinds + +This holds a hash-of-lists. Each list contains the functions in the category +the key denotes. + +=item %Type + +In this hash each key represents a function and the value is the category. +The category can be a comma separated list. + +=item %Flavor + +In this hash each key represents a function and the value is a short +description of that function. + +=item %Type_Description + +In this hash each key represents a category of functions and the value is +a short description of that category. + +=item @Type_Order + +This list of categories is used to produce the same order as the +L<perlfunc/"Perl Functions by Category"> section. + +=back + +=head1 CHANGES + +1.02 20020813 <abe@ztreet.demon.nl> + de-typo in the SYNOPSIS section (thanks Mike Castle for noticing) + +1.01 20011229 <abe@ztreet.demon.nl> + fixed some bugs that slipped in after 5.6.1 + added the pod + finished making it strict safe + +1.00 ?? + first numbered version + +=cut + +our $VERSION = '1.04'; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); + +our(%Kinds, %Type, %Flavor); + +our %Type_Description = ( + 'ARRAY' => 'Functions for real @ARRAYs', + 'Binary' => 'Functions for fixed length data or records', + 'File' => 'Functions for filehandles, files, or directories', + 'Flow' => 'Keywords related to control flow of your perl program', + 'HASH' => 'Functions for real %HASHes', + 'I/O' => 'Input and output functions', + 'LIST' => 'Functions for list data', + 'Math' => 'Numeric functions', + 'Misc' => 'Miscellaneous functions', + 'Modules' => 'Keywords related to perl modules', + 'Network' => 'Fetching network info', + 'Objects' => 'Keywords related to classes and object-orientedness', + 'Process' => 'Functions for processes and process groups', + 'Regexp' => 'Regular expressions and pattern matching', + 'Socket' => 'Low-level socket functions', + 'String' => 'Functions for SCALARs or strings', + 'SysV' => 'System V interprocess communication functions', + 'Time' => 'Time-related functions', + 'User' => 'Fetching user and group info', + 'Namespace' => 'Keywords altering or affecting scoping of identifiers', +); + +our @Type_Order = qw{ + String + Regexp + Math + ARRAY + LIST + HASH + I/O + Binary + File + Flow + Namespace + Misc + Process + Modules + Objects + Socket + SysV + User + Network + Time +}; + +while (<DATA>) { + chomp; + s/#.*//; + next unless $_; + my($name, $type, $text) = split " ", $_, 3; + $Type{$name} = $type; + $Flavor{$name} = $text; + for my $t ( split /[,\s]+/, $type ) { + push @{$Kinds{$t}}, $name; + } +} + +close DATA; + +my( $typedesc, $list ); +unless (caller) { + foreach my $type ( @Type_Order ) { + $list = join(", ", sort @{$Kinds{$type}}); + $typedesc = $Type_Description{$type} . ":"; + write; + } +} + +format = + +^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $typedesc +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $typedesc + ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $list +. + +1; + +__DATA__ +-X File a file test (-r, -x, etc) +abs Math absolute value function +accept Socket accept an incoming socket connect +alarm Process schedule a SIGALRM +atan2 Math arctangent of Y/X in the range -PI to PI +bind Socket binds an address to a socket +binmode I/O prepare binary files for I/O +bless Objects create an object +caller Flow,Namespace get context of the current subroutine call +chdir File change your current working directory +chmod File changes the permissions on a list of files +chomp String remove a trailing record separator from a string +chop String remove the last character from a string +chown File change the ownership on a list of files +chr String get character this number represents +chroot File make directory new root for path lookups +close I/O close file (or pipe or socket) handle +closedir I/O close directory handle +connect Socket connect to a remote socket +continue Flow optional trailing block in a while or foreach +cos Math cosine function +crypt String one-way passwd-style encryption +dbmclose Objects,I/O breaks binding on a tied dbm file +dbmopen Objects,I/O create binding on a tied dbm file +defined Misc test whether a value, variable, or function is defined +delete HASH deletes a value from a hash +die I/O,Flow raise an exception or bail out +do Flow,Modules turn a BLOCK into a TERM +dump Misc,Flow create an immediate core dump +each HASH retrieve the next key/value pair from a hash +endgrent User be done using group file +endhostent User be done using hosts file +endnetent User be done using networks file +endprotoent Network be done using protocols file +endpwent User be done using passwd file +endservent Network be done using services file +eof I/O test a filehandle for its end +eval Flow,Misc catch exceptions or compile and run code +exec Process abandon this program to run another +exists HASH test whether a hash key is present +exit Flow terminate this program +exp Math raise I<e> to a power +fcntl File file control system call +fileno I/O return file descriptor from filehandle +flock I/O lock an entire file with an advisory lock +fork Process create a new process just like this one +format I/O declare a picture format with use by the write() function +formline Misc internal function used for formats +getc I/O get the next character from the filehandle +getgrent User get next group record +getgrgid User get group record given group user ID +getgrnam User get group record given group name +gethostbyaddr Network get host record given its address +gethostbyname Network get host record given name +gethostent Network get next hosts record +getlogin User return who logged in at this tty +getnetbyaddr Network get network record given its address +getnetbyname Network get networks record given name +getnetent Network get next networks record +getpeername Socket find the other end of a socket connection +getpgrp Process get process group +getppid Process get parent process ID +getpriority Process get current nice value +getprotobyname Network get protocol record given name +getprotobynumber Network get protocol record numeric protocol +getprotoent Network get next protocols record +getpwent User get next passwd record +getpwnam User get passwd record given user login name +getpwuid User get passwd record given user ID +getservbyname Network get services record given its name +getservbyport Network get services record given numeric port +getservent Network get next services record +getsockname Socket retrieve the sockaddr for a given socket +getsockopt Socket get socket options on a given socket +glob File expand filenames using wildcards +gmtime Time convert UNIX time into record or string using Greenwich time +goto Flow create spaghetti code +grep LIST locate elements in a list test true against a given criterion +hex Math,String convert a string to a hexadecimal number +import Modules,Namespace patch a module's namespace into your own +index String find a substring within a string +int Math get the integer portion of a number +ioctl File system-dependent device control system call +join LIST join a list into a string using a separator +keys HASH retrieve list of indices from a hash +kill Process send a signal to a process or process group +last Flow exit a block prematurely +lc String return lower-case version of a string +lcfirst String return a string with just the next letter in lower case +length String return the number of bytes in a string +link File create a hard link in the filesystem +listen Socket register your socket as a server +local Misc,Namespace create a temporary value for a global variable (dynamic scoping) +localtime Time convert UNIX time into record or string using local time +lock Threads get a thread lock on a variable, subroutine, or method +log Math retrieve the natural logarithm for a number +lstat File stat a symbolic link +m// Regexp match a string with a regular expression pattern +map LIST apply a change to a list to get back a new list with the changes +mkdir File create a directory +msgctl SysV SysV IPC message control operations +msgget SysV get SysV IPC message queue +msgrcv SysV receive a SysV IPC message from a message queue +msgsnd SysV send a SysV IPC message to a message queue +my Misc,Namespace declare and assign a local variable (lexical scoping) +next Flow iterate a block prematurely +no Modules unimport some module symbols or semantics at compile time +package Modules,Objects,Namespace declare a separate global namespace +prototype Flow,Misc get the prototype (if any) of a subroutine +oct String,Math convert a string to an octal number +open File open a file, pipe, or descriptor +opendir File open a directory +ord String find a character's numeric representation +our Misc,Namespace declare and assign a package variable (lexical scoping) +pack Binary,String convert a list into a binary representation +pipe Process open a pair of connected filehandles +pop ARRAY remove the last element from an array and return it +pos Regexp find or set the offset for the last/next m//g search +print I/O output a list to a filehandle +printf I/O output a formatted list to a filehandle +push ARRAY append one or more elements to an array +q/STRING/ String singly quote a string +qq/STRING/ String doubly quote a string +quotemeta Regexp quote regular expression magic characters +qw/STRING/ LIST quote a list of words +qx/STRING/ Process backquote quote a string +qr/STRING/ Regexp Compile pattern +rand Math retrieve the next pseudorandom number +read I/O,Binary fixed-length buffered input from a filehandle +readdir I/O get a directory from a directory handle +readline I/O fetch a record from a file +readlink File determine where a symbolic link is pointing +readpipe Process execute a system command and collect standard output +recv Socket receive a message over a Socket +redo Flow start this loop iteration over again +ref Objects find out the type of thing being referenced +rename File change a filename +require Modules load in external functions from a library at runtime +reset Misc clear all variables of a given name +return Flow get out of a function early +reverse String,LIST flip a string or a list +rewinddir I/O reset directory handle +rindex String right-to-left substring search +rmdir File remove a directory +s/// Regexp replace a pattern with a string +scalar Misc force a scalar context +seek I/O reposition file pointer for random-access I/O +seekdir I/O reposition directory pointer +select I/O reset default output or do I/O multiplexing +semctl SysV SysV semaphore control operations +semget SysV get set of SysV semaphores +semop SysV SysV semaphore operations +send Socket send a message over a socket +setgrent User prepare group file for use +sethostent Network prepare hosts file for use +setnetent Network prepare networks file for use +setpgrp Process set the process group of a process +setpriority Process set a process's nice value +setprotoent Network prepare protocols file for use +setpwent User prepare passwd file for use +setservent Network prepare services file for use +setsockopt Socket set some socket options +shift ARRAY remove the first element of an array, and return it +shmctl SysV SysV shared memory operations +shmget SysV get SysV shared memory segment identifier +shmread SysV read SysV shared memory +shmwrite SysV write SysV shared memory +shutdown Socket close down just half of a socket connection +sin Math return the sine of a number +sleep Process block for some number of seconds +socket Socket create a socket +socketpair Socket create a pair of sockets +sort LIST sort a list of values +splice ARRAY add or remove elements anywhere in an array +split Regexp split up a string using a regexp delimiter +sprintf String formatted print into a string +sqrt Math square root function +srand Math seed the random number generator +stat File get a file's status information +study Regexp optimize input data for repeated searches +sub Flow declare a subroutine, possibly anonymously +substr String get or alter a portion of a string +symlink File create a symbolic link to a file +syscall I/O,Binary execute an arbitrary system call +sysopen File open a file, pipe, or descriptor +sysread I/O,Binary fixed-length unbuffered input from a filehandle +sysseek I/O,Binary position I/O pointer on handle used with sysread and syswrite +system Process run a separate program +syswrite I/O,Binary fixed-length unbuffered output to a filehandle +tell I/O get current seekpointer on a filehandle +telldir I/O get current seekpointer on a directory handle +tie Objects bind a variable to an object class +tied Objects get a reference to the object underlying a tied variable +time Time return number of seconds since 1970 +times Process,Time return elapsed time for self and child processes +tr/// String transliterate a string +truncate I/O shorten a file +uc String return upper-case version of a string +ucfirst String return a string with just the next letter in upper case +umask File set file creation mode mask +undef Misc remove a variable or function definition +unlink File remove one link to a file +unpack Binary,LIST convert binary structure into normal perl variables +unshift ARRAY prepend more elements to the beginning of a list +untie Objects break a tie binding to a variable +use Modules,Namespace load a module and import its namespace +use Objects load in a module at compile time +utime File set a file's last access and modify times +values HASH return a list of the values in a hash +vec Binary test or set particular bits in a string +wait Process wait for any child process to die +waitpid Process wait for a particular child process to die +wantarray Misc,Flow get void vs scalar vs list context of current subroutine call +warn I/O print debugging info +write I/O print a picture record +y/// String transliterate a string diff --git a/Master/tlpkg/tlperl/lib/Pod/Html.pm b/Master/tlpkg/tlperl/lib/Pod/Html.pm new file mode 100644 index 00000000000..6174dd74576 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Html.pm @@ -0,0 +1,2235 @@ +package Pod::Html; +use strict; +require Exporter; + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +$VERSION = 1.09; +@ISA = qw(Exporter); +@EXPORT = qw(pod2html htmlify); +@EXPORT_OK = qw(anchorify); + +use Carp; +use Config; +use Cwd; +use File::Spec; +use File::Spec::Unix; +use Getopt::Long; + +use locale; # make \w work right in non-ASCII lands + +=head1 NAME + +Pod::Html - module to convert pod files to HTML + +=head1 SYNOPSIS + + use Pod::Html; + pod2html([options]); + +=head1 DESCRIPTION + +Converts files from pod format (see L<perlpod>) to HTML format. It +can automatically generate indexes and cross-references, and it keeps +a cache of things it knows how to cross-reference. + +=head1 FUNCTIONS + +=head2 pod2html + + pod2html("pod2html", + "--podpath=lib:ext:pod:vms", + "--podroot=/usr/src/perl", + "--htmlroot=/perl/nmanual", + "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop", + "--recurse", + "--infile=foo.pod", + "--outfile=/perl/nmanual/foo.html"); + +pod2html takes the following arguments: + +=over 4 + +=item backlink + + --backlink="Back to Top" + +Adds "Back to Top" links in front of every C<head1> heading (except for +the first). By default, no backlinks are generated. + +=item cachedir + + --cachedir=name + +Creates the item and directory caches in the given directory. + +=item css + + --css=stylesheet + +Specify the URL of a cascading style sheet. Also disables all HTML/CSS +C<style> attributes that are output by default (to avoid conflicts). + +=item flush + + --flush + +Flushes the item and directory caches. + +=item header + + --header + --noheader + +Creates header and footer blocks containing the text of the C<NAME> +section. By default, no headers are generated. + +=item help + + --help + +Displays the usage message. + +=item hiddendirs + + --hiddendirs + --nohiddendirs + +Include hidden directories in the search for POD's in podpath if recurse +is set. +The default is not to traverse any directory whose name begins with C<.>. +See L</"podpath"> and L</"recurse">. + +[This option is for backward compatibility only. +It's hard to imagine that one would usefully create a module with a +name component beginning with C<.>.] + +=item htmldir + + --htmldir=name + +Sets the directory in which the resulting HTML file is placed. This +is used to generate relative links to other files. Not passing this +causes all links to be absolute, since this is the value that tells +Pod::Html the root of the documentation tree. + +=item htmlroot + + --htmlroot=name + +Sets the base URL for the HTML files. When cross-references are made, +the HTML root is prepended to the URL. + +=item index + + --index + --noindex + +Generate an index at the top of the HTML file. This is the default +behaviour. + +=item infile + + --infile=name + +Specify the pod file to convert. Input is taken from STDIN if no +infile is specified. + +=item libpods + + --libpods=name:...:name + +List of page names (eg, "perlfunc") which contain linkable C<=item>s. + +=item netscape + + --netscape + --nonetscape + +B<Deprecated>, has no effect. For backwards compatibility only. + +=item outfile + + --outfile=name + +Specify the HTML file to create. Output goes to STDOUT if no outfile +is specified. + +=item podpath + + --podpath=name:...:name + +Specify which subdirectories of the podroot contain pod files whose +HTML converted forms can be linked to in cross references. + +=item podroot + + --podroot=name + +Specify the base directory for finding library pods. + +=item quiet + + --quiet + --noquiet + +Don't display I<mostly harmless> warning messages. These messages +will be displayed by default. But this is not the same as C<verbose> +mode. + +=item recurse + + --recurse + --norecurse + +Recurse into subdirectories specified in podpath (default behaviour). + +=item title + + --title=title + +Specify the title of the resulting HTML file. + +=item verbose + + --verbose + --noverbose + +Display progress messages. By default, they won't be displayed. + +=back + +=head2 htmlify + + htmlify($heading); + +Converts a pod section specification to a suitable section specification +for HTML. Note that we keep spaces and special characters except +C<", ?> (Netscape problem) and the hyphen (writer's problem...). + +=head2 anchorify + + anchorify(@heading); + +Similar to C<htmlify()>, but turns non-alphanumerics into underscores. Note +that C<anchorify()> is not exported by default. + +=head1 ENVIRONMENT + +Uses C<$Config{pod2html}> to setup default options. + +=head1 AUTHOR + +Tom Christiansen, E<lt>tchrist@perl.comE<gt>. + +=head1 SEE ALSO + +L<perlpod> + +=head1 COPYRIGHT + +This program is distributed under the Artistic License. + +=cut + +my($Cachedir); +my($Dircache, $Itemcache); +my @Begin_Stack; +my @Libpods; +my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl); +my($Podfile, @Podpath, $Podroot); +my $Css; + +my $Recurse; +my $Quiet; +my $HiddenDirs; +my $Verbose; +my $Doindex; + +my $Backlink; +my($Listlevel, @Listtype); +my $ListNewTerm; +use vars qw($Ignore); # need to localize it later. + +my(%Items_Named, @Items_Seen); +my($Title, $Header); + +my $Top; +my $Paragraph; + +my %Sections; + +# Caches +my %Pages = (); # associative array used to find the location + # of pages referenced by L<> links. +my %Items = (); # associative array used to find the location + # of =item directives referenced by C<> links + +my %Local_Items; +my $Is83; + +my $Curdir = File::Spec->curdir; + +init_globals(); + +sub init_globals { + $Cachedir = "."; # The directory to which item and directory + # caches will be written. + + $Dircache = "pod2htmd.tmp"; + $Itemcache = "pod2htmi.tmp"; + + @Begin_Stack = (); # begin/end stack + + @Libpods = (); # files to search for links from C<> directives + $Htmlroot = "/"; # http-server base directory from which all + # relative paths in $podpath stem. + $Htmldir = ""; # The directory to which the html pages + # will (eventually) be written. + $Htmlfile = ""; # write to stdout by default + $Htmlfileurl = ""; # The url that other files would use to + # refer to this file. This is only used + # to make relative urls that point to + # other files. + + $Podfile = ""; # read from stdin by default + @Podpath = (); # list of directories containing library pods. + $Podroot = $Curdir; # filesystem base directory from which all + # relative paths in $podpath stem. + $Css = ''; # Cascading style sheet + $Recurse = 1; # recurse on subdirectories in $podpath. + $Quiet = 0; # not quiet by default + $Verbose = 0; # not verbose by default + $Doindex = 1; # non-zero if we should generate an index + $Backlink = ''; # text for "back to top" links + $Listlevel = 0; # current list depth + @Listtype = (); # list types for open lists + $ListNewTerm = 0; # indicates new term in definition list; used + # to correctly open/close <dd> tags + $Ignore = 1; # whether or not to format text. we don't + # format text until we hit our first pod + # directive. + + @Items_Seen = (); # for multiples of the same item in perlfunc + %Items_Named = (); + $Header = 0; # produce block header/footer + $Title = ''; # title to give the pod(s) + $Top = 1; # true if we are at the top of the doc. used + # to prevent the first <hr /> directive. + $Paragraph = ''; # which paragraph we're processing (used + # for error messages) + %Sections = (); # sections within this page + + %Local_Items = (); + $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem? +} + +# +# clean_data: global clean-up of pod data +# +sub clean_data($){ + my( $dataref ) = @_; + for my $i ( 0..$#{$dataref} ) { + ${$dataref}[$i] =~ s/\s+\Z//; + + # have a look for all-space lines + if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){ + my @chunks = split( /^\s+$/m, ${$dataref}[$i] ); + splice( @$dataref, $i, 1, @chunks ); + } + } +} + + +sub pod2html { + local(@ARGV) = @_; + local($/); + local $_; + + init_globals(); + + $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN()); + + # cache of %Pages and %Items from last time we ran pod2html + + #undef $opt_help if defined $opt_help; + + # parse the command-line parameters + parse_command_line(); + + # escape the backlink argument (same goes for title but is done later...) + $Backlink = html_escape($Backlink) if defined $Backlink; + + # set some variables to their default values if necessary + local *POD; + unless (@ARGV && $ARGV[0]) { + $Podfile = "-" unless $Podfile; # stdin + open(POD, "<$Podfile") + || die "$0: cannot open $Podfile file for input: $!\n"; + } else { + $Podfile = $ARGV[0]; # XXX: might be more filenames + *POD = *ARGV; + } + $Htmlfile = "-" unless $Htmlfile; # stdout + $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a // + $Htmldir =~ s#/\z## ; # so we don't get a // + if ( $Htmlroot eq '' + && defined( $Htmldir ) + && $Htmldir ne '' + && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir + ) + { + # Set the 'base' url for this file, so that we can use it + # as the location from which to calculate relative links + # to other files. If this is '', then absolute links will + # be used throughout. + $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1); + } + + # read the pod a paragraph at a time + warn "Scanning for sections in input file(s)\n" if $Verbose; + $/ = ""; + my @poddata = <POD>; + close(POD); + + # be eol agnostic + for (@poddata) { + if (/\r/) { + if (/\r\n/) { + @poddata = map { s/\r\n/\n/g; + /\n\n/ ? + map { "$_\n\n" } split /\n\n/ : + $_ } @poddata; + } else { + @poddata = map { s/\r/\n/g; + /\n\n/ ? + map { "$_\n\n" } split /\n\n/ : + $_ } @poddata; + } + last; + } + } + + clean_data( \@poddata ); + + # scan the pod for =head[1-6] directives and build an index + my $index = scan_headings(\%Sections, @poddata); + + unless($index) { + warn "No headings in $Podfile\n" if $Verbose; + } + + # open the output file + open(HTML, ">$Htmlfile") + || die "$0: cannot open $Htmlfile file for output: $!\n"; + + # put a title in the HTML file if one wasn't specified + if ($Title eq '') { + TITLE_SEARCH: { + for (my $i = 0; $i < @poddata; $i++) { + if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { + for my $para ( @poddata[$i, $i+1] ) { + last TITLE_SEARCH + if ($Title) = $para =~ /(\S+\s+-+.*\S)/s; + } + } + + } + } + } + if (!$Title and $Podfile =~ /\.pod\z/) { + # probably a split pod so take first =head[12] as title + for (my $i = 0; $i < @poddata; $i++) { + last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/; + } + warn "adopted '$Title' as title for $Podfile\n" + if $Verbose and $Title; + } + if ($Title) { + $Title =~ s/\s*\(.*\)//; + } else { + warn "$0: no title for $Podfile.\n" unless $Quiet; + $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s; + $Title = ($Podfile eq "-" ? 'No Title' : $1); + warn "using $Title" if $Verbose; + } + $Title = html_escape($Title); + + my $csslink = ''; + my $bodystyle = ' style="background-color: white"'; + my $tdstyle = ' style="background-color: #cccccc"'; + + if ($Css) { + $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />); + $csslink =~ s,\\,/,g; + $csslink =~ s,(/.):,$1|,; + $bodystyle = ''; + $tdstyle = ''; + } + + my $block = $Header ? <<END_OF_BLOCK : ''; +<table border="0" width="100%" cellspacing="0" cellpadding="3"> +<tr><td class="block"$tdstyle valign="middle"> +<big><strong><span class="block"> $Title</span></strong></big> +</td></tr> +</table> +END_OF_BLOCK + + print HTML <<END_OF_HEAD; +<?xml version="1.0" ?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<title>$Title</title>$csslink +<meta http-equiv="content-type" content="text/html; charset=utf-8" /> +<link rev="made" href="mailto:$Config{perladmin}" /> +</head> + +<body$bodystyle> +$block +END_OF_HEAD + + # load/reload/validate/cache %Pages and %Items + get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse); + + # scan the pod for =item directives + scan_items( \%Local_Items, "", @poddata); + + # put an index at the top of the file. note, if $Doindex is 0 we + # still generate an index, but surround it with an html comment. + # that way some other program can extract it if desired. + $index =~ s/--+/-/g; + + my $hr = ($Doindex and $index) ? qq(<hr name="index" />) : ""; + + unless ($Doindex) + { + $index = qq(<!--\n$index\n-->\n); + } + + print HTML << "END_OF_INDEX"; + +<!-- INDEX BEGIN --> +<div name="index"> +<p><a name=\"__index__\"></a></p> +$index +$hr +</div> +<!-- INDEX END --> + +END_OF_INDEX + + # now convert this file + my $after_item; # set to true after an =item + warn "Converting input file $Podfile\n" if $Verbose; + foreach my $i (0..$#poddata){ + $_ = $poddata[$i]; + $Paragraph = $i+1; + if (/^(=.*)/s) { # is it a pod directive? + $Ignore = 0; + $after_item = 0; + $_ = $1; + if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin + process_begin($1, $2); + } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end + process_end($1, $2); + } elsif (/^=cut/) { # =cut + process_cut(); + } elsif (/^=pod/) { # =pod + process_pod(); + } else { + next if @Begin_Stack && $Begin_Stack[-1] ne 'html'; + + if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading + process_head( $1, $2, $Doindex && $index ); + } elsif (/^=item\s*(.*\S)?/sm) { # =item text + process_item( $1 ); + $after_item = 1; + } elsif (/^=over\s*(.*)/) { # =over N + process_over(); + } elsif (/^=back/) { # =back + process_back(); + } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for + process_for($1,$2); + } else { + /^=(\S*)\s*/; + warn "$0: $Podfile: unknown pod directive '$1' in " + . "paragraph $Paragraph. ignoring.\n" unless $Quiet; + } + } + $Top = 0; + } + else { + next if $Ignore; + next if @Begin_Stack && $Begin_Stack[-1] ne 'html'; + print HTML and next if @Begin_Stack && $Begin_Stack[-1] eq 'html'; + my $text = $_; + + # Open tag for definition list as we have something to put in it + if( $ListNewTerm ){ + print HTML "<dd>\n"; + $ListNewTerm = 0; + } + + if( $text =~ /\A\s+/ ){ + process_pre( \$text ); + print HTML "<pre>\n$text</pre>\n"; + + } else { + process_text( \$text ); + + # experimental: check for a paragraph where all lines + # have some ...\t...\t...\n pattern + if( $text =~ /\t/ ){ + my @lines = split( "\n", $text ); + if( @lines > 1 ){ + my $all = 2; + foreach my $line ( @lines ){ + if( $line =~ /\S/ && $line !~ /\t/ ){ + $all--; + last if $all == 0; + } + } + if( $all > 0 ){ + $text =~ s/\t+/<td>/g; + $text =~ s/^/<tr><td>/gm; + $text = '<table cellspacing="0" cellpadding="0">' . + $text . '</table>'; + } + } + } + ## end of experimental + + print HTML "<p>$text</p>\n"; + } + $after_item = 0; + } + } + + # finish off any pending directives + finish_list(); + + # link to page index + print HTML "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n" + if $Doindex and $index and $Backlink; + + print HTML <<END_OF_TAIL; +$block +</body> + +</html> +END_OF_TAIL + + # close the html file + close(HTML); + + warn "Finished\n" if $Verbose; +} + +############################################################################## + +sub usage { + my $podfile = shift; + warn "$0: $podfile: @_\n" if @_; + die <<END_OF_USAGE; +Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name> + --podpath=<name>:...:<name> --podroot=<name> + --libpods=<name>:...:<name> --recurse --verbose --index + --netscape --norecurse --noindex --cachedir=<name> + + --backlink - set text for "back to top" links (default: none). + --cachedir - directory for the item and directory cache files. + --css - stylesheet URL + --flush - flushes the item and directory caches. + --[no]header - produce block header/footer (default is no headers). + --help - prints this message. + --hiddendirs - search hidden directories in podpath + --htmldir - directory for resulting HTML files. + --htmlroot - http-server base directory from which all relative paths + in podpath stem (default is /). + --[no]index - generate an index at the top of the resulting html + (default behaviour). + --infile - filename for the pod to convert (input taken from stdin + by default). + --libpods - colon-separated list of pages to search for =item pod + directives in as targets of C<> and implicit links (empty + by default). note, these are not filenames, but rather + page names like those that appear in L<> links. + --outfile - filename for the resulting html file (output sent to + stdout by default). + --podpath - colon-separated list of directories containing library + pods (empty by default). + --podroot - filesystem base directory from which all relative paths + in podpath stem (default is .). + --[no]quiet - suppress some benign warning messages (default is off). + --[no]recurse - recurse on those subdirectories listed in podpath + (default behaviour). + --title - title that will appear in resulting html file. + --[no]verbose - self-explanatory (off by default). + --[no]netscape - deprecated, has no effect. for backwards compatibility only. + +END_OF_USAGE + +} + +sub parse_command_line { + my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help, + $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods, + $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet, + $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs); + + unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; + my $result = GetOptions( + 'backlink=s' => \$opt_backlink, + 'cachedir=s' => \$opt_cachedir, + 'css=s' => \$opt_css, + 'flush' => \$opt_flush, + 'header!' => \$opt_header, + 'help' => \$opt_help, + 'hiddendirs!'=> \$opt_hiddendirs, + 'htmldir=s' => \$opt_htmldir, + 'htmlroot=s' => \$opt_htmlroot, + 'index!' => \$opt_index, + 'infile=s' => \$opt_infile, + 'libpods=s' => \$opt_libpods, + 'netscape!' => \$opt_netscape, + 'outfile=s' => \$opt_outfile, + 'podpath=s' => \$opt_podpath, + 'podroot=s' => \$opt_podroot, + 'quiet!' => \$opt_quiet, + 'recurse!' => \$opt_recurse, + 'title=s' => \$opt_title, + 'verbose!' => \$opt_verbose, + ); + usage("-", "invalid parameters") if not $result; + + usage("-") if defined $opt_help; # see if the user asked for help + $opt_help = ""; # just to make -w shut-up. + + @Podpath = split(":", $opt_podpath) if defined $opt_podpath; + @Libpods = split(":", $opt_libpods) if defined $opt_libpods; + + $Backlink = $opt_backlink if defined $opt_backlink; + $Cachedir = $opt_cachedir if defined $opt_cachedir; + $Css = $opt_css if defined $opt_css; + $Header = $opt_header if defined $opt_header; + $Htmldir = $opt_htmldir if defined $opt_htmldir; + $Htmlroot = $opt_htmlroot if defined $opt_htmlroot; + $Doindex = $opt_index if defined $opt_index; + $Podfile = $opt_infile if defined $opt_infile; + $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs; + $Htmlfile = $opt_outfile if defined $opt_outfile; + $Podroot = $opt_podroot if defined $opt_podroot; + $Quiet = $opt_quiet if defined $opt_quiet; + $Recurse = $opt_recurse if defined $opt_recurse; + $Title = $opt_title if defined $opt_title; + $Verbose = $opt_verbose if defined $opt_verbose; + + warn "Flushing item and directory caches\n" + if $opt_verbose && defined $opt_flush; + $Dircache = "$Cachedir/pod2htmd.tmp"; + $Itemcache = "$Cachedir/pod2htmi.tmp"; + if (defined $opt_flush) { + 1 while unlink($Dircache, $Itemcache); + } +} + + +my $Saved_Cache_Key; + +sub get_cache { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + my @cache_key_args = @_; + + # A first-level cache: + # Don't bother reading the cache files if they still apply + # and haven't changed since we last read them. + + my $this_cache_key = cache_key(@cache_key_args); + + return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key; + + # load the cache of %Pages and %Items if possible. $tests will be + # non-zero if successful. + my $tests = 0; + if (-f $dircache && -f $itemcache) { + warn "scanning for item cache\n" if $Verbose; + $tests = load_cache($dircache, $itemcache, $podpath, $podroot); + } + + # if we didn't succeed in loading the cache then we must (re)build + # %Pages and %Items. + if (!$tests) { + warn "scanning directories in pod-path\n" if $Verbose; + scan_podpath($podroot, $recurse, 0); + } + $Saved_Cache_Key = cache_key(@cache_key_args); +} + +sub cache_key { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + return join('!', $dircache, $itemcache, $recurse, + @$podpath, $podroot, stat($dircache), stat($itemcache)); +} + +# +# load_cache - tries to find if the caches stored in $dircache and $itemcache +# are valid caches of %Pages and %Items. if they are valid then it loads +# them and returns a non-zero value. +# +sub load_cache { + my($dircache, $itemcache, $podpath, $podroot) = @_; + my($tests); + local $_; + + $tests = 0; + + open(CACHE, "<$itemcache") || + die "$0: error opening $itemcache for reading: $!\n"; + $/ = "\n"; + + # is it the same podpath? + $_ = <CACHE>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <CACHE>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close(CACHE); + return 0; + } + + warn "loading item cache\n" if $Verbose; + while (<CACHE>) { + /(.*?) (.*)$/; + $Items{$1} = $2; + } + close(CACHE); + + warn "scanning for directory cache\n" if $Verbose; + open(CACHE, "<$dircache") || + die "$0: error opening $dircache for reading: $!\n"; + $/ = "\n"; + $tests = 0; + + # is it the same podpath? + $_ = <CACHE>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <CACHE>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close(CACHE); + return 0; + } + + warn "loading directory cache\n" if $Verbose; + while (<CACHE>) { + /(.*?) (.*)$/; + $Pages{$1} = $2; + } + + close(CACHE); + + return 1; +} + +# +# scan_podpath - scans the directories specified in @podpath for directories, +# .pod files, and .pm files. it also scans the pod files specified in +# @Libpods for =item directives. +# +sub scan_podpath { + my($podroot, $recurse, $append) = @_; + my($pwd, $dir); + my($libpod, $dirname, $pod, @files, @poddata); + + unless($append) { + %Items = (); + %Pages = (); + } + + # scan each directory listed in @Podpath + $pwd = getcwd(); + chdir($podroot) + || die "$0: error changing to directory $podroot: $!\n"; + foreach $dir (@Podpath) { + scan_dir($dir, $recurse); + } + + # scan the pods listed in @Libpods for =item directives + foreach $libpod (@Libpods) { + # if the page isn't defined then we won't know where to find it + # on the system. + next unless defined $Pages{$libpod} && $Pages{$libpod}; + + # if there is a directory then use the .pod and .pm files within it. + # NOTE: Only finds the first so-named directory in the tree. +# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) { + if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) { + # find all the .pod and .pm files within the directory + $dirname = $1; + opendir(DIR, $dirname) || + die "$0: error opening directory $dirname: $!\n"; + @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR)); + closedir(DIR); + + # scan each .pod and .pm file for =item directives + foreach $pod (@files) { + open(POD, "<$dirname/$pod") || + die "$0: error opening $dirname/$pod for input: $!\n"; + @poddata = <POD>; + close(POD); + clean_data( \@poddata ); + + scan_items( \%Items, "$dirname/$pod", @poddata); + } + + # use the names of files as =item directives too. +### Don't think this should be done this way - confuses issues.(WL) +### foreach $pod (@files) { +### $pod =~ /^(.*)(\.pod|\.pm)$/; +### $Items{$1} = "$dirname/$1.html" if $1; +### } + } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ || + $Pages{$libpod} =~ /([^:]*\.pm):/) { + # scan the .pod or .pm file for =item directives + $pod = $1; + open(POD, "<$pod") || + die "$0: error opening $pod for input: $!\n"; + @poddata = <POD>; + close(POD); + clean_data( \@poddata ); + + scan_items( \%Items, "$pod", @poddata); + } else { + warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet; + } + } + @poddata = (); # clean-up a bit + + chdir($pwd) + || die "$0: error changing to directory $pwd: $!\n"; + + # cache the item list for later use + warn "caching items for later use\n" if $Verbose; + open(CACHE, ">$Itemcache") || + die "$0: error open $Itemcache for writing: $!\n"; + + print CACHE join(":", @Podpath) . "\n$podroot\n"; + foreach my $key (keys %Items) { + print CACHE "$key $Items{$key}\n"; + } + + close(CACHE); + + # cache the directory list for later use + warn "caching directories for later use\n" if $Verbose; + open(CACHE, ">$Dircache") || + die "$0: error open $Dircache for writing: $!\n"; + + print CACHE join(":", @Podpath) . "\n$podroot\n"; + foreach my $key (keys %Pages) { + print CACHE "$key $Pages{$key}\n"; + } + + close(CACHE); +} + +# +# scan_dir - scans the directory specified in $dir for subdirectories, .pod +# files, and .pm files. notes those that it finds. this information will +# be used later in order to figure out where the pages specified in L<> +# links are on the filesystem. +# +sub scan_dir { + my($dir, $recurse) = @_; + my($t, @subdirs, @pods, $pod, $dirname, @dirs); + local $_; + + @subdirs = (); + @pods = (); + + opendir(DIR, $dir) || + die "$0: error opening directory $dir: $!\n"; + while (defined($_ = readdir(DIR))) { + if (-d "$dir/$_" && $_ ne "." && $_ ne ".." + && ($HiddenDirs || !/^\./) + ) { # directory + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_:"; + push(@subdirs, $_); + } elsif (/\.pod\z/) { # .pod + s/\.pod\z//; + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pod:"; + push(@pods, "$dir/$_.pod"); + } elsif (/\.html\z/) { # .html + s/\.html\z//; + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pod:"; + } elsif (/\.pm\z/) { # .pm + s/\.pm\z//; + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pm:"; + push(@pods, "$dir/$_.pm"); + } elsif (-T "$dir/$_") { # script(?) + local *F; + if (open(F, "$dir/$_")) { + my $line; + while (defined($line = <F>)) { + if ($line =~ /^=(?:pod|head1)/) { + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pod:"; + last; + } + } + close(F); + } + } + } + closedir(DIR); + + # recurse on the subdirectories if necessary + if ($recurse) { + foreach my $subdir (@subdirs) { + scan_dir("$dir/$subdir", $recurse); + } + } +} + +# +# scan_headings - scan a pod file for head[1-6] tags, note the tags, and +# build an index. +# +sub scan_headings { + my($sections, @data) = @_; + my($tag, $which_head, $otitle, $listdepth, $index); + + local $Ignore = 0; + + $listdepth = 0; + $index = ""; + + # scan for =head directives, note their name, and build an index + # pointing to each of them. + foreach my $line (@data) { + if ($line =~ /^=(head)([1-6])\s+(.*)/) { + ($tag, $which_head, $otitle) = ($1,$2,$3); + + my $title = depod( $otitle ); + my $name = anchorify( $title ); + $$sections{$name} = 1; + $title = process_text( \$otitle ); + + while ($which_head != $listdepth) { + if ($which_head > $listdepth) { + $index .= "\n" . ("\t" x $listdepth) . "<ul>\n"; + $listdepth++; + } elsif ($which_head < $listdepth) { + $listdepth--; + $index .= "\n" . ("\t" x $listdepth) . "</ul>\n"; + } + } + + $index .= "\n" . ("\t" x $listdepth) . "<li>" . + "<a href=\"#" . $name . "\">" . + $title . "</a></li>"; + } + } + + # finish off the lists + while ($listdepth--) { + $index .= "\n" . ("\t" x $listdepth) . "</ul>\n"; + } + + # get rid of bogus lists + $index =~ s,\t*<ul>\s*</ul>\n,,g; + + return $index; +} + +# +# scan_items - scans the pod specified by $pod for =item directives. we +# will use this information later on in resolving C<> links. +# +sub scan_items { + my( $itemref, $pod, @poddata ) = @_; + my($i, $item); + local $_; + + $pod =~ s/\.pod\z//; + $pod .= ".html" if $pod; + + foreach $i (0..$#poddata) { + my $txt = depod( $poddata[$i] ); + + # figure out what kind of item it is. + # Build string for referencing this item. + if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list + next unless $1; + $item = $1; + } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list + $item = $1; + } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list + $item = $1; + } else { + next; + } + my $fid = fragment_id( $item ); + $$itemref{$fid} = "$pod" if $fid; + } +} + +# +# process_head - convert a pod head[1-6] tag and convert it to HTML format. +# +sub process_head { + my($tag, $heading, $hasindex) = @_; + + # figure out the level of the =head + $tag =~ /head([1-6])/; + my $level = $1; + + finish_list(); + + print HTML "<p>\n"; + if( $level == 1 && ! $Top ){ + print HTML "<a href=\"#__index__\"><small>$Backlink</small></a>\n" + if $hasindex and $Backlink; + print HTML "</p>\n<hr />\n" + } else { + print HTML "</p>\n"; + } + + my $name = anchorify( depod( $heading ) ); + my $convert = process_text( \$heading ); + print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n"; +} + + +# +# emit_item_tag - print an =item's text +# Note: The global $EmittedItem is used for inhibiting self-references. +# +my $EmittedItem; + +sub emit_item_tag($$$){ + my( $otext, $text, $compact ) = @_; + my $item = fragment_id( depod($text) , -generate); + Carp::confess("Undefined fragment '$text' (".depod($text).") from fragment_id() in emit_item_tag() in $Podfile") + if !defined $item; + $EmittedItem = $item; + ### print STDERR "emit_item_tag=$item ($text)\n"; + + print HTML '<strong>'; + if ($Items_Named{$item}++) { + print HTML process_text( \$otext ); + } else { + my $name = $item; + $name = anchorify($name); + print HTML qq{<a name="$name" class="item">}, process_text( \$otext ), '</a>'; + } + print HTML "</strong>"; + undef( $EmittedItem ); +} + +sub new_listitem { + my( $tag ) = @_; + # Open tag for definition list as we have something to put in it + if( ($tag ne 'dl') && ($ListNewTerm) ){ + print HTML "<dd>\n"; + $ListNewTerm = 0; + } + + if( $Items_Seen[$Listlevel]++ == 0 ){ + # start of new list + push( @Listtype, "$tag" ); + print HTML "<$tag>\n"; + } else { + # if this is not the first item, close the previous one + if ( $tag eq 'dl' ){ + print HTML "</dd>\n" unless $ListNewTerm; + } else { + print HTML "</li>\n"; + } + } + my $opentag = $tag eq 'dl' ? 'dt' : 'li'; + print HTML "<$opentag>"; +} + +# +# process_item - convert a pod item tag and convert it to HTML format. +# +sub process_item { + my( $otext ) = @_; + + # lots of documents start a list without doing an =over. this is + # bad! but, the proper thing to do seems to be to just assume + # they did do an =over. so warn them once and then continue. + if( $Listlevel == 0 ){ + warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet; + process_over(); + } + + # remove formatting instructions from the text + my $text = depod( $otext ); + + # all the list variants: + if( $text =~ /\A\*/ ){ # bullet + new_listitem( 'ul' ); + if ($text =~ /\A\*\s+(\S.*)\Z/s ) { # with additional text + my $tag = $1; + $otext =~ s/\A\*\s+//; + emit_item_tag( $otext, $tag, 1 ); + print HTML "\n"; + } + + } elsif( $text =~ /\A\d+/ ){ # numbered list + new_listitem( 'ol' ); + if ($text =~ /\A(?>\d+\.?)\s*(\S.*)\Z/s ) { # with additional text + my $tag = $1; + $otext =~ s/\A\d+\.?\s*//; + emit_item_tag( $otext, $tag, 1 ); + print HTML "\n"; + } + + } else { # definition list + # new_listitem takes care of opening the <dt> tag + new_listitem( 'dl' ); + if ($text =~ /\A(.+)\Z/s ){ # should have text + emit_item_tag( $otext, $text, 1 ); + # write the definition term and close <dt> tag + print HTML "</dt>\n"; + } + # trigger opening a <dd> tag for the actual definition; will not + # happen if next paragraph is also a definition term (=item) + $ListNewTerm = 1; + } + print HTML "\n"; +} + +# +# process_over - process a pod over tag and start a corresponding HTML list. +# +sub process_over { + # start a new list + $Listlevel++; + push( @Items_Seen, 0 ); +} + +# +# process_back - process a pod back tag and convert it to HTML format. +# +sub process_back { + if( $Listlevel == 0 ){ + warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet; + return; + } + + # close off the list. note, I check to see if $Listtype[$Listlevel] is + # defined because an =item directive may have never appeared and thus + # $Listtype[$Listlevel] may have never been initialized. + $Listlevel--; + if( defined $Listtype[$Listlevel] ){ + if ( $Listtype[$Listlevel] eq 'dl' ){ + print HTML "</dd>\n" unless $ListNewTerm; + } else { + print HTML "</li>\n"; + } + print HTML "</$Listtype[$Listlevel]>\n"; + pop( @Listtype ); + $ListNewTerm = 0; + } + + # clean up item count + pop( @Items_Seen ); +} + +# +# process_cut - process a pod cut tag, thus start ignoring pod directives. +# +sub process_cut { + $Ignore = 1; +} + +# +# process_pod - process a pod tag, thus stop ignoring pod directives +# until we see a corresponding cut. +# +sub process_pod { + # no need to set $Ignore to 0 cause the main loop did it +} + +# +# process_for - process a =for pod tag. if it's for html, spit +# it out verbatim, if illustration, center it, otherwise ignore it. +# +sub process_for { + my($whom, $text) = @_; + if ( $whom =~ /^(pod2)?html$/i) { + print HTML $text; + } elsif ($whom =~ /^illustration$/i) { + 1 while chomp $text; + for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) { + $text .= $ext, last if -r "$text$ext"; + } + print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>}; + } +} + +# +# process_begin - process a =begin pod tag. this pushes +# whom we're beginning on the begin stack. if there's a +# begin stack, we only print if it us. +# +sub process_begin { + my($whom, $text) = @_; + $whom = lc($whom); + push (@Begin_Stack, $whom); + if ( $whom =~ /^(pod2)?html$/) { + print HTML $text if $text; + } +} + +# +# process_end - process a =end pod tag. pop the +# begin stack. die if we're mismatched. +# +sub process_end { + my($whom, $text) = @_; + $whom = lc($whom); + if (!defined $Begin_Stack[-1] or $Begin_Stack[-1] ne $whom ) { + Carp::confess("Unmatched begin/end at chunk $Paragraph in pod $Podfile\n") + } + pop( @Begin_Stack ); +} + +# +# process_pre - indented paragraph, made into <pre></pre> +# +sub process_pre { + my( $text ) = @_; + my( $rest ); + return if $Ignore; + + $rest = $$text; + + # insert spaces in place of tabs + $rest =~ s#(.+)# + my $line = $1; + 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e; + $line; + #eg; + + # convert some special chars to HTML escapes + $rest = html_escape($rest); + + # try and create links for all occurrences of perl.* within + # the preformatted text. + $rest =~ s{ + (\s*)(perl\w+) + }{ + if ( defined $Pages{$2} ){ # is a link + qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>); + } elsif (defined $Pages{dosify($2)}) { # is a link + qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>); + } else { + "$1$2"; + } + }xeg; + $rest =~ s{ + (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)? + }{ + my $url ; + if ( $Htmlfileurl ne '' ){ + # Here, we take advantage of the knowledge + # that $Htmlfileurl ne '' implies $Htmlroot eq ''. + # Since $Htmlroot eq '', we need to prepend $Htmldir + # on the fron of the link to get the absolute path + # of the link's target. We check for a leading '/' + # to avoid corrupting links that are #, file:, etc. + my $old_url = $3 ; + $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/}; + $url = relativize_url( "$old_url.html", $Htmlfileurl ); + } else { + $url = "$3.html" ; + } + "$1$url" ; + }xeg; + + # Look for embedded URLs and make them into links. We don't + # relativize them since they are best left as the author intended. + + my $urls = '(' . join ('|', qw{ + http + telnet + mailto + news + gopher + file + wais + ftp + } ) + . ')'; + + my $ltrs = '\w'; + my $gunk = '/#~:.?+=&%@!\-'; + my $punc = '.:!?\-;'; + my $any = "${ltrs}${gunk}${punc}"; + + $rest =~ s{ + \b # start at word boundary + ( # begin $1 { + $urls : # need resource and a colon + (?!:) # Ignore File::, among others. + [$any] +? # followed by one or more of any valid + # character, but be conservative and + # take only what you need to.... + ) # end $1 } + (?= + " > # maybe pre-quoted '<a href="...">' + | # or: + [$punc]* # 0 or more punctuation + (?: # followed + [^$any] # by a non-url char + | # or + $ # end of the string + ) # + | # or else + $ # then end of the string + ) + }{<a href="$1">$1</a>}igox; + + # text should be as it is (verbatim) + $$text = $rest; +} + + +# +# pure text processing +# +# pure_text/inIS_text: differ with respect to automatic C<> recognition. +# we don't want this to happen within IS +# +sub pure_text($){ + my $text = shift(); + process_puretext( $text, 1 ); +} + +sub inIS_text($){ + my $text = shift(); + process_puretext( $text, 0 ); +} + +# +# process_puretext - process pure text (without pod-escapes) converting +# double-quotes and handling implicit C<> links. +# +sub process_puretext { + my($text, $notinIS) = @_; + + ## Guessing at func() or [\$\@%&]*var references in plain text is destined + ## to produce some strange looking ref's. uncomment to disable: + ## $notinIS = 0; + + my(@words, $lead, $trail); + + # keep track of leading and trailing white-space + $lead = ($text =~ s/\A(\s+)//s ? $1 : ""); + $trail = ($text =~ s/(\s+)\Z//s ? $1 : ""); + + # split at space/non-space boundaries + @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text ); + + # process each word individually + foreach my $word (@words) { + # skip space runs + next if $word =~ /^\s*$/; + # see if we can infer a link or a function call + # + # NOTE: This is a word based search, it won't automatically + # mark "substr($var, 1, 2)" because the 1st word would be "substr($var" + # User has to enclose those with proper C<> + + if( $notinIS && $word =~ + m/ + ^([a-z_]{2,}) # The function name + \( + ([0-9][a-z]* # Manual page(1) or page(1M) + |[^)]*[\$\@\%][^)]+ # ($foo), (1, @foo), (%hash) + | # () + ) + \) + ([.,;]?)$ # a possible punctuation follows + /xi + ) { + # has parenthesis so should have been a C<> ref + ## try for a pagename (perlXXX(1))? + my( $func, $args, $rest ) = ( $1, $2, $3 || '' ); + if( $args =~ /^\d+$/ ){ + my $url = page_sect( $word, '' ); + if( defined $url ){ + $word = qq(<a href="$url" class="man">the $word manpage</a>$rest); + next; + } + } + ## try function name for a link, append tt'ed argument list + $word = emit_C( $func, '', "($args)") . $rest; + +#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing. +## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) { +## # perl variables, should be a C<> ref +## $word = emit_C( $word ); + + } elsif ($word =~ m,^\w+://\w,) { + # looks like a URL + # Don't relativize it: leave it as the author intended + $word = qq(<a href="$word">$word</a>); + } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) { + # looks like an e-mail address + my ($w1, $w2, $w3) = ("", $word, ""); + ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; + ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/; + $word = qq($w1<a href="mailto:$w2">$w2</a>$w3); + } else { + $word = html_escape($word) if $word =~ /["&<>]/; + } + } + + # put everything back together + return $lead . join( '', @words ) . $trail; +} + + +# +# process_text - handles plaintext that appears in the input pod file. +# there may be pod commands embedded within the text so those must be +# converted to html commands. +# + +sub process_text1($$;$$); +sub pattern ($) { $_[0] ? '\s+'.('>' x ($_[0] + 1)) : '>' } +sub closing ($) { local($_) = shift; (defined && s/\s+\z//) ? length : 0 } + +sub process_text { + return if $Ignore; + my( $tref ) = @_; + my $res = process_text1( 0, $tref ); + $res =~ s/\s+$//s; + $$tref = $res; +} + +sub process_text_rfc_links { + my $text = shift; + + # For every "RFCnnnn" or "RFC nnn", link it to the authoritative + # ource. Do not use the /i modifier here. Require "RFC" to be written in + # in capital letters. + + $text =~ s{ + (?<=[^<>[:alpha:]]) # Make sure this is not an URL already + (RFC\s*([0-9]{1,5}))(?![0-9]) # max 5 digits + } + {<a href="http://www.ietf.org/rfc/rfc$2.txt" class="rfc">$1</a>}gx; + + $text; +} + +sub process_text1($$;$$){ + my( $lev, $rstr, $func, $closing ) = @_; + my $res = ''; + + unless (defined $func) { + $func = ''; + $lev++; + } + + if( $func eq 'B' ){ + # B<text> - boldface + $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>'; + + } elsif( $func eq 'C' ){ + # C<code> - can be a ref or <code></code> + # need to extract text + my $par = go_ahead( $rstr, 'C', $closing ); + + ## clean-up of the link target + my $text = depod( $par ); + + ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ; + ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n"; + + $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) ); + + } elsif( $func eq 'E' ){ + # E<x> - convert to character + $$rstr =~ s/^([^>]*)>//; + my $escape = $1; + $escape =~ s/^0?x([\dA-F]+)$/#x$1/i + or $escape =~ s/^0([0-7]+)$/'#'.oct($1)/ei + or $escape =~ s/^(\d+)$/#$1/; + $res = "&$escape;"; + + } elsif( $func eq 'F' ){ + # F<filename> - italicize + $res = '<em class="file">' . process_text1( $lev, $rstr ) . '</em>'; + + } elsif( $func eq 'I' ){ + # I<text> - italicize + $res = '<em>' . process_text1( $lev, $rstr ) . '</em>'; + + } elsif( $func eq 'L' ){ + # L<link> - link + ## L<text|cross-ref> => produce text, use cross-ref for linking + ## L<cross-ref> => make text from cross-ref + ## need to extract text + my $par = go_ahead( $rstr, 'L', $closing ); + + # some L<>'s that shouldn't be: + # a) full-blown URL's are emitted as-is + if( $par =~ m{^\w+://}s ){ + return make_URL_href( $par ); + } + # b) C<...> is stripped and treated as C<> + if( $par =~ /^C<(.*)>$/ ){ + my $text = depod( $1 ); + return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) ); + } + + # analyze the contents + $par =~ s/\n/ /g; # undo word-wrapped tags + my $opar = $par; + my $linktext; + if( $par =~ s{^([^|]+)\|}{} ){ + $linktext = $1; + } + + # make sure sections start with a / + $par =~ s{^"}{/"}; + + my( $page, $section, $ident ); + + # check for link patterns + if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident + # we've got a name/ident (no quotes) + if (length $2) { + ( $page, $ident ) = ( $1, $2 ); + } else { + ( $page, $section ) = ( $1, $2 ); + } + ### print STDERR "--> L<$par> to page $page, ident $ident\n"; + + } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section" + # even though this should be a "section", we go for ident first + ( $page, $ident ) = ( $1, $2 ); + ### print STDERR "--> L<$par> to page $page, section $section\n"; + + } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes + ( $page, $section ) = ( '', $par ); + ### print STDERR "--> L<$par> to void page, section $section\n"; + + } else { + ( $page, $section ) = ( $par, '' ); + ### print STDERR "--> L<$par> to page $par, void section\n"; + } + + # now, either $section or $ident is defined. the convoluted logic + # below tries to resolve L<> according to what the user specified. + # failing this, we try to find the next best thing... + my( $url, $ltext, $fid ); + + RESOLVE: { + if( defined $ident ){ + ## try to resolve $ident as an item + ( $url, $fid ) = coderef( $page, $ident ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $ident; + $linktext .= " in " if $ident && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got coderef url=$url\n"; + last RESOLVE; + } + ## no luck: go for a section (auto-quoting!) + $section = $ident; + } + ## now go for a section + my $htmlsection = htmlify( $section ); + $url = page_sect( $page, $htmlsection ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $section; + $linktext .= " in " if $section && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got page/section url=$url\n"; + last RESOLVE; + } + ## no luck: go for an ident + if( $section ){ + $ident = $section; + } else { + $ident = $page; + $page = undef(); + } + ( $url, $fid ) = coderef( $page, $ident ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $ident; + $linktext .= " in " if $ident && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got section=>coderef url=$url\n"; + last RESOLVE; + } + + # warning; show some text. + $linktext = $opar unless defined $linktext; + warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet; + } + + # now we have a URL or just plain code + $$rstr = $linktext . '>' . $$rstr; + if( defined( $url ) ){ + $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>'; + } else { + $res = '<em>' . process_text1( $lev, $rstr ) . '</em>'; + } + + } elsif( $func eq 'S' ){ + # S<text> - non-breaking spaces + $res = process_text1( $lev, $rstr ); + $res =~ s/ / /g; + + } elsif( $func eq 'X' ){ + # X<> - ignore + warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n" + unless $$rstr =~ s/^[^>]*>// or $Quiet; + } elsif( $func eq 'Z' ){ + # Z<> - empty + warn "$0: $Podfile: invalid Z<> in paragraph $Paragraph.\n" + unless $$rstr =~ s/^>// or $Quiet; + + } else { + my $term = pattern $closing; + while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){ + # all others: either recurse into new function or + # terminate at closing angle bracket(s) + my $pt = $1; + $pt .= $2 if !$3 && $lev == 1; + $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt ); + return $res if !$3 && $lev > 1; + if( $3 ){ + $res .= process_text1( $lev, $rstr, $3, closing $4 ); + } + } + if( $lev == 1 ){ + $res .= pure_text( $$rstr ); + } elsif( ! $Quiet ) { + my $snippet = substr($$rstr,0,60); + warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph: '$snippet'.\n" + + } + $res = process_text_rfc_links($res); + } + return $res; +} + +# +# go_ahead: extract text of an IS (can be nested) +# +sub go_ahead($$$){ + my( $rstr, $func, $closing ) = @_; + my $res = ''; + my @closing = ($closing); + while( $$rstr =~ + s/\A(.*?)(([BCEFILSXZ])<(<+\s+)?|@{[pattern $closing[0]]})//s ){ + $res .= $1; + unless( $3 ){ + shift @closing; + return $res unless @closing; + } else { + unshift @closing, closing $4; + } + $res .= $2; + } + unless ($Quiet) { + my $snippet = substr($$rstr,0,60); + warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph (go_ahead): '$snippet'.\n" + } + return $res; +} + +# +# emit_C - output result of C<text> +# $text is the depod-ed text +# +sub emit_C($;$$){ + my( $text, $nocode, $args ) = @_; + $args = '' unless defined $args; + my $res; + my( $url, $fid ) = coderef( undef(), $text ); + + # need HTML-safe text + my $linktext = html_escape( "$text$args" ); + + if( defined( $url ) && + (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){ + $res = "<a href=\"$url\"><code>$linktext</code></a>"; + } elsif( 0 && $nocode ){ + $res = $linktext; + } else { + $res = "<code>$linktext</code>"; + } + return $res; +} + +# +# html_escape: make text safe for HTML +# +sub html_escape { + my $rest = $_[0]; + $rest =~ s/&/&/g; + $rest =~ s/</</g; + $rest =~ s/>/>/g; + $rest =~ s/"/"/g; + # ' is only in XHTML, not HTML4. Be conservative + #$rest =~ s/'/'/g; + return $rest; +} + + +# +# dosify - convert filenames to 8.3 +# +sub dosify { + my($str) = @_; + return lc($str) if $^O eq 'VMS'; # VMS just needs casing + if ($Is83) { + $str = lc $str; + $str =~ s/(\.\w+)/substr ($1,0,4)/ge; + $str =~ s/(\w+)/substr ($1,0,8)/ge; + } + return $str; +} + +# +# page_sect - make a URL from the text of a L<> +# +sub page_sect($$) { + my( $page, $section ) = @_; + my( $linktext, $page83, $link); # work strings + + # check if we know that this is a section in this page + if (!defined $Pages{$page} && defined $Sections{$page}) { + $section = $page; + $page = ""; + ### print STDERR "reset page='', section=$section\n"; + } + + $page83=dosify($page); + $page=$page83 if (defined $Pages{$page83}); + if ($page eq "") { + $link = "#" . anchorify( $section ); + } elsif ( $page =~ /::/ ) { + $page =~ s,::,/,g; + # Search page cache for an entry keyed under the html page name, + # then look to see what directory that page might be in. NOTE: + # this will only find one page. A better solution might be to produce + # an intermediate page that is an index to all such pages. + my $page_name = $page ; + $page_name =~ s,^.*/,,s ; + if ( defined( $Pages{ $page_name } ) && + $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/ + ) { + $page = $1 ; + } + else { + # NOTE: This branch assumes that all A::B pages are located in + # $Htmlroot/A/B.html . This is often incorrect, since they are + # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could + # analyze the contents of %Pages and figure out where any + # cousins of A::B are, then assume that. So, if A::B isn't found, + # but A::C is found in lib/A/C.pm, then A::B is assumed to be in + # lib/A/B.pm. This is also limited, but it's an improvement. + # Maybe a hints file so that the links point to the correct places + # nonetheless? + + } + $link = "$Htmlroot/$page.html"; + $link .= "#" . anchorify( $section ) if ($section); + } elsif (!defined $Pages{$page}) { + $link = ""; + } else { + $section = anchorify( $section ) if $section ne ""; + ### print STDERR "...section=$section\n"; + + # if there is a directory by the name of the page, then assume that an + # appropriate section will exist in the subdirectory +# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) { + if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) { + $link = "$Htmlroot/$1/$section.html"; + ### print STDERR "...link=$link\n"; + + # since there is no directory by the name of the page, the section will + # have to exist within a .html of the same name. thus, make sure there + # is a .pod or .pm that might become that .html + } else { + $section = "#$section" if $section; + ### print STDERR "...section=$section\n"; + + # check if there is a .pod with the page name. + # for L<Foo>, Foo.(pod|pm) is preferred to A/Foo.(pod|pm) + if ($Pages{$page} =~ /([^:]*)\.(?:pod|pm):/) { + $link = "$Htmlroot/$1.html$section"; + } else { + $link = ""; + } + } + } + + if ($link) { + # Here, we take advantage of the knowledge that $Htmlfileurl ne '' + # implies $Htmlroot eq ''. This means that the link in question + # needs a prefix of $Htmldir if it begins with '/'. The test for + # the initial '/' is done to avoid '#'-only links, and to allow + # for other kinds of links, like file:, ftp:, etc. + my $url ; + if ( $Htmlfileurl ne '' ) { + $link = "$Htmldir$link" if $link =~ m{^/}s; + $url = relativize_url( $link, $Htmlfileurl ); +# print( " b: [$link,$Htmlfileurl,$url]\n" ); + } + else { + $url = $link ; + } + return $url; + + } else { + return undef(); + } +} + +# +# relativize_url - convert an absolute URL to one relative to a base URL. +# Assumes both end in a filename. +# +sub relativize_url { + my ($dest,$source) = @_ ; + + my ($dest_volume,$dest_directory,$dest_file) = + File::Spec::Unix->splitpath( $dest ) ; + $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ; + + my ($source_volume,$source_directory,$source_file) = + File::Spec::Unix->splitpath( $source ) ; + $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ; + + my $rel_path = '' ; + if ( $dest ne '' ) { + $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ; + } + + if ( $rel_path ne '' && + substr( $rel_path, -1 ) ne '/' && + substr( $dest_file, 0, 1 ) ne '#' + ) { + $rel_path .= "/$dest_file" ; + } + else { + $rel_path .= "$dest_file" ; + } + + return $rel_path ; +} + + +# +# coderef - make URL from the text of a C<> +# +sub coderef($$){ + my( $page, $item ) = @_; + my( $url ); + + my $fid = fragment_id( $item ); + + if( defined( $page ) && $page ne "" ){ + # we have been given a $page... + $page =~ s{::}{/}g; + + Carp::confess("Undefined fragment '$item' from fragment_id() in coderef() in $Podfile") + if !defined $fid; + # Do we take it? Item could be a section! + my $base = $Items{$fid} || ""; + $base =~ s{[^/]*/}{}; + if( $base ne "$page.html" ){ + ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n"; + $page = undef(); + } + + } else { + # no page - local items precede cached items + if( defined( $fid ) ){ + if( exists $Local_Items{$fid} ){ + $page = $Local_Items{$fid}; + } else { + $page = $Items{$fid}; + } + } + } + + # if there was a pod file that we found earlier with an appropriate + # =item directive, then create a link to that page. + if( defined $page ){ + if( $page ){ + if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){ + $page = $1 . '.html'; + } + my $link = "$Htmlroot/$page#" . anchorify($fid); + + # Here, we take advantage of the knowledge that $Htmlfileurl + # ne '' implies $Htmlroot eq ''. + if ( $Htmlfileurl ne '' ) { + $link = "$Htmldir$link" ; + $url = relativize_url( $link, $Htmlfileurl ) ; + } else { + $url = $link ; + } + } else { + $url = "#" . anchorify($fid); + } + + confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/; + } + return( $url, $fid ); +} + + + +# +# Adapted from Nick Ing-Simmons' PodToHtml package. +sub relative_url { + my $source_file = shift ; + my $destination_file = shift; + + my $source = URI::file->new_abs($source_file); + my $uo = URI::file->new($destination_file,$source)->abs; + return $uo->rel->as_string; +} + + +# +# finish_list - finish off any pending HTML lists. this should be called +# after the entire pod file has been read and converted. +# +sub finish_list { + if( $Listlevel ){ + warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet; + while( $Listlevel ){ + process_back(); + } + } +} + +# +# htmlify - converts a pod section specification to a suitable section +# specification for HTML. Note that we keep spaces and special characters +# except ", ? (Netscape problem) and the hyphen (writer's problem...). +# +sub htmlify { + my( $heading) = @_; + $heading =~ s/(\s+)/ /g; + $heading =~ s/\s+\Z//; + $heading =~ s/\A\s+//; + # The hyphen is a disgrace to the English language. + # $heading =~ s/[-"?]//g; + $heading =~ s/["?]//g; + $heading = lc( $heading ); + return $heading; +} + +# +# similar to htmlify, but turns non-alphanumerics into underscores +# +sub anchorify { + my ($anchor) = @_; + $anchor = htmlify($anchor); + $anchor =~ s/\W/_/g; + return $anchor; +} + +# +# depod - convert text by eliminating all interior sequences +# Note: can be called with copy or modify semantics +# +my %E2c; +$E2c{lt} = '<'; +$E2c{gt} = '>'; +$E2c{sol} = '/'; +$E2c{verbar} = '|'; +$E2c{amp} = '&'; # in Tk's pods + +sub depod1($;$$); + +sub depod($){ + my $string; + if( ref( $_[0] ) ){ + $string = ${$_[0]}; + ${$_[0]} = depod1( \$string ); + } else { + $string = $_[0]; + depod1( \$string ); + } +} + +sub depod1($;$$){ + my( $rstr, $func, $closing ) = @_; + my $res = ''; + return $res unless defined $$rstr; + if( ! defined( $func ) ){ + # skip to next begin of an interior sequence + while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?//s ){ + # recurse into its text + $res .= $1 . depod1( $rstr, $2, closing $3); + } + $res .= $$rstr; + } elsif( $func eq 'E' ){ + # E<x> - convert to character + $$rstr =~ s/^([^>]*)>//; + $res .= $E2c{$1} || ""; + } elsif( $func eq 'X' ){ + # X<> - ignore + $$rstr =~ s/^[^>]*>//; + } elsif( $func eq 'Z' ){ + # Z<> - empty + $$rstr =~ s/^>//; + } else { + # all others: either recurse into new function or + # terminate at closing angle bracket + my $term = pattern $closing; + while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){ + $res .= $1; + last unless $3; + $res .= depod1( $rstr, $3, closing $4 ); + } + ## If we're here and $2 ne '>': undelimited interior sequence. + ## Ignored, as this is called without proper indication of where we are. + ## Rely on process_text to produce diagnostics. + } + return $res; +} + +{ + my %seen; # static fragment record hash + +sub fragment_id_readable { + my $text = shift; + my $generate = shift; # optional flag + + my $orig = $text; + + # leave the words for the fragment identifier, + # change everything else to underbars. + $text =~ s/[^A-Za-z0-9_]+/_/g; # do not use \W to avoid locale dependency. + $text =~ s/_{2,}/_/g; + $text =~ s/\A_//; + $text =~ s/_\Z//; + + unless ($text) + { + # Nothing left after removing punctuation, so leave it as is + # E.g. if option is named: "=item -#" + + $text = $orig; + } + + if ($generate) { + if ( exists $seen{$text} ) { + # This already exists, make it unique + $seen{$text}++; + $text = $text . $seen{$text}; + } else { + $seen{$text} = 1; # first time seen this fragment + } + } + + $text; +}} + +my @HC; +sub fragment_id_obfuscated { # This was the old "_2d_2d__" + my $text = shift; + my $generate = shift; # optional flag + + # text? Normalize by obfuscating the fragment id to make it unique + $text =~ s/\s+/_/sg; + + $text =~ s{(\W)}{ + defined( $HC[ord($1)] ) ? $HC[ord($1)] + : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe; + $text = substr( $text, 0, 50 ); + + $text; +} + +# +# fragment_id - construct a fragment identifier from: +# a) =item text +# b) contents of C<...> +# + +sub fragment_id { + my $text = shift; + my $generate = shift; # optional flag + + $text =~ s/\s+\Z//s; + if( $text ){ + # a method or function? + return $1 if $text =~ /(\w+)\s*\(/; + return $1 if $text =~ /->\s*(\w+)\s*\(?/; + + # a variable name? + return $1 if $text =~ /^([\$\@%*]\S+)/; + + # some pattern matching operator? + return $1 if $text =~ m|^(\w+/).*/\w*$|; + + # fancy stuff... like "do { }" + return $1 if $text =~ m|^(\w+)\s*{.*}$|; + + # honour the perlfunc manpage: func [PAR[,[ ]PAR]...] + # and some funnies with ... Module ... + return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z,/& ][A-Z\d,/& ]*)?$}; + return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$}; + + return fragment_id_readable($text, $generate); + } else { + return; + } +} + +# +# make_URL_href - generate HTML href from URL +# Special treatment for CGI queries. +# +sub make_URL_href($){ + my( $url ) = @_; + if( $url !~ + s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){ + $url = "<a href=\"$url\">$url</a>"; + } + return $url; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm b/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm new file mode 100644 index 00000000000..13a86188bcb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm @@ -0,0 +1,936 @@ +############################################################################# +# 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.31'; ## 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<Pod::Parser> when +reading and parsing POD text from an input source. The following objects +are defined: + +=over 4 + +=begin __PRIVATE__ + +=item package B<Pod::InputSource> + +An object corresponding to a source of POD input text. It is mostly a +wrapper around a filehandle or C<IO::Handle>-type object (or anything +that implements the C<getline()> method) which keeps track of some +additional information relevant to the parsing of PODs. + +=end __PRIVATE__ + +=item package B<Pod::Paragraph> + +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<perlpod>). + +=item package B<Pod::InteriorSequence> + +An object corresponding to an interior sequence command from the POD +input text (see L<perlpod>). + +=item package B<Pod::ParseTree> + +An object corresponding to a tree of parsed POD text. Each "node" in +a parse-tree (or I<ptree>) is either a text-string or a reference to +a B<Pod::InteriorSequence> 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<Pod::InputSource> + +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<Pod::InputSource> objects. Each such object is merely a wrapper around +an C<IO::Handle> object of some kind (or at least something that +implements the C<getline()> method). They have the following +methods/attributes: + +=end __PRIVATE__ + +=cut + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B<new()> + + 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<Pod::InputSource> 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<name()> + + 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<handle()> + + 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<was_cutting()> + + print "Yes.\n" if ($pod_input->was_cutting()); + +The value of the C<cutting> state (that the B<cutting()> 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<cutting> +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<Pod::Paragraph> + +An object representing a paragraph of POD input text. +It has the following methods/attributes: + +=cut + +##--------------------------------------------------------------------------- + +=head2 Pod::Paragraph-E<gt>B<new()> + + 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<Pod::Paragraph> 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<head1> or C<item> (it should +I<not> 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 => '<unknown-file>', + -line => 0, + -prefix => '=', + -separator => ' ', + -ptree => [], + @_ + }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_para-E<gt>B<cmd_name()> + + 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<without> 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-E<gt>B<text()> + + 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-E<gt>B<raw_text()> + + my $raw_pod_para = $pod_para->raw_text(); + +This method will return the I<raw> 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-E<gt>B<cmd_prefix()> + + 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-E<gt>B<cmd_separator()> + + 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-E<gt>B<parse_tree()> + + 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-E<gt>B<file_line()> + + 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'} || '<unknown-file>', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::InteriorSequence; + +##--------------------------------------------------------------------------- + +=head1 B<Pod::InteriorSequence> + +An object representing a POD interior sequence command. +It has the following methods/attributes: + +=cut + +##--------------------------------------------------------------------------- + +=head2 Pod::InteriorSequence-E<gt>B<new()> + + 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<Pod::InteriorSequence> 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<lt>'). +The C<-name> keyword indicates the name of the corresponding interior +sequence command, such as C<I> or C<B> or C<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<Pod::ParseTree::new> (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 => '<unknown-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-E<gt>B<cmd_name()> + + 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-E<gt>B<prepend()> + + $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-E<gt>B<append()> + + $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-E<gt>B<nested()> + + $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<undef> is returned. + +=cut + +sub nested { + my $self = shift; + (@_ == 1) and $self->{'-parent_sequence'} = shift; + return $self->{'-parent_sequence'} || undef; +} + +##--------------------------------------------------------------------------- + +=head2 $pod_seq-E<gt>B<raw_text()> + + my $seq_raw_text = $pod_seq->raw_text(); + +This method will return the I<raw> 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-E<gt>B<left_delimiter()> + + 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-E<gt>B<right_delimiter()> + +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-E<gt>B<parse_tree()> + + 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-E<gt>B<file_line()> + + 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'} || '<unknown-file>', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +=head2 Pod::InteriorSequence::B<DESTROY()> + +This method performs any necessary cleanup for the interior-sequence. +If you override this method then it is B<imperative> that you invoke +the parent method from within your own method, otherwise +I<interior-sequence storage will not be reclaimed upon destruction!> + +=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<Pod::ParseTree> + +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<Pod::InteriorSequence> objects (in order of +appearance). A B<Pod::ParseTree> 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-E<gt>B<new()> + + 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<Pod::Parse_tree> 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-E<gt>B<top()> + + 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<Pod::ParseTree>. 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-E<gt>B<children()> + +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<Pod::InteriorSequence>. +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-E<gt>B<prepend()> + +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<before> +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-E<gt>B<append()> + +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<after> +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-E<gt>B<raw_text()> + + my $ptree_raw_text = $ptree->raw_text(); + +This method will return the I<raw> 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<DESTROY()> + +This method performs any necessary cleanup for the parse-tree. +If you override this method then it is B<imperative> +that you invoke the parent method from within your own method, +otherwise I<parse-tree storage will not be reclaimed upon destruction!> + +=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 + +See L<Pod::Parser>, L<Pod::Select> + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm b/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm new file mode 100644 index 00000000000..9d3a905258f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm @@ -0,0 +1,1876 @@ +package Pod::LaTeX; + +=head1 NAME + +Pod::LaTeX - Convert Pod data to formatted Latex + +=head1 SYNOPSIS + + use Pod::LaTeX; + my $parser = Pod::LaTeX->new ( ); + + $parser->parse_from_filehandle; + + $parser->parse_from_file ('file.pod', 'file.tex'); + +=head1 DESCRIPTION + +C<Pod::LaTeX> is a module to convert documentation in the Pod format +into Latex. The L<B<pod2latex>|pod2latex> X<pod2latex> command uses +this module for translation. + +C<Pod::LaTeX> is a derived class from L<Pod::Select|Pod::Select>. + +=cut + + +use strict; +require Pod::ParseUtils; +use base qw/ Pod::Select /; + +# use Data::Dumper; # for debugging +use Carp; + +use vars qw/ $VERSION %HTML_Escapes @LatexSections /; + +$VERSION = '0.58'; + +# Definitions of =headN -> latex mapping +@LatexSections = (qw/ + chapter + section + subsection + subsubsection + paragraph + subparagraph + /); + +# Standard escape sequences converted to Latex. +# The Unicode name of each character is given in the comments. +# Complete LaTeX set added by Peter Acklam. + +%HTML_Escapes = ( + 'sol' => '\textfractionsolidus{}', # xxx - or should it be just '/' + 'verbar' => '|', + + # The stuff below is based on the information available at + # http://www.w3.org/TR/html401/sgml/entities.html + + # All characters in the range 0xA0-0xFF of the ISO 8859-1 character set. + # Several of these characters require the `textcomp' LaTeX package. + 'nbsp' => q|~|, # 0xA0 - no-break space = non-breaking space + 'iexcl' => q|\textexclamdown{}|, # 0xA1 - inverted exclamation mark + 'cent' => q|\textcent{}|, # 0xA2 - cent sign + 'pound' => q|\textsterling{}|, # 0xA3 - pound sign + 'curren' => q|\textcurrency{}|, # 0xA4 - currency sign + 'yen' => q|\textyen{}|, # 0xA5 - yen sign = yuan sign + 'brvbar' => q|\textbrokenbar{}|, # 0xA6 - broken bar = broken vertical bar + 'sect' => q|\textsection{}|, # 0xA7 - section sign + 'uml' => q|\textasciidieresis{}|, # 0xA8 - diaeresis = spacing diaeresis + 'copy' => q|\textcopyright{}|, # 0xA9 - copyright sign + 'ordf' => q|\textordfeminine{}|, # 0xAA - feminine ordinal indicator + 'laquo' => q|\guillemotleft{}|, # 0xAB - left-pointing double angle quotation mark = left pointing guillemet + 'not' => q|\textlnot{}|, # 0xAC - not sign + 'shy' => q|\-|, # 0xAD - soft hyphen = discretionary hyphen + 'reg' => q|\textregistered{}|, # 0xAE - registered sign = registered trade mark sign + 'macr' => q|\textasciimacron{}|, # 0xAF - macron = spacing macron = overline = APL overbar + 'deg' => q|\textdegree{}|, # 0xB0 - degree sign + 'plusmn' => q|\textpm{}|, # 0xB1 - plus-minus sign = plus-or-minus sign + 'sup2' => q|\texttwosuperior{}|, # 0xB2 - superscript two = superscript digit two = squared + 'sup3' => q|\textthreesuperior{}|, # 0xB3 - superscript three = superscript digit three = cubed + 'acute' => q|\textasciiacute{}|, # 0xB4 - acute accent = spacing acute + 'micro' => q|\textmu{}|, # 0xB5 - micro sign + 'para' => q|\textparagraph{}|, # 0xB6 - pilcrow sign = paragraph sign + 'middot' => q|\textperiodcentered{}|, # 0xB7 - middle dot = Georgian comma = Greek middle dot + 'cedil' => q|\c{}|, # 0xB8 - cedilla = spacing cedilla + 'sup1' => q|\textonesuperior{}|, # 0xB9 - superscript one = superscript digit one + 'ordm' => q|\textordmasculine{}|, # 0xBA - masculine ordinal indicator + 'raquo' => q|\guillemotright{}|, # 0xBB - right-pointing double angle quotation mark = right pointing guillemet + 'frac14' => q|\textonequarter{}|, # 0xBC - vulgar fraction one quarter = fraction one quarter + 'frac12' => q|\textonehalf{}|, # 0xBD - vulgar fraction one half = fraction one half + 'frac34' => q|\textthreequarters{}|, # 0xBE - vulgar fraction three quarters = fraction three quarters + 'iquest' => q|\textquestiondown{}|, # 0xBF - inverted question mark = turned question mark + 'Agrave' => q|\`A|, # 0xC0 - latin capital letter A with grave = latin capital letter A grave + 'Aacute' => q|\'A|, # 0xC1 - latin capital letter A with acute + 'Acirc' => q|\^A|, # 0xC2 - latin capital letter A with circumflex + 'Atilde' => q|\~A|, # 0xC3 - latin capital letter A with tilde + 'Auml' => q|\"A|, # 0xC4 - latin capital letter A with diaeresis + 'Aring' => q|\AA{}|, # 0xC5 - latin capital letter A with ring above = latin capital letter A ring + 'AElig' => q|\AE{}|, # 0xC6 - latin capital letter AE = latin capital ligature AE + 'Ccedil' => q|\c{C}|, # 0xC7 - latin capital letter C with cedilla + 'Egrave' => q|\`E|, # 0xC8 - latin capital letter E with grave + 'Eacute' => q|\'E|, # 0xC9 - latin capital letter E with acute + 'Ecirc' => q|\^E|, # 0xCA - latin capital letter E with circumflex + 'Euml' => q|\"E|, # 0xCB - latin capital letter E with diaeresis + 'Igrave' => q|\`I|, # 0xCC - latin capital letter I with grave + 'Iacute' => q|\'I|, # 0xCD - latin capital letter I with acute + 'Icirc' => q|\^I|, # 0xCE - latin capital letter I with circumflex + 'Iuml' => q|\"I|, # 0xCF - latin capital letter I with diaeresis + 'ETH' => q|\DH{}|, # 0xD0 - latin capital letter ETH + 'Ntilde' => q|\~N|, # 0xD1 - latin capital letter N with tilde + 'Ograve' => q|\`O|, # 0xD2 - latin capital letter O with grave + 'Oacute' => q|\'O|, # 0xD3 - latin capital letter O with acute + 'Ocirc' => q|\^O|, # 0xD4 - latin capital letter O with circumflex + 'Otilde' => q|\~O|, # 0xD5 - latin capital letter O with tilde + 'Ouml' => q|\"O|, # 0xD6 - latin capital letter O with diaeresis + 'times' => q|\texttimes{}|, # 0xD7 - multiplication sign + 'Oslash' => q|\O{}|, # 0xD8 - latin capital letter O with stroke = latin capital letter O slash + 'Ugrave' => q|\`U|, # 0xD9 - latin capital letter U with grave + 'Uacute' => q|\'U|, # 0xDA - latin capital letter U with acute + 'Ucirc' => q|\^U|, # 0xDB - latin capital letter U with circumflex + 'Uuml' => q|\"U|, # 0xDC - latin capital letter U with diaeresis + 'Yacute' => q|\'Y|, # 0xDD - latin capital letter Y with acute + 'THORN' => q|\TH{}|, # 0xDE - latin capital letter THORN + 'szlig' => q|\ss{}|, # 0xDF - latin small letter sharp s = ess-zed + 'agrave' => q|\`a|, # 0xE0 - latin small letter a with grave = latin small letter a grave + 'aacute' => q|\'a|, # 0xE1 - latin small letter a with acute + 'acirc' => q|\^a|, # 0xE2 - latin small letter a with circumflex + 'atilde' => q|\~a|, # 0xE3 - latin small letter a with tilde + 'auml' => q|\"a|, # 0xE4 - latin small letter a with diaeresis + 'aring' => q|\aa{}|, # 0xE5 - latin small letter a with ring above = latin small letter a ring + 'aelig' => q|\ae{}|, # 0xE6 - latin small letter ae = latin small ligature ae + 'ccedil' => q|\c{c}|, # 0xE7 - latin small letter c with cedilla + 'egrave' => q|\`e|, # 0xE8 - latin small letter e with grave + 'eacute' => q|\'e|, # 0xE9 - latin small letter e with acute + 'ecirc' => q|\^e|, # 0xEA - latin small letter e with circumflex + 'euml' => q|\"e|, # 0xEB - latin small letter e with diaeresis + 'igrave' => q|\`i|, # 0xEC - latin small letter i with grave + 'iacute' => q|\'i|, # 0xED - latin small letter i with acute + 'icirc' => q|\^i|, # 0xEE - latin small letter i with circumflex + 'iuml' => q|\"i|, # 0xEF - latin small letter i with diaeresis + 'eth' => q|\dh{}|, # 0xF0 - latin small letter eth + 'ntilde' => q|\~n|, # 0xF1 - latin small letter n with tilde + 'ograve' => q|\`o|, # 0xF2 - latin small letter o with grave + 'oacute' => q|\'o|, # 0xF3 - latin small letter o with acute + 'ocirc' => q|\^o|, # 0xF4 - latin small letter o with circumflex + 'otilde' => q|\~o|, # 0xF5 - latin small letter o with tilde + 'ouml' => q|\"o|, # 0xF6 - latin small letter o with diaeresis + 'divide' => q|\textdiv{}|, # 0xF7 - division sign + 'oslash' => q|\o{}|, # 0xF8 - latin small letter o with stroke, = latin small letter o slash + 'ugrave' => q|\`u|, # 0xF9 - latin small letter u with grave + 'uacute' => q|\'u|, # 0xFA - latin small letter u with acute + 'ucirc' => q|\^u|, # 0xFB - latin small letter u with circumflex + 'uuml' => q|\"u|, # 0xFC - latin small letter u with diaeresis + 'yacute' => q|\'y|, # 0xFD - latin small letter y with acute + 'thorn' => q|\th{}|, # 0xFE - latin small letter thorn + 'yuml' => q|\"y|, # 0xFF - latin small letter y with diaeresis + + # Latin Extended-B + 'fnof' => q|\textflorin{}|, # latin small f with hook = function = florin + + # Greek + 'Alpha' => q|$\mathrm{A}$|, # greek capital letter alpha + 'Beta' => q|$\mathrm{B}$|, # greek capital letter beta + 'Gamma' => q|$\Gamma$|, # greek capital letter gamma + 'Delta' => q|$\Delta$|, # greek capital letter delta + 'Epsilon' => q|$\mathrm{E}$|, # greek capital letter epsilon + 'Zeta' => q|$\mathrm{Z}$|, # greek capital letter zeta + 'Eta' => q|$\mathrm{H}$|, # greek capital letter eta + 'Theta' => q|$\Theta$|, # greek capital letter theta + 'Iota' => q|$\mathrm{I}$|, # greek capital letter iota + 'Kappa' => q|$\mathrm{K}$|, # greek capital letter kappa + 'Lambda' => q|$\Lambda$|, # greek capital letter lambda + 'Mu' => q|$\mathrm{M}$|, # greek capital letter mu + 'Nu' => q|$\mathrm{N}$|, # greek capital letter nu + 'Xi' => q|$\Xi$|, # greek capital letter xi + 'Omicron' => q|$\mathrm{O}$|, # greek capital letter omicron + 'Pi' => q|$\Pi$|, # greek capital letter pi + 'Rho' => q|$\mathrm{R}$|, # greek capital letter rho + 'Sigma' => q|$\Sigma$|, # greek capital letter sigma + 'Tau' => q|$\mathrm{T}$|, # greek capital letter tau + 'Upsilon' => q|$\Upsilon$|, # greek capital letter upsilon + 'Phi' => q|$\Phi$|, # greek capital letter phi + 'Chi' => q|$\mathrm{X}$|, # greek capital letter chi + 'Psi' => q|$\Psi$|, # greek capital letter psi + 'Omega' => q|$\Omega$|, # greek capital letter omega + + 'alpha' => q|$\alpha$|, # greek small letter alpha + 'beta' => q|$\beta$|, # greek small letter beta + 'gamma' => q|$\gamma$|, # greek small letter gamma + 'delta' => q|$\delta$|, # greek small letter delta + 'epsilon' => q|$\epsilon$|, # greek small letter epsilon + 'zeta' => q|$\zeta$|, # greek small letter zeta + 'eta' => q|$\eta$|, # greek small letter eta + 'theta' => q|$\theta$|, # greek small letter theta + 'iota' => q|$\iota$|, # greek small letter iota + 'kappa' => q|$\kappa$|, # greek small letter kappa + 'lambda' => q|$\lambda$|, # greek small letter lambda + 'mu' => q|$\mu$|, # greek small letter mu + 'nu' => q|$\nu$|, # greek small letter nu + 'xi' => q|$\xi$|, # greek small letter xi + 'omicron' => q|$o$|, # greek small letter omicron + 'pi' => q|$\pi$|, # greek small letter pi + 'rho' => q|$\rho$|, # greek small letter rho +# 'sigmaf' => q||, # greek small letter final sigma + 'sigma' => q|$\sigma$|, # greek small letter sigma + 'tau' => q|$\tau$|, # greek small letter tau + 'upsilon' => q|$\upsilon$|, # greek small letter upsilon + 'phi' => q|$\phi$|, # greek small letter phi + 'chi' => q|$\chi$|, # greek small letter chi + 'psi' => q|$\psi$|, # greek small letter psi + 'omega' => q|$\omega$|, # greek small letter omega +# 'thetasym' => q||, # greek small letter theta symbol +# 'upsih' => q||, # greek upsilon with hook symbol +# 'piv' => q||, # greek pi symbol + + # General Punctuation + 'bull' => q|\textbullet{}|, # bullet = black small circle + # bullet is NOT the same as bullet operator + 'hellip' => q|\textellipsis{}|, # horizontal ellipsis = three dot leader + 'prime' => q|\textquotesingle{}|, # prime = minutes = feet + 'Prime' => q|\textquotedbl{}|, # double prime = seconds = inches + 'oline' => q|\textasciimacron{}|, # overline = spacing overscore + 'frasl' => q|\textfractionsolidus{}|, # fraction slash + + # Letterlike Symbols + 'weierp' => q|$\wp$|, # script capital P = power set = Weierstrass p + 'image' => q|$\Re$|, # blackletter capital I = imaginary part + 'real' => q|$\Im$|, # blackletter capital R = real part symbol + 'trade' => q|\texttrademark{}|, # trade mark sign +# 'alefsym' => q||, # alef symbol = first transfinite cardinal + # alef symbol is NOT the same as hebrew letter alef, although the same + # glyph could be used to depict both characters + + # Arrows + 'larr' => q|\textleftarrow{}|, # leftwards arrow + 'uarr' => q|\textuparrow{}|, # upwards arrow + 'rarr' => q|\textrightarrow{}|, # rightwards arrow + 'darr' => q|\textdownarrow{}|, # downwards arrow + 'harr' => q|$\leftrightarrow$|, # left right arrow +# 'crarr' => q||, # downwards arrow with corner leftwards = carriage return + 'lArr' => q|$\Leftarrow$|, # leftwards double arrow + # ISO 10646 does not say that lArr is the same as the 'is implied by' + # arrow but also does not have any other character for that function. So + # lArr can be used for 'is implied by' as ISOtech suggests + 'uArr' => q|$\Uparrow$|, # upwards double arrow + 'rArr' => q|$\Rightarrow$|, # rightwards double arrow + # ISO 10646 does not say this is the 'implies' character but does not + # have another character with this function so ? rArr can be used for + # 'implies' as ISOtech suggests + 'dArr' => q|$\Downarrow$|, # downwards double arrow + 'hArr' => q|$\Leftrightarrow$|, # left right double arrow + + # Mathematical Operators. + # Some of these require the `amssymb' package. + 'forall' => q|$\forall$|, # for all + 'part' => q|$\partial$|, # partial differential + 'exist' => q|$\exists$|, # there exists + 'empty' => q|$\emptyset$|, # empty set = null set = diameter + 'nabla' => q|$\nabla$|, # nabla = backward difference + 'isin' => q|$\in$|, # element of + 'notin' => q|$\notin$|, # not an element of + 'ni' => q|$\ni$|, # contains as member + 'prod' => q|$\prod$|, # n-ary product = product sign + # prod is NOT the same character as 'greek capital letter pi' though the + # same glyph might be used for both + 'sum' => q|$\sum$|, # n-ary sumation + # sum is NOT the same character as 'greek capital letter sigma' though + # the same glyph might be used for both + 'minus' => q|$-$|, # minus sign + 'lowast' => q|$\ast$|, # asterisk operator + 'radic' => q|$\surd$|, # square root = radical sign + 'prop' => q|$\propto$|, # proportional to + 'infin' => q|$\infty$|, # infinity + 'ang' => q|$\angle$|, # angle + 'and' => q|$\wedge$|, # logical and = wedge + 'or' => q|$\vee$|, # logical or = vee + 'cap' => q|$\cap$|, # intersection = cap + 'cup' => q|$\cup$|, # union = cup + 'int' => q|$\int$|, # integral + 'there4' => q|$\therefore$|, # therefore + 'sim' => q|$\sim$|, # tilde operator = varies with = similar to + # tilde operator is NOT the same character as the tilde + 'cong' => q|$\cong$|, # approximately equal to + 'asymp' => q|$\asymp$|, # almost equal to = asymptotic to + 'ne' => q|$\neq$|, # not equal to + 'equiv' => q|$\equiv$|, # identical to + 'le' => q|$\leq$|, # less-than or equal to + 'ge' => q|$\geq$|, # greater-than or equal to + 'sub' => q|$\subset$|, # subset of + 'sup' => q|$\supset$|, # superset of + # note that nsup, 'not a superset of' is not covered by the Symbol font + # encoding and is not included. + 'nsub' => q|$\not\subset$|, # not a subset of + 'sube' => q|$\subseteq$|, # subset of or equal to + 'supe' => q|$\supseteq$|, # superset of or equal to + 'oplus' => q|$\oplus$|, # circled plus = direct sum + 'otimes' => q|$\otimes$|, # circled times = vector product + 'perp' => q|$\perp$|, # up tack = orthogonal to = perpendicular + 'sdot' => q|$\cdot$|, # dot operator + # dot operator is NOT the same character as middle dot + + # Miscellaneous Technical + 'lceil' => q|$\lceil$|, # left ceiling = apl upstile + 'rceil' => q|$\rceil$|, # right ceiling + 'lfloor' => q|$\lfloor$|, # left floor = apl downstile + 'rfloor' => q|$\rfloor$|, # right floor + 'lang' => q|$\langle$|, # left-pointing angle bracket = bra + # lang is NOT the same character as 'less than' or 'single left-pointing + # angle quotation mark' + 'rang' => q|$\rangle$|, # right-pointing angle bracket = ket + # rang is NOT the same character as 'greater than' or 'single + # right-pointing angle quotation mark' + + # Geometric Shapes + 'loz' => q|$\lozenge$|, # lozenge + + # Miscellaneous Symbols + 'spades' => q|$\spadesuit$|, # black spade suit + 'clubs' => q|$\clubsuit$|, # black club suit = shamrock + 'hearts' => q|$\heartsuit$|, # black heart suit = valentine + 'diams' => q|$\diamondsuit$|, # black diamond suit + + # C0 Controls and Basic Latin + 'quot' => q|"|, # quotation mark = APL quote ["] + 'amp' => q|\&|, # ampersand + 'lt' => q|<|, # less-than sign + 'gt' => q|>|, # greater-than sign + 'OElig' => q|\OE{}|, # latin capital ligature OE + 'oelig' => q|\oe{}|, # latin small ligature oe + 'Scaron' => q|\v{S}|, # latin capital letter S with caron + 'scaron' => q|\v{s}|, # latin small letter s with caron + 'Yuml' => q|\"Y|, # latin capital letter Y with diaeresis + 'circ' => q|\textasciicircum{}|, # modifier letter circumflex accent + 'tilde' => q|\textasciitilde{}|, # small tilde + 'ensp' => q|\phantom{n}|, # en space + 'emsp' => q|\hspace{1em}|, # em space + 'thinsp' => q|\,|, # thin space + 'zwnj' => q|{}|, # zero width non-joiner +# 'zwj' => q||, # zero width joiner +# 'lrm' => q||, # left-to-right mark +# 'rlm' => q||, # right-to-left mark + 'ndash' => q|--|, # en dash + 'mdash' => q|---|, # em dash + 'lsquo' => q|\textquoteleft{}|, # left single quotation mark + 'rsquo' => q|\textquoteright{}|, # right single quotation mark + 'sbquo' => q|\quotesinglbase{}|, # single low-9 quotation mark + 'ldquo' => q|\textquotedblleft{}|, # left double quotation mark + 'rdquo' => q|\textquotedblright{}|, # right double quotation mark + 'bdquo' => q|\quotedblbase{}|, # double low-9 quotation mark + 'dagger' => q|\textdagger{}|, # dagger + 'Dagger' => q|\textdaggerdbl{}|, # double dagger + 'permil' => q|\textperthousand{}|, # per mille sign + 'lsaquo' => q|\guilsinglleft{}|, # single left-pointing angle quotation mark + 'rsaquo' => q|\guilsinglright{}|, # single right-pointing angle quotation mark + 'euro' => q|\texteuro{}|, # euro sign +); + +=head1 OBJECT METHODS + +The following methods are provided in this module. Methods inherited +from C<Pod::Select> are not described in the public interface. + +=over 4 + +=begin __PRIVATE__ + +=item C<initialize> + +Initialise the object. This method is subclassed from C<Pod::Parser>. +The base class method is invoked. This method defines the default +behaviour of the object unless overridden by supplying arguments to +the constructor. + +Internal settings are defaulted as well as the public instance data. +Internal hash values are accessed directly (rather than through +a method) and start with an underscore. + +This method should not be invoked by the user directly. + +=end __PRIVATE__ + +=cut + + + +# - An array for nested lists + +# Arguments have already been read by this point + +sub initialize { + my $self = shift; + + # print Dumper($self); + + # Internals + $self->{_Lists} = []; # For nested lists + $self->{_suppress_all_para} = 0; # For =begin blocks + $self->{_dont_modify_any_para}=0; # For =begin blocks + $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section + + # Options - only initialise if not already set + + # Cause the '=head1 NAME' field to be treated specially + # The contents of the NAME paragraph will be converted + # to a section title. All subsequent =head1 will be converted + # to =head2 and down. Will not affect =head1's prior to NAME + # Assumes: 'Module - purpose' format + # Also creates a purpose field + # The name is used for Labeling of the subsequent subsections + $self->{ReplaceNAMEwithSection} = 0 + unless exists $self->{ReplaceNAMEwithSection}; + $self->{AddPreamble} = 1 # make full latex document + unless exists $self->{AddPreamble}; + $self->{StartWithNewPage} = 0 # Start new page for pod section + unless exists $self->{StartWithNewPage}; + $self->{TableOfContents} = 0 # Add table of contents + unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1 + $self->{AddPostamble} = 1 # Add closing latex code at end + unless exists $self->{AddPostamble}; # effectively end{document} and index + $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble + unless exists $self->{MakeIndex}; # and AddPreamble) + + $self->{UniqueLabels} = 1 # Use label unique for each pod + unless exists $self->{UniqueLabels}; # either based on the filename + # or supplied + + # Control the level of =head1. default is \section + # + $self->{Head1Level} = 1 # Offset in latex sections + unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection + + # Control at which level numbering of sections is turned off + # ie subsection becomes subsection* + # The numbering is relative to the latex sectioning commands + # and is independent of Pod heading level + # default is to number \section but not \subsection + $self->{LevelNoNum} = 2 + unless exists $self->{LevelNoNum}; + + # Label to be used as prefix to all internal section names + # If not defined will attempt to derive it from the filename + # This can not happen when running parse_from_filehandle though + # hence the ability to set the label externally + # The label could then be Pod::Parser_DESCRIPTION or somesuch + + $self->{Label} = undef # label to be used as prefix + unless exists $self->{Label}; # to all internal section names + + # These allow the caller to add arbritrary latex code to + # start and end of document. AddPreamble and AddPostamble are ignored + # if these are set. + # Also MakeIndex and TableOfContents are also ignored. + $self->{UserPreamble} = undef # User supplied start (AddPreamble =1) + unless exists $self->{Label}; + $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1) + unless exists $self->{Label}; + + # Run base initialize + $self->SUPER::initialize; + +} + +=back + +=head2 Data Accessors + +The following methods are provided for accessing instance data. These +methods should be used for accessing configuration parameters rather +than assuming the object is a hash. + +Default values can be supplied by using these names as keys to a hash +of arguments when using the C<new()> constructor. + +=over 4 + +=item B<AddPreamble> + +Logical to control whether a C<latex> preamble is to be written. +If true, a valid C<latex> preamble is written before the pod data is written. +This is similar to: + + \documentclass{article} + \usepackage[T1]{fontenc} + \usepackage{textcomp} + \begin{document} + +but will be more complicated if table of contents and indexing are required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPreamble(); + $parser->AddPreamble(1); + +If used in conjunction with C<AddPostamble> a full latex document will +be written that could be immediately processed by C<latex>. + +For some pod escapes it may be necessary to include the amsmath +package. This is not yet added to the preamble automaatically. + +=cut + +sub AddPreamble { + my $self = shift; + if (@_) { + $self->{AddPreamble} = shift; + } + return $self->{AddPreamble}; +} + +=item B<AddPostamble> + +Logical to control whether a standard C<latex> ending is written to the output +file after the document has been processed. +In its simplest form this is simply: + + \end{document} + +but can be more complicated if a index is required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPostamble(); + $parser->AddPostamble(1); + +If used in conjunction with C<AddPreaamble> a full latex document will +be written that could be immediately processed by C<latex>. + +=cut + +sub AddPostamble { + my $self = shift; + if (@_) { + $self->{AddPostamble} = shift; + } + return $self->{AddPostamble}; +} + +=item B<Head1Level> + +The C<latex> sectioning level that should be used to correspond to +a pod C<=head1> directive. This can be used, for example, to turn +a C<=head1> into a C<latex> C<subsection>. This should hold a number +corresponding to the required position in an array containing the +following elements: + + [0] chapter + [1] section + [2] subsection + [3] subsubsection + [4] paragraph + [5] subparagraph + +Can be used to set or retrieve the current value: + + $parser->Head1Level(2); + $sect = $parser->Head1Level; + +Setting this number too high can result in sections that may not be reproducible +in the expected way. For example, setting this to 4 would imply that C<=head3> +do not have a corresponding C<latex> section (C<=head1> would correspond to +a C<paragraph>). + +A check is made to ensure that the supplied value is an integer in the +range 0 to 5. + +Default is for a value of 1 (i.e. a C<section>). + +=cut + +sub Head1Level { + my $self = shift; + if (@_) { + my $arg = shift; + if ($arg =~ /^\d$/ && $arg <= $#LatexSections) { + $self->{Head1Level} = $arg; + } else { + carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n"; + } + } + return $self->{Head1Level}; +} + +=item B<Label> + +This is the label that is prefixed to all C<latex> label and index +entries to make them unique. In general, pods have similarly titled +sections (NAME, DESCRIPTION etc) and a C<latex> label will be multiply +defined if more than one pod document is to be included in a single +C<latex> file. To overcome this, this label is prefixed to a label +whenever a label is required (joined with an underscore) or to an +index entry (joined by an exclamation mark which is the normal index +separator). For example, C<\label{text}> becomes C<\label{Label_text}>. + +Can be used to set or retrieve the current value: + + $label = $parser->Label; + $parser->Label($label); + +This label is only used if C<UniqueLabels> is true. +Its value is set automatically from the C<NAME> field +if C<ReplaceNAMEwithSection> is true. If this is not the case +it must be set manually before starting the parse. + +Default value is C<undef>. + +=cut + +sub Label { + my $self = shift; + if (@_) { + $self->{Label} = shift; + } + return $self->{Label}; +} + +=item B<LevelNoNum> + +Control the point at which C<latex> section numbering is turned off. +For example, this can be used to make sure that C<latex> sections +are numbered but subsections are not. + +Can be used to set or retrieve the current value: + + $lev = $parser->LevelNoNum; + $parser->LevelNoNum(2); + +The argument must be an integer between 0 and 5 and is the same as the +number described in C<Head1Level> method description. The number has +nothing to do with the pod heading number, only the C<latex> sectioning. + +Default is 2. (i.e. C<latex> subsections are written as C<subsection*> +but sections are numbered). + +=cut + +sub LevelNoNum { + my $self = shift; + if (@_) { + $self->{LevelNoNum} = shift; + } + return $self->{LevelNoNum}; +} + +=item B<MakeIndex> + +Controls whether C<latex> commands for creating an index are to be inserted +into the preamble and postamble + + $makeindex = $parser->MakeIndex; + $parser->MakeIndex(0); + +Irrelevant if both C<AddPreamble> and C<AddPostamble> are false (or equivalently, +C<UserPreamble> and C<UserPostamble> are set). + +Default is for an index to be created. + +=cut + +sub MakeIndex { + my $self = shift; + if (@_) { + $self->{MakeIndex} = shift; + } + return $self->{MakeIndex}; +} + +=item B<ReplaceNAMEwithSection> + +This controls whether the C<NAME> section in the pod is to be translated +literally or converted to a slightly modified output where the section +name is the pod name rather than "NAME". + +If true, the pod segment + + =head1 NAME + + pod::name - purpose + + =head1 SYNOPSIS + +is converted to the C<latex> + + \section{pod::name\label{pod_name}\index{pod::name}} + + Purpose + + \subsection*{SYNOPSIS\label{pod_name_SYNOPSIS}% + \index{pod::name!SYNOPSIS}} + +(dependent on the value of C<Head1Level> and C<LevelNoNum>). Note that +subsequent C<head1> directives translate to subsections rather than +sections and that the labels and index now include the pod name (dependent +on the value of C<UniqueLabels>). + +The C<Label> is set from the pod name regardless of any current value +of C<Label>. + + $mod = $parser->ReplaceNAMEwithSection; + $parser->ReplaceNAMEwithSection(0); + +Default is to translate the pod literally. + +=cut + +sub ReplaceNAMEwithSection { + my $self = shift; + if (@_) { + $self->{ReplaceNAMEwithSection} = shift; + } + return $self->{ReplaceNAMEwithSection}; +} + +=item B<StartWithNewPage> + +If true, each pod translation will begin with a C<latex> +C<\clearpage>. + + $parser->StartWithNewPage(1); + $newpage = $parser->StartWithNewPage; + +Default is false. + +=cut + +sub StartWithNewPage { + my $self = shift; + if (@_) { + $self->{StartWithNewPage} = shift; + } + return $self->{StartWithNewPage}; +} + +=item B<TableOfContents> + +If true, a table of contents will be created. +Irrelevant if C<AddPreamble> is false or C<UserPreamble> +is set. + + $toc = $parser->TableOfContents; + $parser->TableOfContents(1); + +Default is false. + +=cut + +sub TableOfContents { + my $self = shift; + if (@_) { + $self->{TableOfContents} = shift; + } + return $self->{TableOfContents}; +} + +=item B<UniqueLabels> + +If true, the translator will attempt to make sure that +each C<latex> label or index entry will be uniquely identified +by prefixing the contents of C<Label>. This allows +multiple documents to be combined without clashing +common labels such as C<DESCRIPTION> and C<SYNOPSIS> + + $parser->UniqueLabels(1); + $unq = $parser->UniqueLabels; + +Default is true. + +=cut + +sub UniqueLabels { + my $self = shift; + if (@_) { + $self->{UniqueLabels} = shift; + } + return $self->{UniqueLabels}; +} + +=item B<UserPreamble> + +User supplied C<latex> preamble. Added before the pod translation +data. + +If set, the contents will be prepended to the output file before the translated +data regardless of the value of C<AddPreamble>. +C<MakeIndex> and C<TableOfContents> will also be ignored. + +=cut + +sub UserPreamble { + my $self = shift; + if (@_) { + $self->{UserPreamble} = shift; + } + return $self->{UserPreamble}; +} + +=item B<UserPostamble> + +User supplied C<latex> postamble. Added after the pod translation +data. + +If set, the contents will be prepended to the output file after the translated +data regardless of the value of C<AddPostamble>. +C<MakeIndex> will also be ignored. + +=cut + +sub UserPostamble { + my $self = shift; + if (@_) { + $self->{UserPostamble} = shift; + } + return $self->{UserPostamble}; +} + +=begin __PRIVATE__ + +=item B<Lists> + +Contains details of the currently active lists. + The array contains C<Pod::List> objects. A new C<Pod::List> +object is created each time a list is encountered and it is +pushed onto this stack. When the list context ends, it +is popped from the stack. The array will be empty if no +lists are active. + +Returns array of list information in list context +Returns array ref in scalar context + +=cut + + + +sub lists { + my $self = shift; + return @{ $self->{_Lists} } if wantarray(); + return $self->{_Lists}; +} + +=end __PRIVATE__ + +=back + +=begin __PRIVATE__ + +=head2 Subclassed methods + +The following methods override methods provided in the C<Pod::Select> +base class. See C<Pod::Parser> and C<Pod::Select> for more information +on what these methods require. + +=over 4 + +=cut + +######### END ACCESSORS ################### + +# Opening pod + +=item B<begin_pod> + +Writes the C<latex> preamble if requested. Only writes something +if AddPreamble is true. Writes a standard header unless a UserPreamble +is defined. + +=cut + +sub begin_pod { + my $self = shift; + + # Get the pod identification + # This should really come from the '=head1 NAME' paragraph + + my $infile = $self->input_file; + my $class = ref($self); + my $date = gmtime(time); + + # Comment message to say where this came from + my $comment = << "__TEX_COMMENT__"; +%% Latex generated from POD in document $infile +%% Using the perl module $class +%% Converted on $date +__TEX_COMMENT__ + + # Write the preamble + # If the caller has supplied one then we just use that + + my $preamble = ''; + + if ($self->AddPreamble) { + + if (defined $self->UserPreamble) { + + $preamble = $self->UserPreamble; + + # Add the description of where this came from + $preamble .= "\n$comment\n%% Preamble supplied by user.\n\n"; + + } else { + + # Write our own preamble + + # Code to initialise index making + # Use an array so that we can prepend comment if required + my @makeidx = ( + '\usepackage{makeidx}', + '\makeindex', + ); + + unless ($self->MakeIndex) { + foreach (@makeidx) { + $_ = '%% ' . $_; + } + } + my $makeindex = join("\n",@makeidx) . "\n"; + + # Table of contents + my $tableofcontents = '\tableofcontents'; + + $tableofcontents = '%% ' . $tableofcontents + unless $self->TableOfContents; + + # Roll our own + $preamble = << "__TEX_HEADER__"; +\\documentclass{article} +\\usepackage[T1]{fontenc} +\\usepackage{textcomp} + +$comment + +$makeindex + +\\begin{document} + +$tableofcontents + +__TEX_HEADER__ + + } + } + + # Write the header (blank if none) + $self->_output($preamble); + + # Start on new page if requested + $self->_output("\\clearpage\n") if $self->StartWithNewPage; + +} + + +=item B<end_pod> + +Write the closing C<latex> code. Only writes something if AddPostamble +is true. Writes a standard header unless a UserPostamble is defined. + +=cut + +sub end_pod { + my $self = shift; + + # End string + my $end = ''; + + # Use the user version of the postamble if defined + if ($self->AddPostamble) { + + if (defined $self->UserPostamble) { + $end = $self->UserPostamble; + + } else { + + # Check for index + my $makeindex = '\printindex'; + + $makeindex = '%% '. $makeindex unless $self->MakeIndex; + + $end = "$makeindex\n\n\\end{document}\n"; + } + } + + $self->_output($end); + +} + +=item B<command> + +Process basic pod commands. + +=cut + +sub command { + my $self = shift; + my ($command, $paragraph, $line_num, $parobj) = @_; + + # return if we dont care + return if $command eq 'pod'; + + # Store a copy of the raw text in case we are in a =for + # block and need to preserve the existing latex + my $rawpara = $paragraph; + + # Do the latex escapes + $paragraph = $self->_replace_special_chars($paragraph); + + # Interpolate pod sequences in paragraph + $paragraph = $self->interpolate($paragraph, $line_num); + $paragraph =~ s/\s+$//; + + # Replace characters that can only be done after + # interpolation of interior sequences + $paragraph = $self->_replace_special_chars_late($paragraph); + + # Now run the command + if ($command eq 'over') { + + $self->begin_list($paragraph, $line_num); + + } elsif ($command eq 'item') { + + $self->add_item($paragraph, $line_num); + + } elsif ($command eq 'back') { + + $self->end_list($line_num); + + } elsif ($command eq 'head1') { + + # Store the name of the section + $self->{_CURRENT_HEAD1} = $paragraph; + + # Print it + $self->head(1, $paragraph, $parobj); + + } elsif ($command eq 'head2') { + + $self->head(2, $paragraph, $parobj); + + } elsif ($command eq 'head3') { + + $self->head(3, $paragraph, $parobj); + + } elsif ($command eq 'head4') { + + $self->head(4, $paragraph, $parobj); + + } elsif ($command eq 'head5') { + + $self->head(5, $paragraph, $parobj); + + } elsif ($command eq 'head6') { + + $self->head(6, $paragraph, $parobj); + + } elsif ($command eq 'begin') { + + # pass through if latex + if ($paragraph =~ /^latex/i) { + # Make sure that subsequent paragraphs are not modfied before printing + $self->{_dont_modify_any_para} = 1; + + } else { + # Suppress all subsequent paragraphs unless + # it is explcitly intended for latex + $self->{_suppress_all_para} = 1; + } + + } elsif ($command eq 'for') { + + # =for latex + # some latex + + # With =for we will get the text for the full paragraph + # as well as the format name. + # We do not get an additional paragraph later on. The next + # paragraph is not governed by the =for + + # The first line contains the format and the rest is the + # raw code. + my ($format, $chunk) = split(/\n/, $rawpara, 2); + + # If we have got some latex code print it out immediately + # unmodified. Else do nothing. + if ($format =~ /^latex/i) { + # Make sure that next paragraph is not modfied before printing + $self->_output( $chunk ); + + } + + } elsif ($command eq 'end') { + + # Reset suppression + $self->{_suppress_all_para} = 0; + $self->{_dont_modify_any_para} = 0; + + } elsif ($command eq 'pod') { + + # Do nothing + + } else { + carp "Command $command not recognised at line $line_num\n"; + } + +} + +=item B<verbatim> + +Verbatim text + +=cut + +sub verbatim { + my $self = shift; + my ($paragraph, $line_num, $parobj) = @_; + + # Expand paragraph unless in =begin block + if ($self->{_dont_modify_any_para}) { + # Just print as is + $self->_output($paragraph); + + } else { + + return if $paragraph =~ /^\s+$/; + + # Clean trailing space + $paragraph =~ s/\s+$//; + + # Clean tabs. Routine taken from Tabs.pm + # by David Muir Sharnoff muir@idiom.com, + # slightly modified by hsmyers@sdragons.com 10/22/01 + my @l = split("\n",$paragraph); + foreach (@l) { + 1 while s/(^|\n)([^\t\n]*)(\t+)/ + $1. $2 . (" " x + (8 * length($3) + - (length($2) % 8))) + /sex; + } + $paragraph = join("\n",@l); + # End of change. + + + + $self->_output('\begin{verbatim}' . "\n$paragraph\n". '\end{verbatim}'."\n"); + } +} + +=item B<textblock> + +Plain text paragraph. + +=cut + +sub textblock { + my $self = shift; + my ($paragraph, $line_num, $parobj) = @_; + + # print Dumper($self); + + # Expand paragraph unless in =begin block + if ($self->{_dont_modify_any_para}) { + # Just print as is + $self->_output($paragraph); + + return; + } + + + # Escape latex special characters + $paragraph = $self->_replace_special_chars($paragraph); + + # Interpolate interior sequences + my $expansion = $self->interpolate($paragraph, $line_num); + $expansion =~ s/\s+$//; + + # Escape special characters that can not be done earlier + $expansion = $self->_replace_special_chars_late($expansion); + + # If we are replacing 'head1 NAME' with a section + # we need to look in the paragraph and rewrite things + # Need to make sure this is called only on the first paragraph + # following 'head1 NAME' and not on subsequent paragraphs that may be + # present. + if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()) { + + # Strip white space from start and end + $paragraph =~ s/^\s+//; + $paragraph =~ s/\s$//; + + # Split the string into 2 parts + my ($name, $purpose) = split(/\s+-\s+/, $expansion,2); + + # Now prevent this from triggering until a new head1 NAME is set + $self->{_CURRENT_HEAD1} = '_NAME'; + + # Might want to clear the Label() before doing this (CHECK) + + # Print the heading + $self->head(1, $name, $parobj); + + # Set the labeling in case we want unique names later + $self->Label( $self->_create_label( $name, 1 ) ); + + # Raise the Head1Level by one so that subsequent =head1 appear + # as subsections of the main name section unless we are already + # at maximum [Head1Level() could check this itself - CHECK] + $self->Head1Level( $self->Head1Level() + 1) + unless $self->Head1Level == $#LatexSections; + + # Now write out the new latex paragraph + $purpose = ucfirst($purpose); + $self->_output("\n\n$purpose\n\n"); + + } else { + # Just write the output + $self->_output("\n\n$expansion\n\n"); + } + +} + +=item B<interior_sequence> + +Interior sequence expansion + +=cut + +sub interior_sequence { + my $self = shift; + + my ($seq_command, $seq_argument, $pod_seq) = @_; + + if ($seq_command eq 'B') { + return "\\textbf{$seq_argument}"; + + } elsif ($seq_command eq 'I') { + return "\\textit{$seq_argument}"; + + } elsif ($seq_command eq 'E') { + + # If it is simply a number + if ($seq_argument =~ /^\d+$/) { + return chr($seq_argument); + # Look up escape in hash table + } elsif (exists $HTML_Escapes{$seq_argument}) { + return $HTML_Escapes{$seq_argument}; + + } else { + my ($file, $line) = $pod_seq->file_line(); + warn "Escape sequence $seq_argument not recognised at line $line of file $file\n"; + return; + } + + } elsif ($seq_command eq 'Z') { + + # Zero width space + return '{}'; + + } elsif ($seq_command eq 'C') { + return "\\texttt{$seq_argument}"; + + } elsif ($seq_command eq 'F') { + return "\\emph{$seq_argument}"; + + } elsif ($seq_command eq 'S') { + # non breakable spaces + my $nbsp = '~'; + + $seq_argument =~ s/\s/$nbsp/g; + return $seq_argument; + + } elsif ($seq_command eq 'L') { + my $link = new Pod::Hyperlink($seq_argument); + + # undef on failure + unless (defined $link) { + carp $@; + return; + } + + # Handle internal links differently + my $type = $link->type; + my $page = $link->page; + + if ($type eq 'section' && $page eq '') { + # Use internal latex reference + my $node = $link->node; + + # Convert to a label + $node = $self->_create_label($node); + + return "\\S\\ref{$node}"; + + } else { + # Use default markup for external references + # (although Starlink would use \xlabel) + my $markup = $link->markup; + my ($file, $line) = $pod_seq->file_line(); + + return $self->interpolate($link->markup, $line); + } + + + + } elsif ($seq_command eq 'P') { + # Special markup for Pod::Hyperlink + # Replace :: with / - but not sure if I want to do this + # any more. + my $link = $seq_argument; + $link =~ s|::|/|g; + + my $ref = "\\emph{$seq_argument}"; + return $ref; + + } elsif ($seq_command eq 'Q') { + # Special markup for Pod::Hyperlink + return "\\textsf{$seq_argument}"; + + } elsif ($seq_command eq 'X') { + # Index entries + + # use \index command + # I will let '!' go through for now + # not sure how sub categories are handled in X<> + my $index = $self->_create_index($seq_argument); + return "\\index{$index}\n"; + + } else { + carp "Unknown sequence $seq_command<$seq_argument>"; + } + +} + +=back + +=head2 List Methods + +Methods used to handle lists. + +=over 4 + +=item B<begin_list> + +Called when a new list is found (via the C<over> directive). +Creates a new C<Pod::List> object and stores it on the +list stack. + + $parser->begin_list($indent, $line_num); + +=cut + +sub begin_list { + my $self = shift; + my $indent = shift; + my $line_num = shift; + + # Indicate that a list should be started for the next item + # need to do this to work out the type of list + push ( @{$self->lists}, new Pod::List(-indent => $indent, + -start => $line_num, + -file => $self->input_file, + ) + ); + +} + +=item B<end_list> + +Called when the end of a list is found (the C<back> directive). +Pops the C<Pod::List> object off the stack of lists and writes +the C<latex> code required to close a list. + + $parser->end_list($line_num); + +=cut + +sub end_list { + my $self = shift; + my $line_num = shift; + + unless (defined $self->lists->[-1]) { + my $file = $self->input_file; + warn "No list is active at line $line_num (file=$file). Missing =over?\n"; + return; + } + + # What to write depends on list type + my $type = $self->lists->[-1]->type; + + # Dont write anything if the list type is not set + # iomplying that a list was created but no entries were + # placed in it (eg because of a =begin/=end combination) + $self->_output("\\end{$type}\n") + if (defined $type && length($type) > 0); + + # Clear list + pop(@{ $self->lists}); + +} + +=item B<add_item> + +Add items to the list. The first time an item is encountered +(determined from the state of the current C<Pod::List> object) +the type of list is determined (ordered, unnumbered or description) +and the relevant latex code issued. + + $parser->add_item($paragraph, $line_num); + +=cut + +sub add_item { + my $self = shift; + my $paragraph = shift; + my $line_num = shift; + + unless (defined $self->lists->[-1]) { + my $file = $self->input_file; + warn "List has already ended by line $line_num of file $file. Missing =over?\n"; + # Replace special chars +# $paragraph = $self->_replace_special_chars($paragraph); + $self->_output("$paragraph\n\n"); + return; + } + + # If paragraphs printing is turned off via =begin/=end or whatver + # simply return immediately + return if $self->{_suppress_all_para}; + + # Check to see whether we are starting a new lists + if (scalar($self->lists->[-1]->item) == 0) { + + # Examine the paragraph to determine what type of list + # we have + $paragraph =~ s/\s+$//; + $paragraph =~ s/^\s+//; + + my $type; + if (substr($paragraph, 0,1) eq '*') { + $type = 'itemize'; + } elsif ($paragraph =~ /^\d/) { + $type = 'enumerate'; + } else { + $type = 'description'; + } + $self->lists->[-1]->type($type); + + $self->_output("\\begin{$type}\n"); + + } + + my $type = $self->lists->[-1]->type; + + if ($type eq 'description') { + # Handle long items - long items do not wrap + # If the string is longer than 40 characters we split + # it into a real item header and some bold text. + my $maxlen = 40; + my ($hunk1, $hunk2) = $self->_split_delimited( $paragraph, $maxlen ); + + # Print the first hunk + $self->_output("\n\\item[{$hunk1}] "); + + # and the second hunk if it is defined + if ($hunk2) { + $self->_output("\\textbf{$hunk2}"); + } else { + # Not there so make sure we have a new line + $self->_output("\\mbox{}"); + } + + } else { + # If the item was '* Something' or '\d+ something' we still need to write + # out the something. Also allow 1) and 1. + my $extra_info = $paragraph; + $extra_info =~ s/^(\*|\d+[\.\)]?)\s*//; + $self->_output("\n\\item $extra_info"); + } + + # Store the item name in the object. Required so that + # we can tell if the list is new or not + $self->lists->[-1]->item($paragraph); + +} + +=back + +=head2 Methods for headings + +=over 4 + +=item B<head> + +Print a heading of the required level. + + $parser->head($level, $paragraph, $parobj); + +The first argument is the pod heading level. The second argument +is the contents of the heading. The 3rd argument is a Pod::Paragraph +object so that the line number can be extracted. + +=cut + +sub head { + my $self = shift; + my $num = shift; + my $paragraph = shift; + my $parobj = shift; + + # If we are replace 'head1 NAME' with a section + # we return immediately if we get it + return + if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()); + + # Create a label + my $label = $self->_create_label($paragraph); + + # Create an index entry + my $index = $self->_create_index($paragraph); + + # Work out position in the above array taking into account + # that =head1 is equivalent to $self->Head1Level + + my $level = $self->Head1Level() - 1 + $num; + + # Warn if heading to large + if ($num > $#LatexSections) { + my $line = $parobj->file_line; + my $file = $self->input_file; + warn "Heading level too large ($level) for LaTeX at line $line of file $file\n"; + $level = $#LatexSections; + } + + # Check to see whether section should be unnumbered + my $star = ($level >= $self->LevelNoNum ? '*' : ''); + + # Section + $self->_output("\\" .$LatexSections[$level] .$star ."{$paragraph\\label{".$label ."}\\index{".$index."}}\n"); + +} + + +=back + +=end __PRIVATE__ + +=begin __PRIVATE__ + +=head2 Internal methods + +Internal routines are described in this section. They do not form part of the +public interface. All private methods start with an underscore. + +=over 4 + +=item B<_output> + +Output text to the output filehandle. This method must be always be called +to output parsed text. + + $parser->_output($text); + +Does not write anything if a =begin is active that should be +ignored. + +=cut + +sub _output { + my $self = shift; + my $text = shift; + + print { $self->output_handle } $text + unless $self->{_suppress_all_para}; + +} + + +=item B<_replace_special_chars> + +Subroutine to replace characters that are special in C<latex> +with the escaped forms + + $escaped = $parser->_replace_special_chars($paragraph); + +Need to call this routine before interior_sequences are munged but not +if verbatim. It must be called before interpolation of interior +sequences so that curly brackets and special latex characters inserted +during interpolation are not themselves escaped. This means that < and +> can not be modified here since the text still contains interior +sequences. + +Special characters and the C<latex> equivalents are: + + } \} + { \{ + _ \_ + $ \$ + % \% + & \& + \ $\backslash$ + ^ \^{} + ~ \~{} + # \# + +=cut + +sub _replace_special_chars { + my $self = shift; + my $paragraph = shift; + + # Replace a \ with $\backslash$ + # This is made more complicated because the dollars will be escaped + # by the subsequent replacement. Easiest to add \backslash + # now and then add the dollars + $paragraph =~ s/\\/\\backslash/g; + + # Must be done after escape of \ since this command adds latex escapes + # Replace characters that can be escaped + $paragraph =~ s/([\$\#&%_{}])/\\$1/g; + + # Replace ^ characters with \^{} so that $^F works okay + $paragraph =~ s/(\^)/\\$1\{\}/g; + + # Replace tilde (~) with \texttt{\~{}} + $paragraph =~ s/~/\\texttt\{\\~\{\}\}/g; + + # Now add the dollars around each \backslash + $paragraph =~ s/(\\backslash)/\$$1\$/g; + return $paragraph; +} + +=item B<_replace_special_chars_late> + +Replace special characters that can not be replaced before interior +sequence interpolation. See C<_replace_special_chars> for a routine +to replace special characters prior to interpolation of interior +sequences. + +Does the following transformation: + + < $<$ + > $>$ + | $|$ + + +=cut + +sub _replace_special_chars_late { + my $self = shift; + my $paragraph = shift; + + # < and > + $paragraph =~ s/(<|>)/\$$1\$/g; + + # Replace | with $|$ + $paragraph =~ s'\|'$|$'g; + + + return $paragraph; +} + + +=item B<_create_label> + +Return a string that can be used as an internal reference +in a C<latex> document (i.e. accepted by the C<\label> command) + + $label = $parser->_create_label($string) + +If UniqueLabels is true returns a label prefixed by Label() +This can be suppressed with an optional second argument. + + $label = $parser->_create_label($string, $suppress); + +If a second argument is supplied (of any value including undef) +the Label() is never prefixed. This means that this routine can +be called to create a Label() without prefixing a previous setting. + +=cut + +sub _create_label { + my $self = shift; + my $paragraph = shift; + my $suppress = (@_ ? 1 : 0 ); + + # Remove latex commands + $paragraph = $self->_clean_latex_commands($paragraph); + + # Remove non alphanumerics from the label and replace with underscores + # want to protect '-' though so use negated character classes + $paragraph =~ s/[^-:\w]/_/g; + + # Multiple underscores will look unsightly so remove repeats + # This will also have the advantage of tidying up the end and + # start of string + $paragraph =~ s/_+/_/g; + + # If required need to make sure that the label is unique + # since it is possible to have multiple pods in a single + # document + if (!$suppress && $self->UniqueLabels() && defined $self->Label) { + $paragraph = $self->Label() .'_'. $paragraph; + } + + return $paragraph; +} + + +=item B<_create_index> + +Similar to C<_create_label> except an index entry is created. +If C<UniqueLabels> is true, the index entry is prefixed by +the current C<Label> and an exclamation mark. + + $ind = $parser->_create_index($paragraph); + +An exclamation mark is used by C<makeindex> to generate +sub-entries in an index. + +=cut + +sub _create_index { + my $self = shift; + my $paragraph = shift; + my $suppress = (@_ ? 1 : 0 ); + + # Remove latex commands + $paragraph = $self->_clean_latex_commands($paragraph); + + # If required need to make sure that the index entry is unique + # since it is possible to have multiple pods in a single + # document + if (!$suppress && $self->UniqueLabels() && defined $self->Label) { + $paragraph = $self->Label() .'!'. $paragraph; + } + + # Need to replace _ with space + $paragraph =~ s/_/ /g; + + return $paragraph; + +} + +=item B<_clean_latex_commands> + +Removes latex commands from text. The latex command is assumed to be of the +form C<\command{ text }>. "C<text>" is retained + + $clean = $parser->_clean_latex_commands($text); + +=cut + +sub _clean_latex_commands { + my $self = shift; + my $paragraph = shift; + + # Remove latex commands of the form \text{ } + # and replace with the contents of the { } + # need to make this non-greedy so that it can handle + # "\text{a} and \text2{b}" + # without converting it to + # "a} and \text2{b" + # This match will still get into trouble if \} is present + # This is not vital since the subsequent replacement of non-alphanumeric + # characters will tidy it up anyway + $paragraph =~ s/\\\w+{(.*?)}/$1/g; + + return $paragraph +} + +=item B<_split_delimited> + +Split the supplied string into two parts at approximately the +specified word boundary. Special care is made to make sure that it +does not split in the middle of some curly brackets. + +e.g. "this text is \textbf{very bold}" would not be split into +"this text is \textbf{very" and " bold". + + ($hunk1, $hunk2) = $self->_split_delimited( $para, $length); + +The length indicates the maximum length of hunk1. + +=cut + +# initially Supplied by hsmyers@sdragons.com +# 10/25/01, utility to split \hbox +# busting lines. Reformatted by TimJ to match module style. +sub _split_delimited { + my $self = shift; + my $input = shift; + my $limit = shift; + + # Return immediately if already small + return ($input, '') if length($input) < $limit; + + my @output; + my $s = ''; + my $t = ''; + my $depth = 0; + my $token; + + $input =~ s/\n/ /gm; + $input .= ' '; + foreach ( split ( //, $input ) ) { + $token .= $_; + if (/\{/) { + $depth++; + } elsif ( /}/ ) { + $depth--; + } elsif ( / / and $depth == 0) { + push @output, $token if ( $token and $token ne ' ' ); + $token = ''; + } + } + + foreach (@output) { + if (length($s) < $limit) { + $s .= $_; + } else { + $t .= $_; + } + } + + # Tidy up + $s =~ s/\s+$//; + $t =~ s/\s+$//; + return ($s,$t); +} + +=back + +=end __PRIVATE__ + +=head1 NOTES + +Compatible with C<latex2e> only. Can not be used with C<latex> v2.09 +or earlier. + +A subclass of C<Pod::Select> so that specific pod sections can be +converted to C<latex> by using the C<select> method. + +Some HTML escapes are missing and many have not been tested. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Select>, L<pod2latex> + +=head1 AUTHORS + +Tim Jenness E<lt>tjenness@cpan.orgE<gt> + +Bug fixes and improvements have been received from: Simon Cozens +E<lt>simon@cozens.netE<gt>, Mark A. Hershberger +E<lt>mah@everybody.orgE<gt>, Marcel Grunauer +E<lt>marcel@codewerk.comE<gt>, Hugh S Myers +E<lt>hsmyers@sdragons.comE<gt>, Peter J Acklam +E<lt>jacklam@math.uio.noE<gt>, Sudhi Herle E<lt>sudhi@herle.netE<gt>, +Ariel Scolnicov E<lt>ariels@compugen.co.ilE<gt>, +Adriano Rodrigues Ferreira E<lt>ferreira@triang.com.brE<gt> and +R. de Vries E<lt>r.de.vries@dutchspace.nlE<gt>. + + +=head1 COPYRIGHT + +Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=begin __PRIVATE__ + +=head1 REVISION + +$Id: LaTeX.pm,v 1.19 2004/12/30 01:40:44 timj Exp $ + +=end __PRIVATE__ + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/Pod/Man.pm b/Master/tlpkg/tlperl/lib/Pod/Man.pm new file mode 100644 index 00000000000..9339f835bbc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Man.pm @@ -0,0 +1,1764 @@ +# Pod::Man -- Convert POD data to formatted *roff input. +# +# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 +# Russ Allbery <rra@stanford.edu> +# Substantial contributions by Sean Burke <sburke@cpan.org> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module translates POD documentation into *roff markup using the man +# macro set, and is intended for converting POD documents written as Unix +# manual pages to manual pages that can be read by the man(1) command. It is +# a replacement for the pod2man command distributed with versions of Perl +# prior to 5.6. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Man; + +require 5.005; + +use strict; +use subs qw(makespace); +use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); + +use Carp qw(croak); +use Pod::Simple (); + +@ISA = qw(Pod::Simple); + +$VERSION = '2.23'; + +# Set the debugging level. If someone has inserted a debug function into this +# class already, use that. Otherwise, use any Pod::Simple debug function +# that's defined, and failing that, define a debug level of 10. +BEGIN { + my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef; + unless (defined &DEBUG) { + *DEBUG = $parent || sub () { 10 }; + } +} + +# Import the ASCII constant from Pod::Simple. This is true iff we're in an +# ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is +# generally only false for EBCDIC. +BEGIN { *ASCII = \&Pod::Simple::ASCII } + +# Pretty-print a data structure. Only used for debugging. +BEGIN { *pretty = \&Pod::Simple::pretty } + +############################################################################## +# Object initialization +############################################################################## + +# Initialize the object and set various Pod::Simple options that we need. +# Here, we also process any additional options passed to the constructor or +# set up defaults if none were given. Note that all internal object keys are +# in all-caps, reserving all lower-case object keys for Pod::Simple and user +# arguments. +sub new { + my $class = shift; + my $self = $class->SUPER::new; + + # Tell Pod::Simple not to handle S<> by automatically inserting . + $self->nbsp_for_S (1); + + # Tell Pod::Simple to keep whitespace whenever possible. + if ($self->can ('preserve_whitespace')) { + $self->preserve_whitespace (1); + } else { + $self->fullstop_space_harden (1); + } + + # The =for and =begin targets that we accept. + $self->accept_targets (qw/man MAN roff ROFF/); + + # Ensure that contiguous blocks of code are merged together. Otherwise, + # some of the guesswork heuristics don't work right. + $self->merge_text (1); + + # Pod::Simple doesn't do anything useful with our arguments, but we want + # to put them in our object as hash keys and values. This could cause + # problems if we ever clash with Pod::Simple's own internal class + # variables. + %$self = (%$self, @_); + + # Send errors to stderr if requested. + if ($$self{stderr}) { + $self->no_errata_section (1); + $self->complain_stderr (1); + delete $$self{stderr}; + } + + # Initialize various other internal constants based on our arguments. + $self->init_fonts; + $self->init_quotes; + $self->init_page; + + # For right now, default to turning on all of the magic. + $$self{MAGIC_CPP} = 1; + $$self{MAGIC_EMDASH} = 1; + $$self{MAGIC_FUNC} = 1; + $$self{MAGIC_MANREF} = 1; + $$self{MAGIC_SMALLCAPS} = 1; + $$self{MAGIC_VARS} = 1; + + return $self; +} + +# Translate a font string into an escape. +sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } + +# Determine which fonts the user wishes to use and store them in the object. +# Regular, italic, bold, and bold-italic are constants, but the fixed width +# fonts may be set by the user. Sets the internal hash key FONTS which is +# used to map our internal font escapes to actual *roff sequences later. +sub init_fonts { + my ($self) = @_; + + # Figure out the fixed-width font. If user-supplied, make sure that they + # are the right length. + for (qw/fixed fixedbold fixeditalic fixedbolditalic/) { + my $font = $$self{$_}; + if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) { + croak qq(roff font should be 1 or 2 chars, not "$font"); + } + } + + # Set the default fonts. We can't be sure portably across different + # implementations what fixed bold-italic may be called (if it's even + # available), so default to just bold. + $$self{fixed} ||= 'CW'; + $$self{fixedbold} ||= 'CB'; + $$self{fixeditalic} ||= 'CI'; + $$self{fixedbolditalic} ||= 'CB'; + + # Set up a table of font escapes. First number is fixed-width, second is + # bold, third is italic. + $$self{FONTS} = { '000' => '\fR', '001' => '\fI', + '010' => '\fB', '011' => '\f(BI', + '100' => toescape ($$self{fixed}), + '101' => toescape ($$self{fixeditalic}), + '110' => toescape ($$self{fixedbold}), + '111' => toescape ($$self{fixedbolditalic}) }; +} + +# Initialize the quotes that we'll be using for C<> text. This requires some +# special handling, both to parse the user parameter if given and to make sure +# that the quotes will be safe against *roff. Sets the internal hash keys +# LQUOTE and RQUOTE. +sub init_quotes { + my ($self) = (@_); + + $$self{quotes} ||= '"'; + if ($$self{quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; + } elsif ($$self{quotes} =~ /^(.)(.)$/ + || $$self{quotes} =~ /^(..)(..)$/) { + $$self{LQUOTE} = $1; + $$self{RQUOTE} = $2; + } else { + croak(qq(Invalid quote specification "$$self{quotes}")) + } + + # Double the first quote; note that this should not be s///g as two double + # quotes is represented in *roff as three double quotes, not four. Weird, + # I know. + $$self{LQUOTE} =~ s/\"/\"\"/; + $$self{RQUOTE} =~ s/\"/\"\"/; +} + +# Initialize the page title information and indentation from our arguments. +sub init_page { + my ($self) = @_; + + # We used to try first to get the version number from a local binary, but + # we shouldn't need that any more. Get the version from the running Perl. + # Work a little magic to handle subversions correctly under both the + # pre-5.6 and the post-5.6 version numbering schemes. + my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); + $version[2] ||= 0; + $version[2] *= 10 ** (3 - length $version[2]); + for (@version) { $_ += 0 } + my $version = join ('.', @version); + + # Set the defaults for page titles and indentation if the user didn't + # override anything. + $$self{center} = 'User Contributed Perl Documentation' + unless defined $$self{center}; + $$self{release} = 'perl v' . $version + unless defined $$self{release}; + $$self{indent} = 4 + unless defined $$self{indent}; + + # Double quotes in things that will be quoted. + for (qw/center release/) { + $$self{$_} =~ s/\"/\"\"/g if $$self{$_}; + } +} + +############################################################################## +# Core parsing +############################################################################## + +# This is the glue that connects the code below with Pod::Simple itself. The +# goal is to convert the event stream coming from the POD parser into method +# calls to handlers once the complete content of a tag has been seen. Each +# paragraph or POD command will have textual content associated with it, and +# as soon as all of a paragraph or POD command has been seen, that content +# will be passed in to the corresponding method for handling that type of +# object. The exceptions are handlers for lists, which have opening tag +# handlers and closing tag handlers that will be called right away. +# +# The internal hash key PENDING is used to store the contents of a tag until +# all of it has been seen. It holds a stack of open tags, each one +# represented by a tuple of the attributes hash for the tag, formatting +# options for the tag (which are inherited), and the contents of the tag. + +# Add a block of text to the contents of the current node, formatting it +# according to the current formatting instructions as we do. +sub _handle_text { + my ($self, $text) = @_; + DEBUG > 3 and print "== $text\n"; + my $tag = $$self{PENDING}[-1]; + $$tag[2] .= $self->format_text ($$tag[1], $text); +} + +# Given an element name, get the corresponding method name. +sub method_for_element { + my ($self, $element) = @_; + $element =~ tr/-/_/; + $element =~ tr/A-Z/a-z/; + $element =~ tr/_a-z0-9//cd; + return $element; +} + +# Handle the start of a new element. If cmd_element is defined, assume that +# we need to collect the entire tree for this element before passing it to the +# element method, and create a new tree into which we'll collect blocks of +# text and nested elements. Otherwise, if start_element is defined, call it. +sub _handle_element_start { + my ($self, $element, $attrs) = @_; + DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n"; + my $method = $self->method_for_element ($element); + + # If we have a command handler, we need to accumulate the contents of the + # tag before calling it. Turn off IN_NAME for any command other than + # <Para> and the formatting codes so that IN_NAME isn't still set for the + # first heading after the NAME heading. + if ($self->can ("cmd_$method")) { + DEBUG > 2 and print "<$element> starts saving a tag\n"; + $$self{IN_NAME} = 0 if ($element ne 'Para' && length ($element) > 1); + + # How we're going to format embedded text blocks depends on the tag + # and also depends on our parent tags. Thankfully, inside tags that + # turn off guesswork and reformatting, nothing else can turn it back + # on, so this can be strictly inherited. + my $formatting = $$self{PENDING}[-1][1]; + $formatting = $self->formatting ($formatting, $element); + push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]); + DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n"; + } elsif ($self->can ("start_$method")) { + my $method = 'start_' . $method; + $self->$method ($attrs, ''); + } else { + DEBUG > 2 and print "No $method start method, skipping\n"; + } +} + +# Handle the end of an element. If we had a cmd_ method for this element, +# this is where we pass along the tree that we built. Otherwise, if we have +# an end_ method for the element, call that. +sub _handle_element_end { + my ($self, $element) = @_; + DEBUG > 3 and print "-- $element\n"; + my $method = $self->method_for_element ($element); + + # If we have a command handler, pull off the pending text and pass it to + # the handler along with the saved attribute hash. + if ($self->can ("cmd_$method")) { + DEBUG > 2 and print "</$element> stops saving a tag\n"; + my $tag = pop @{ $$self{PENDING} }; + DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n"; + DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n"; + my $method = 'cmd_' . $method; + my $text = $self->$method ($$tag[0], $$tag[2]); + if (defined $text) { + if (@{ $$self{PENDING} } > 1) { + $$self{PENDING}[-1][2] .= $text; + } else { + $self->output ($text); + } + } + } elsif ($self->can ("end_$method")) { + my $method = 'end_' . $method; + $self->$method (); + } else { + DEBUG > 2 and print "No $method end method, skipping\n"; + } +} + +############################################################################## +# General formatting +############################################################################## + +# Return formatting instructions for a new block. Takes the current +# formatting and the new element. Formatting inherits negatively, in the +# sense that if the parent has turned off guesswork, all child elements should +# leave it off. We therefore return a copy of the same formatting +# instructions but possibly with more things turned off depending on the +# element. +sub formatting { + my ($self, $current, $element) = @_; + my %options; + if ($current) { + %options = %$current; + } else { + %options = (guesswork => 1, cleanup => 1, convert => 1); + } + if ($element eq 'Data') { + $options{guesswork} = 0; + $options{cleanup} = 0; + $options{convert} = 0; + } elsif ($element eq 'X') { + $options{guesswork} = 0; + $options{cleanup} = 0; + } elsif ($element eq 'Verbatim' || $element eq 'C') { + $options{guesswork} = 0; + $options{literal} = 1; + } + return \%options; +} + +# Format a text block. Takes a hash of formatting options and the text to +# format. Currently, the only formatting options are guesswork, cleanup, and +# convert, all of which are boolean. +sub format_text { + my ($self, $options, $text) = @_; + my $guesswork = $$options{guesswork} && !$$self{IN_NAME}; + my $cleanup = $$options{cleanup}; + my $convert = $$options{convert}; + my $literal = $$options{literal}; + + # Cleanup just tidies up a few things, telling *roff that the hyphens are + # hard, putting a bit of space between consecutive underscores, and + # escaping backslashes. Be careful not to mangle our character + # translations by doing this before processing character translation. + if ($cleanup) { + $text =~ s/\\/\\e/g; + $text =~ s/-/\\-/g; + $text =~ s/_(?=_)/_\\|/g; + } + + # Normally we do character translation, but we won't even do that in + # <Data> blocks or if UTF-8 output is desired. + if ($convert && !$$self{utf8} && ASCII) { + $text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg; + } + + # Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes, + # but don't mess up our accept escapes. + if ($literal) { + $text =~ s/(?<!\\\*)\'/\\*\(Aq/g; + $text =~ s/(?<!\\\*)\`/\\\`/g; + } + + # If guesswork is asked for, do that. This involves more substantial + # formatting based on various heuristics that may only be appropriate for + # particular documents. + if ($guesswork) { + $text = $self->guesswork ($text); + } + + return $text; +} + +# Handles C<> text, deciding whether to put \*C` around it or not. This is a +# whole bunch of messy heuristics to try to avoid overquoting, originally from +# Barrie Slaymaker. This largely duplicates similar code in Pod::Text. +sub quote_literal { + my $self = shift; + local $_ = shift; + + # A regex that matches the portion of a variable reference that's the + # array or hash index, separated out just because we want to use it in + # several places in the following regex. + my $index = '(?: \[.*\] | \{.*\} )?'; + + # If in NAME section, just return an ASCII quoted string to avoid + # confusing tools like whatis. + return qq{"$_"} if $$self{IN_NAME}; + + # Check for things that we don't want to quote, and if we find any of + # them, return the string with just a font change and no quoting. + m{ + ^\s* + (?: + ( [\'\`\"] ) .* \1 # already quoted + | \\\*\(Aq .* \\\*\(Aq # quoted and escaped + | \\?\` .* ( \' | \\\*\(Aq ) # `quoted' + | \$+ [\#^]? \S $index # special ($^Foo, $") + | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func + | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call + | [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number + | 0x [a-fA-F\d]+ # a hex constant + ) + \s*\z + }xso and return '\f(FS' . $_ . '\f(FE'; + + # If we didn't return, go ahead and quote the text. + return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"; +} + +# Takes a text block to perform guesswork on. Returns the text block with +# formatting codes added. This is the code that marks up various Perl +# constructs and things commonly used in man pages without requiring the user +# to add any explicit markup, and is applied to all non-literal text. We're +# guaranteed that the text we're applying guesswork to does not contain any +# *roff formatting codes. Note that the inserted font sequences must be +# treated later with mapfonts or textmapfonts. +# +# This method is very fragile, both in the regular expressions it uses and in +# the ordering of those modifications. Care and testing is required when +# modifying it. +sub guesswork { + my $self = shift; + local $_ = shift; + DEBUG > 5 and print " Guesswork called on [$_]\n"; + + # By the time we reach this point, all hypens will be escaped by adding a + # backslash. We want to undo that escaping if they're part of regular + # words and there's only a single dash, since that's a real hyphen that + # *roff gets to consider a possible break point. Make sure that a dash + # after the first character of a word stays non-breaking, however. + # + # Note that this is not user-controllable; we pretty much have to do this + # transformation or *roff will mangle the output in unacceptable ways. + s{ + ( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )? + ( (?: [a-zA-Z\']+ \\-)+ ) + ( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) ) + \b + } { + my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4); + $hyphen ||= ''; + $main =~ s/\\-/-/g; + $prefix . $hyphen . $main . $suffix; + }egx; + + # Translate "--" into a real em-dash if it's used like one. This means + # that it's either surrounded by whitespace, it follows a regular word, or + # it occurs between two regular words. + if ($$self{MAGIC_EMDASH}) { + s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx; + s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx; + } + + # Make words in all-caps a little bit smaller; they look better that way. + # However, we don't want to change Perl code (like @ARGV), nor do we want + # to fix the MIME in MIME-Version since it looks weird with the + # full-height V. + # + # We change only a string of all caps (2) either at the beginning of the + # line or following regular punctuation (like quotes) or whitespace (1), + # and followed by either similar punctuation, an em-dash, or the end of + # the line (3). + if ($$self{MAGIC_SMALLCAPS}) { + s{ + ( ^ | [\s\(\"\'\`\[\{<>] | \\\ ) # (1) + ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* ) # (2) + (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\\ | $ ) # (3) + } { + $1 . '\s-1' . $2 . '\s0' + }egx; + } + + # Note that from this point forward, we have to adjust for \s-1 and \s-0 + # strings inserted around things that we've made small-caps if later + # transforms should work on those strings. + + # Italize functions in the form func(), including functions that are in + # all capitals, but don't italize if there's anything between the parens. + # The function must start with an alphabetic character or underscore and + # then consist of word characters or colons. + if ($$self{MAGIC_FUNC}) { + s{ + ( \b | \\s-1 ) + ( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) ) + } { + $1 . '\f(IS' . $2 . '\f(IE' + }egx; + } + + # Change references to manual pages to put the page name in italics but + # the number in the regular font, with a thin space between the name and + # the number. Only recognize func(n) where func starts with an alphabetic + # character or underscore and contains only word characters, periods (for + # configuration file man pages), or colons, and n is a single digit, + # optionally followed by some number of lowercase letters. Note that this + # does not recognize man page references like perl(l) or socket(3SOCKET). + if ($$self{MAGIC_MANREF}) { + s{ + ( \b | \\s-1 ) + ( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ ) + ( \( \d [a-z]* \) ) + } { + $1 . '\f(IS' . $2 . '\f(IE\|' . $3 + }egx; + } + + # Convert simple Perl variable references to a fixed-width font. Be + # careful not to convert functions, though; there are too many subtleties + # with them to want to perform this transformation. + if ($$self{MAGIC_VARS}) { + s{ + ( ^ | \s+ ) + ( [\$\@%] [\w:]+ ) + (?! \( ) + } { + $1 . '\f(FS' . $2 . '\f(FE' + }egx; + } + + # Fix up double quotes. Unfortunately, we miss this transformation if the + # quoted text contains any code with formatting codes and there's not much + # we can effectively do about that, which makes it somewhat unclear if + # this is really a good idea. + s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx; + + # Make C++ into \*(C+, which is a squinched version. + if ($$self{MAGIC_CPP}) { + s{ \b C\+\+ } {\\*\(C+}gx; + } + + # Done. + DEBUG > 5 and print " Guesswork returning [$_]\n"; + return $_; +} + +############################################################################## +# Output +############################################################################## + +# When building up the *roff code, we don't use real *roff fonts. Instead, we +# embed font codes of the form \f(<font>[SE] where <font> is one of B, I, or +# F, S stands for start, and E stands for end. This method turns these into +# the right start and end codes. +# +# We add this level of complexity because the old pod2man didn't get code like +# B<someI<thing> else> right; after I<> it switched back to normal text rather +# than bold. We take care of this by using variables that state whether bold, +# italic, or fixed are turned on as a combined pointer to our current font +# sequence, and set each to the number of current nestings of start tags for +# that font. +# +# \fP changes to the previous font, but only one previous font is kept. We +# don't know what the outside level font is; normally it's R, but if we're +# inside a heading it could be something else. So arrange things so that the +# outside font is always the "previous" font and end with \fP instead of \fR. +# Idea from Zack Weinberg. +sub mapfonts { + my ($self, $text) = @_; + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + my $last = '\fR'; + $text =~ s< + \\f\((.)(.) + > < + my $sequence = ''; + my $f; + if ($last ne '\fR') { $sequence = '\fP' } + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) }; + if ($f eq $last) { + ''; + } else { + if ($f ne '\fR') { $sequence .= $f } + $last = $f; + $sequence; + } + >gxe; + return $text; +} + +# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU +# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather +# than R, presumably because \f(CW doesn't actually do a font change. To work +# around this, use a separate textmapfonts for text blocks where the default +# font is always R and only use the smart mapfonts for headings. +sub textmapfonts { + my ($self, $text) = @_; + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + $text =~ s< + \\f\((.)(.) + > < + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) }; + >gxe; + return $text; +} + +# Given a command and a single argument that may or may not contain double +# quotes, handle double-quote formatting for it. If there are no double +# quotes, just return the command followed by the argument in double quotes. +# If there are double quotes, use an if statement to test for nroff, and for +# nroff output the command followed by the argument in double quotes with +# embedded double quotes doubled. For other formatters, remap paired double +# quotes to LQUOTE and RQUOTE. +sub switchquotes { + my ($self, $command, $text, $extra) = @_; + $text =~ s/\\\*\([LR]\"/\"/g; + + # We also have to deal with \*C` and \*C', which are used to add the + # quotes around C<> text, since they may expand to " and if they do this + # confuses the .SH macros and the like no end. Expand them ourselves. + # Also separate troff from nroff if there are any fixed-width fonts in use + # to work around problems with Solaris nroff. + my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/); + my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'}; + $fixedpat =~ s/\\/\\\\/g; + $fixedpat =~ s/\(/\\\(/g; + if ($text =~ m/\"/ || $text =~ m/$fixedpat/) { + $text =~ s/\"/\"\"/g; + my $nroff = $text; + my $troff = $text; + $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; + if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) { + $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g; + $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g; + $troff =~ s/\\\*\(C[\'\`]//g; + } + $nroff = qq("$nroff") . ($extra ? " $extra" : ''); + $troff = qq("$troff") . ($extra ? " $extra" : ''); + + # Work around the Solaris nroff bug where \f(CW\fP leaves the font set + # to Roman rather than the actual previous font when used in headings. + # troff output may still be broken, but at least we can fix nroff by + # just switching the font changes to the non-fixed versions. + $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f[PR]/$1/g; + $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)\\f([PR])/\\fI$1\\f$2/g; + $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)\\f([PR])/\\fB$1\\f$2/g; + $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)\\f([PR])/\\f\(BI$1\\f$2/g; + + # Now finally output the command. Bother with .ie only if the nroff + # and troff output aren't the same. + if ($nroff ne $troff) { + return ".ie n $command $nroff\n.el $command $troff\n"; + } else { + return "$command $nroff\n"; + } + } else { + $text = qq("$text") . ($extra ? " $extra" : ''); + return "$command $text\n"; + } +} + +# Protect leading quotes and periods against interpretation as commands. Also +# protect anything starting with a backslash, since it could expand or hide +# something that *roff would interpret as a command. This is overkill, but +# it's much simpler than trying to parse *roff here. +sub protect { + my ($self, $text) = @_; + $text =~ s/^([.\'\\])/\\&$1/mg; + return $text; +} + +# Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation +# level the situation. This function is needed since in *roff one has to +# create vertical whitespace after paragraphs and between some things, but +# other macros create their own whitespace. Also close out a sequence of +# repeated =items, since calling makespace means we're about to begin the item +# body. +sub makespace { + my ($self) = @_; + $self->output (".PD\n") if $$self{ITEMS} > 1; + $$self{ITEMS} = 0; + $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n") + if $$self{NEEDSPACE}; +} + +# Output any pending index entries, and optionally an index entry given as an +# argument. Support multiple index entries in X<> separated by slashes, and +# strip special escapes from index entries. +sub outindex { + my ($self, $section, $index) = @_; + my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} }; + return unless ($section || @entries); + + # We're about to output all pending entries, so clear our pending queue. + $$self{INDEX} = []; + + # Build the output. Regular index entries are marked Xref, and headings + # pass in their own section. Undo some *roff formatting on headings. + my @output; + if (@entries) { + push @output, [ 'Xref', join (' ', @entries) ]; + } + if ($section) { + $index =~ s/\\-/-/g; + $index =~ s/\\(?:s-?\d|.\(..|.)//g; + push @output, [ $section, $index ]; + } + + # Print out the .IX commands. + for (@output) { + my ($type, $entry) = @$_; + $entry =~ s/\"/\"\"/g; + $entry =~ s/\\/\\\\/g; + $self->output (".IX $type " . '"' . $entry . '"' . "\n"); + } +} + +# Output some text, without any additional changes. +sub output { + my ($self, @text) = @_; + print { $$self{output_fh} } @text; +} + +############################################################################## +# Document initialization +############################################################################## + +# Handle the start of the document. Here we handle empty documents, as well +# as setting up our basic macros in a preamble and building the page title. +sub start_document { + my ($self, $attrs) = @_; + if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) { + DEBUG and print "Document is contentless\n"; + $$self{CONTENTLESS} = 1; + return; + } + + # If we were given the utf8 option, set an output encoding on our file + # handle. Wrap in an eval in case we're using a version of Perl too old + # to understand this. + # + # This is evil because it changes the global state of a file handle that + # we may not own. However, we can't just blindly encode all output, since + # there may be a pre-applied output encoding (such as from PERL_UNICODE) + # and then we would double-encode. This seems to be the least bad + # approach. + if ($$self{utf8}) { + eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') }; + } + + # Determine information for the preamble and then output it. + my ($name, $section); + if (defined $$self{name}) { + $name = $$self{name}; + $section = $$self{section} || 1; + } else { + ($name, $section) = $self->devise_title; + } + my $date = $$self{date} || $self->devise_date; + $self->preamble ($name, $section, $date) + unless $self->bare_output or DEBUG > 9; + + # Initialize a few per-document variables. + $$self{INDENT} = 0; # Current indentation level. + $$self{INDENTS} = []; # Stack of indentations. + $$self{INDEX} = []; # Index keys waiting to be printed. + $$self{IN_NAME} = 0; # Whether processing the NAME section. + $$self{ITEMS} = 0; # The number of consecutive =items. + $$self{ITEMTYPES} = []; # Stack of =item types, one per list. + $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting. + $$self{SHIFTS} = []; # Stack of .RS shifts. + $$self{PENDING} = [[]]; # Pending output. +} + +# Handle the end of the document. This does nothing but print out a final +# comment at the end of the document under debugging. +sub end_document { + my ($self) = @_; + return if $self->bare_output; + return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING}); + $self->output (q(.\" [End document]) . "\n") if DEBUG; +} + +# Try to figure out the name and section from the file name and return them as +# a list, returning an empty name and section 1 if we can't find any better +# information. Uses File::Basename and File::Spec as necessary. +sub devise_title { + my ($self) = @_; + my $name = $self->source_filename || ''; + my $section = $$self{section} || 1; + $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i); + $name =~ s/\.p(od|[lm])\z//i; + + # If the section isn't 3, then the name defaults to just the basename of + # the file. Otherwise, assume we're dealing with a module. We want to + # figure out the full module name from the path to the file, but we don't + # want to include too much of the path into the module name. Lose + # anything up to the first off: + # + # */lib/*perl*/ standard or site_perl module + # */*perl*/lib/ from -Dprefix=/opt/perl + # */*perl*/ random module hierarchy + # + # which works. Also strip off a leading site, site_perl, or vendor_perl + # component, any OS-specific component, and any version number component, + # and strip off an initial component of "lib" or "blib/lib" since that's + # what ExtUtils::MakeMaker creates. splitdir requires at least File::Spec + # 0.8. + if ($section !~ /^3/) { + require File::Basename; + $name = uc File::Basename::basename ($name); + } else { + require File::Spec; + my ($volume, $dirs, $file) = File::Spec->splitpath ($name); + my @dirs = File::Spec->splitdir ($dirs); + my $cut = 0; + my $i; + for ($i = 0; $i < @dirs; $i++) { + if ($dirs[$i] =~ /perl/) { + $cut = $i + 1; + $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib'); + last; + } + } + if ($cut > 0) { + splice (@dirs, 0, $cut); + shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/); + shift @dirs if ($dirs[0] =~ /^[\d.]+$/); + shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/); + } + shift @dirs if $dirs[0] eq 'lib'; + splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib'); + + # Remove empty directories when building the module name; they + # occur too easily on Unix by doubling slashes. + $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file); + } + return ($name, $section); +} + +# Determine the modification date and return that, properly formatted in ISO +# format. If we can't get the modification date of the input, instead use the +# current time. Pod::Simple returns a completely unuseful stringified file +# handle as the source_filename for input from a file handle, so we have to +# deal with that as well. +sub devise_date { + my ($self) = @_; + my $input = $self->source_filename; + my $time; + if ($input) { + $time = (stat $input)[9] || time; + } else { + $time = time; + } + + # Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker + # uses this and it has to work in the core which can't load dynamic + # libraries. + my ($year, $month, $day) = (localtime $time)[5,4,3]; + return sprintf ("%04d-%02d-%02d", $year + 1900, $month + 1, $day); +} + +# Print out the preamble and the title. The meaning of the arguments to .TH +# unfortunately vary by system; some systems consider the fourth argument to +# be a "source" and others use it as a version number. Generally it's just +# presented as the left-side footer, though, so it doesn't matter too much if +# a particular system gives it another interpretation. +# +# The order of date and release used to be reversed in older versions of this +# module, but this order is correct for both Solaris and Linux. +sub preamble { + my ($self, $name, $section, $date) = @_; + my $preamble = $self->preamble_template (!$$self{utf8}); + + # Build the index line and make sure that it will be syntactically valid. + my $index = "$name $section"; + $index =~ s/\"/\"\"/g; + + # If name or section contain spaces, quote them (section really never + # should, but we may as well be cautious). + for ($name, $section) { + if (/\s/) { + s/\"/\"\"/g; + $_ = '"' . $_ . '"'; + } + } + + # Double quotes in date, since it will be quoted. + $date =~ s/\"/\"\"/g; + + # Substitute into the preamble the configuration options. + $preamble =~ s/\@CFONT\@/$$self{fixed}/; + $preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/; + $preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/; + chomp $preamble; + + # Get the version information. + my $version = $self->version_report; + + # Finally output everything. + $self->output (<<"----END OF HEADER----"); +.\\" Automatically generated by $version +.\\" +.\\" Standard preamble: +.\\" ======================================================================== +$preamble +.\\" ======================================================================== +.\\" +.IX Title "$index" +.TH $name $section "$date" "$$self{release}" "$$self{center}" +.\\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\\" way too many mistakes in technical documents. +.if n .ad l +.nh +----END OF HEADER---- + $self->output (".\\\" [End of preamble]\n") if DEBUG; +} + +############################################################################## +# Text blocks +############################################################################## + +# Handle a basic block of text. The only tricky part of this is if this is +# the first paragraph of text after an =over, in which case we have to change +# indentations for *roff. +sub cmd_para { + my ($self, $attrs, $text) = @_; + my $line = $$attrs{start_line}; + + # Output the paragraph. We also have to handle =over without =item. If + # there's an =over without =item, SHIFTWAIT will be set, and we need to + # handle creation of the indent here. Add the shift to SHIFTS so that it + # will be cleaned up on =back. + $self->makespace; + if ($$self{SHIFTWAIT}) { + $self->output (".RS $$self{INDENT}\n"); + push (@{ $$self{SHIFTS} }, $$self{INDENT}); + $$self{SHIFTWAIT} = 0; + } + + # Add the line number for debugging, but not in the NAME section just in + # case the comment would confuse apropos. + $self->output (".\\\" [At source line $line]\n") + if defined ($line) && DEBUG && !$$self{IN_NAME}; + + # Force exactly one newline at the end and strip unwanted trailing + # whitespace at the end. + $text =~ s/\s*$/\n/; + + # Output the paragraph. + $self->output ($self->protect ($self->textmapfonts ($text))); + $self->outindex; + $$self{NEEDSPACE} = 1; + return ''; +} + +# Handle a verbatim paragraph. Put a null token at the beginning of each line +# to protect against commands and wrap in .Vb/.Ve (which we define in our +# prelude). +sub cmd_verbatim { + my ($self, $attrs, $text) = @_; + + # Ignore an empty verbatim paragraph. + return unless $text =~ /\S/; + + # Force exactly one newline at the end and strip unwanted trailing + # whitespace at the end. + $text =~ s/\s*$/\n/; + + # Get a count of the number of lines before the first blank line, which + # we'll pass to .Vb as its parameter. This tells *roff to keep that many + # lines together. We don't want to tell *roff to keep huge blocks + # together. + my @lines = split (/\n/, $text); + my $unbroken = 0; + for (@lines) { + last if /^\s*$/; + $unbroken++; + } + $unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT}); + + # Prepend a null token to each line. + $text =~ s/^/\\&/gm; + + # Output the results. + $self->makespace; + $self->output (".Vb $unbroken\n$text.Ve\n"); + $$self{NEEDSPACE} = 1; + return ''; +} + +# Handle literal text (produced by =for and similar constructs). Just output +# it with the minimum of changes. +sub cmd_data { + my ($self, $attrs, $text) = @_; + $text =~ s/^\n+//; + $text =~ s/\n{0,2}$/\n/; + $self->output ($text); + return ''; +} + +############################################################################## +# Headings +############################################################################## + +# Common code for all headings. This is called before the actual heading is +# output. It returns the cleaned up heading text (putting the heading all on +# one line) and may do other things, like closing bad =item blocks. +sub heading_common { + my ($self, $text, $line) = @_; + $text =~ s/\s+$//; + $text =~ s/\s*\n\s*/ /g; + + # This should never happen; it means that we have a heading after =item + # without an intervening =back. But just in case, handle it anyway. + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + + # Output the current source line. + $self->output ( ".\\\" [At source line $line]\n" ) + if defined ($line) && DEBUG; + return $text; +} + +# First level heading. We can't output .IX in the NAME section due to a bug +# in some versions of catman, so don't output a .IX for that section. .SH +# already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as +# appropriate. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\\s-?\d//g; + $text = $self->heading_common ($text, $$attrs{start_line}); + my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/); + $self->output ($self->switchquotes ('.SH', $self->mapfonts ($text))); + $self->outindex ('Header', $text) unless $isname; + $$self{NEEDSPACE} = 0; + $$self{IN_NAME} = $isname; + return ''; +} + +# Second level heading. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text = $self->heading_common ($text, $$attrs{start_line}); + $self->output ($self->switchquotes ('.SS', $self->mapfonts ($text))); + $self->outindex ('Subsection', $text); + $$self{NEEDSPACE} = 0; + return ''; +} + +# Third level heading. *roff doesn't have this concept, so just put the +# heading in italics as a normal paragraph. +sub cmd_head3 { + my ($self, $attrs, $text) = @_; + $text = $self->heading_common ($text, $$attrs{start_line}); + $self->makespace; + $self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n"); + $self->outindex ('Subsection', $text); + $$self{NEEDSPACE} = 1; + return ''; +} + +# Fourth level heading. *roff doesn't have this concept, so just put the +# heading as a normal paragraph. +sub cmd_head4 { + my ($self, $attrs, $text) = @_; + $text = $self->heading_common ($text, $$attrs{start_line}); + $self->makespace; + $self->output ($self->textmapfonts ($text) . "\n"); + $self->outindex ('Subsection', $text); + $$self{NEEDSPACE} = 1; + return ''; +} + +############################################################################## +# Formatting codes +############################################################################## + +# All of the formatting codes that aren't handled internally by the parser, +# other than L<> and X<>. +sub cmd_b { return $_[0]->{IN_NAME} ? $_[2] : '\f(BS' . $_[2] . '\f(BE' } +sub cmd_i { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' } +sub cmd_f { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' } +sub cmd_c { return $_[0]->quote_literal ($_[2]) } + +# Index entries are just added to the pending entries. +sub cmd_x { + my ($self, $attrs, $text) = @_; + push (@{ $$self{INDEX} }, $text); + return ''; +} + +# Links reduce to the text that we're given, wrapped in angle brackets if it's +# a URL. +sub cmd_l { + my ($self, $attrs, $text) = @_; + if ($$attrs{type} eq 'url') { + if (not defined($$attrs{to}) or $$attrs{to} eq $text) { + return "<$text>"; + } else { + return "$text <$$attrs{to}>"; + } + } else { + return $text; + } +} + +############################################################################## +# List handling +############################################################################## + +# Handle the beginning of an =over block. Takes the type of the block as the +# first argument, and then the attr hash. This is called by the handlers for +# the four different types of lists (bullet, number, text, and block). +sub over_common_start { + my ($self, $type, $attrs) = @_; + my $line = $$attrs{start_line}; + my $indent = $$attrs{indent}; + DEBUG > 3 and print " Starting =over $type (line $line, indent ", + ($indent || '?'), "\n"; + + # Find the indentation level. + unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) { + $indent = $$self{indent}; + } + + # If we've gotten multiple indentations in a row, we need to emit the + # pending indentation for the last level that we saw and haven't acted on + # yet. SHIFTS is the stack of indentations that we've actually emitted + # code for. + if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) { + $self->output (".RS $$self{INDENT}\n"); + push (@{ $$self{SHIFTS} }, $$self{INDENT}); + } + + # Now, do record-keeping. INDENTS is a stack of indentations that we've + # seen so far, and INDENT is the current level of indentation. ITEMTYPES + # is a stack of list types that we've seen. + push (@{ $$self{INDENTS} }, $$self{INDENT}); + push (@{ $$self{ITEMTYPES} }, $type); + $$self{INDENT} = $indent + 0; + $$self{SHIFTWAIT} = 1; +} + +# End an =over block. Takes no options other than the class pointer. +# Normally, once we close a block and therefore remove something from INDENTS, +# INDENTS will now be longer than SHIFTS, indicating that we also need to emit +# *roff code to close the indent. This isn't *always* true, depending on the +# circumstance. If we're still inside an indentation, we need to emit another +# .RE and then a new .RS to unconfuse *roff. +sub over_common_end { + my ($self) = @_; + DEBUG > 3 and print " Ending =over\n"; + $$self{INDENT} = pop @{ $$self{INDENTS} }; + pop @{ $$self{ITEMTYPES} }; + + # If we emitted code for that indentation, end it. + if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) { + $self->output (".RE\n"); + pop @{ $$self{SHIFTS} }; + } + + # If we're still in an indentation, *roff will have now lost track of the + # right depth of that indentation, so fix that. + if (@{ $$self{INDENTS} } > 0) { + $self->output (".RE\n"); + $self->output (".RS $$self{INDENT}\n"); + } + $$self{NEEDSPACE} = 1; + $$self{SHIFTWAIT} = 0; +} + +# Dispatch the start and end calls as appropriate. +sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) } +sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) } +sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) } +sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) } +sub end_over_bullet { $_[0]->over_common_end } +sub end_over_number { $_[0]->over_common_end } +sub end_over_text { $_[0]->over_common_end } +sub end_over_block { $_[0]->over_common_end } + +# The common handler for all item commands. Takes the type of the item, the +# attributes, and then the text of the item. +# +# Emit an index entry for anything that's interesting, but don't emit index +# entries for things like bullets and numbers. Newlines in an item title are +# turned into spaces since *roff can't handle them embedded. +sub item_common { + my ($self, $type, $attrs, $text) = @_; + my $line = $$attrs{start_line}; + DEBUG > 3 and print " $type item (line $line): $text\n"; + + # Clean up the text. We want to end up with two variables, one ($text) + # which contains any body text after taking out the item portion, and + # another ($item) which contains the actual item text. + $text =~ s/\s+$//; + my ($item, $index); + if ($type eq 'bullet') { + $item = "\\\(bu"; + $text =~ s/\n*$/\n/; + } elsif ($type eq 'number') { + $item = $$attrs{number} . '.'; + } else { + $item = $text; + $item =~ s/\s*\n\s*/ /g; + $text = ''; + $index = $item if ($item =~ /\w/); + } + + # Take care of the indentation. If shifts and indents are equal, close + # the top shift, since we're about to create an indentation with .IP. + # Also output .PD 0 to turn off spacing between items if this item is + # directly following another one. We only have to do that once for a + # whole chain of items so do it for the second item in the change. Note + # that makespace is what undoes this. + if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) { + $self->output (".RE\n"); + pop @{ $$self{SHIFTS} }; + } + $self->output (".PD 0\n") if ($$self{ITEMS} == 1); + + # Now, output the item tag itself. + $item = $self->textmapfonts ($item); + $self->output ($self->switchquotes ('.IP', $item, $$self{INDENT})); + $$self{NEEDSPACE} = 0; + $$self{ITEMS}++; + $$self{SHIFTWAIT} = 0; + + # If body text for this item was included, go ahead and output that now. + if ($text) { + $text =~ s/\s*$/\n/; + $self->makespace; + $self->output ($self->protect ($self->textmapfonts ($text))); + $$self{NEEDSPACE} = 1; + } + $self->outindex ($index ? ('Item', $index) : ()); +} + +# Dispatch the item commands to the appropriate place. +sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) } +sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) } +sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) } +sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) } + +############################################################################## +# Backward compatibility +############################################################################## + +# Reset the underlying Pod::Simple object between calls to parse_from_file so +# that the same object can be reused to convert multiple pages. +sub parse_from_file { + my $self = shift; + $self->reinit; + + # Fake the old cutting option to Pod::Parser. This fiddings with internal + # Pod::Simple state and is quite ugly; we need a better approach. + if (ref ($_[0]) eq 'HASH') { + my $opts = shift @_; + if (defined ($$opts{-cutting}) && !$$opts{-cutting}) { + $$self{in_pod} = 1; + $$self{last_was_blank} = 1; + } + } + + # Do the work. + my $retval = $self->SUPER::parse_from_file (@_); + + # Flush output, since Pod::Simple doesn't do this. Ideally we should also + # close the file descriptor if we had to open one, but we can't easily + # figure this out. + my $fh = $self->output_fh (); + my $oldfh = select $fh; + my $oldflush = $|; + $| = 1; + print $fh ''; + $| = $oldflush; + select $oldfh; + return $retval; +} + +# Pod::Simple failed to provide this backward compatibility function, so +# implement it ourselves. File handles are one of the inputs that +# parse_from_file supports. +sub parse_from_filehandle { + my $self = shift; + $self->parse_from_file (@_); +} + +############################################################################## +# Translation tables +############################################################################## + +# The following table is adapted from Tom Christiansen's pod2man. It assumes +# that the standard preamble has already been printed, since that's what +# defines all of the accent marks. We really want to do something better than +# this when *roff actually supports other character sets itself, since these +# results are pretty poor. +# +# This only works in an ASCII world. What to do in a non-ASCII world is very +# unclear -- hopefully we can assume UTF-8 and just leave well enough alone. +@ESCAPES{0xA0 .. 0xFF} = ( + "\\ ", undef, undef, undef, undef, undef, undef, undef, + undef, undef, undef, undef, undef, "\\%", undef, undef, + + undef, undef, undef, undef, undef, undef, undef, undef, + undef, undef, undef, undef, undef, undef, undef, undef, + + "A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(AE", "C\\*,", + "E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:", + + "\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef, + "O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8", + + "a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,", + "e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:", + + "\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef, + "o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:", +) if ASCII; + +############################################################################## +# Premable +############################################################################## + +# The following is the static preamble which starts all *roff output we +# generate. Most is static except for the font to use as a fixed-width font, +# which is designed by @CFONT@, and the left and right quotes to use for C<> +# text, designated by @LQOUTE@ and @RQUOTE@. However, the second part, which +# defines the accent marks, is only used if $escapes is set to true. +sub preamble_template { + my ($self, $accents) = @_; + my $preamble = <<'----END OF PREAMBLE----'; +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft @CFONT@ +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" Set up some character translations and predefined strings. \*(-- will +.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left +.\" double quote, and \*(R" will give a right double quote. \*(C+ will +.\" give a nicer C++. Capital omega is used to do unbreakable dashes and +.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, +.\" nothing in troff, for use with C<>. +.tr \(*W- +.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' +.ie n \{\ +. ds -- \(*W- +. ds PI pi +. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch +. ds L" "" +. ds R" "" +. ds C` @LQUOTE@ +. ds C' @RQUOTE@ +'br\} +.el\{\ +. ds -- \|\(em\| +. ds PI \(*p +. ds L" `` +. ds R" '' +'br\} +.\" +.\" Escape single quotes in literal strings from groff's Unicode transform. +.ie \n(.g .ds Aq \(aq +.el .ds Aq ' +.\" +.\" If the F register is turned on, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.ie \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. nr % 0 +. rr F +.\} +.el \{\ +. de IX +.. +.\} +----END OF PREAMBLE---- + + if ($accents) { + $preamble .= <<'----END OF PREAMBLE----' +.\" +.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). +.\" Fear. Run. Save yourself. No user-serviceable parts. +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds / +.\} +.if t \{\ +. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" +. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' +. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' +. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' +. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' +. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' +.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +.\} +.rm #[ #] #H #V #F C +----END OF PREAMBLE---- +#`# for cperl-mode + } + return $preamble; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Man - Convert POD data to formatted *roff input + +=for stopwords +en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8 +UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased +Christiansen + +=head1 SYNOPSIS + + use Pod::Man; + my $parser = Pod::Man->new (release => $VERSION, section => 8); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_file (\*STDIN); + + # Read POD from file.pod and write to file.1. + $parser->parse_from_file ('file.pod', 'file.1'); + +=head1 DESCRIPTION + +Pod::Man is a module to convert documentation in the POD format (the +preferred language for documenting Perl) into *roff input using the man +macro set. The resulting *roff code is suitable for display on a terminal +using L<nroff(1)>, normally via L<man(1)>, or printing using L<troff(1)>. +It is conventionally invoked using the driver script B<pod2man>, but it can +also be used directly. + +As a derived class from Pod::Simple, Pod::Man supports the same methods and +interfaces. See L<Pod::Simple> for all the details. + +new() can take options, in the form of key/value pairs that control the +behavior of the parser. See below for details. + +If no options are given, Pod::Man uses the name of the input file with any +trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to +section 1 unless the file ended in C<.pm> in which case it defaults to +section 3, to a centered title of "User Contributed Perl Documentation", to +a centered footer of the Perl version it is run with, and to a left-hand +footer of the modification date of its input (or the current date if given +C<STDIN> for input). + +Pod::Man assumes that your *roff formatters have a fixed-width font named +C<CW>. If yours is called something else (like C<CR>), use the C<fixed> +option to specify it. This generally only matters for troff output for +printing. Similarly, you can set the fonts used for bold, italic, and +bold italic fixed-width output. + +Besides the obvious pod conversions, Pod::Man also takes care of +formatting func(), func(3), and simple variable references like $foo or +@bar so you don't have to use code escapes for them; complex expressions +like C<$fred{'stuff'}> will still need to be escaped, though. It also +translates dashes that aren't used as hyphens into en dashes, makes long +dashes--like this--into proper em dashes, fixes "paired quotes," makes C++ +look right, puts a little space between double underscores, makes ALLCAPS +a teeny bit smaller in B<troff>, and escapes stuff that *roff treats as +special so that you don't have to. + +The recognized options to new() are as follows. All options take a single +argument. + +=over 4 + +=item center + +Sets the centered page header to use instead of "User Contributed Perl +Documentation". + +=item date + +Sets the left-hand footer. By default, the modification date of the input +file will be used, or the current date if stat() can't find that file (the +case if the input is from C<STDIN>), and the date will be formatted as +C<YYYY-MM-DD>. + +=item fixed + +The fixed-width font to use for verbatim text and code. Defaults to +C<CW>. Some systems may want C<CR> instead. Only matters for B<troff> +output. + +=item fixedbold + +Bold version of the fixed-width font. Defaults to C<CB>. Only matters +for B<troff> output. + +=item fixeditalic + +Italic version of the fixed-width font (actually, something of a misnomer, +since most fixed-width fonts only have an oblique version, not an italic +version). Defaults to C<CI>. Only matters for B<troff> output. + +=item fixedbolditalic + +Bold italic (probably actually oblique) version of the fixed-width font. +Pod::Man doesn't assume you have this, and defaults to C<CB>. Some +systems (such as Solaris) have this font available as C<CX>. Only matters +for B<troff> output. + +=item name + +Set the name of the manual page. Without this option, the manual name is +set to the uppercased base name of the file being converted unless the +manual section is 3, in which case the path is parsed to see if it is a Perl +module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into +a name like C<Pod::Man>. This option, if given, overrides any automatic +determination of the name. + +=item quotes + +Sets the quote marks used to surround CE<lt>> text. If the value is a +single character, it is used as both the left and right quote; if it is two +characters, the first character is used as the left quote and the second as +the right quoted; and if it is four characters, the first two are used as +the left quote and the second two as the right quote. + +This may also be set to the special value C<none>, in which case no quote +marks are added around CE<lt>> text (but the font is still changed for troff +output). + +=item release + +Set the centered footer. By default, this is the version of Perl you run +Pod::Man under. Note that some system an macro sets assume that the +centered footer will be a modification date and will prepend something like +"Last modified: "; if this is the case, you may want to set C<release> to +the last modified date and C<date> to the version number. + +=item section + +Set the section for the C<.TH> macro. The standard section numbering +convention is to use 1 for user commands, 2 for system calls, 3 for +functions, 4 for devices, 5 for file formats, 6 for games, 7 for +miscellaneous information, and 8 for administrator commands. There is a lot +of variation here, however; some systems (like Solaris) use 4 for file +formats, 5 for miscellaneous information, and 7 for devices. Still others +use 1m instead of 8, or some mix of both. About the only section numbers +that are reliably consistent are 1, 2, and 3. + +By default, section 1 will be used unless the file ends in C<.pm> in which +case section 3 will be selected. + +=item stderr + +Send error messages about invalid POD to standard error instead of +appending a POD ERRORS section to the generated *roff output. + +=item utf8 + +By default, Pod::Man produces the most conservative possible *roff output +to try to ensure that it will work with as many different *roff +implementations as possible. Many *roff implementations cannot handle +non-ASCII characters, so this means all non-ASCII characters are converted +either to a *roff escape sequence that tries to create a properly accented +character (at least for troff output) or to C<X>. + +If this option is set, Pod::Man will instead output UTF-8. If your *roff +implementation can handle it, this is the best output format to use and +avoids corruption of documents containing non-ASCII characters. However, +be warned that *roff source with literal UTF-8 characters is not supported +by many implementations and may even result in segfaults and other bad +behavior. + +Be aware that, when using this option, the input encoding of your POD +source must be properly declared unless it is US-ASCII or Latin-1. POD +input without an C<=encoding> command will be assumed to be in Latin-1, +and if it's actually in UTF-8, the output will be double-encoded. See +L<perlpod(1)> for more information on the C<=encoding> command. + +=back + +The standard Pod::Simple method parse_file() takes one argument naming the +POD file to read from. By default, the output is sent to C<STDOUT>, but +this can be changed with the output_fd() method. + +The standard Pod::Simple method parse_from_file() takes up to two +arguments, the first being the input file to read POD from and the second +being the file to write the formatted output to. + +You can also call parse_lines() to parse an array of lines or +parse_string_document() to parse a document already in memory. To put the +output into a string instead of a file handle, call the output_string() +method. See L<Pod::Simple> for the specific details. + +=head1 DIAGNOSTICS + +=over 4 + +=item roff font should be 1 or 2 chars, not "%s" + +(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that +wasn't either one or two characters. Pod::Man doesn't support *roff fonts +longer than two characters, although some *roff extensions do (the canonical +versions of B<nroff> and B<troff> don't either). + +=item Invalid quote specification "%s" + +(F) The quote specification given (the quotes option to the constructor) was +invalid. A quote specification must be one, two, or four characters long. + +=back + +=head1 BUGS + +Encoding handling assumes that PerlIO is available and does not work +properly if it isn't. The C<utf8> option is therefore not supported +unless Perl is built with PerlIO support. + +There is currently no way to turn off the guesswork that tries to format +unmarked text appropriately, and sometimes it isn't wanted (particularly +when using POD to document something other than Perl). Most of the work +toward fixing this has now been done, however, and all that's still needed +is a user interface. + +The NAME section should be recognized specially and index entries emitted +for everything in that section. This would have to be deferred until the +next section, since extraneous things in NAME tends to confuse various man +page processors. Currently, no index entries are emitted for anything in +NAME. + +Pod::Man doesn't handle font names longer than two characters. Neither do +most B<troff> implementations, but GNU troff does as an extension. It would +be nice to support as an option for those who want to use it. + +The preamble added to each output file is rather verbose, and most of it +is only necessary in the presence of non-ASCII characters. It would +ideally be nice if all of those definitions were only output if needed, +perhaps on the fly as the characters are used. + +Pod::Man is excessively slow. + +=head1 CAVEATS + +If Pod::Man is given the C<utf8> option, the encoding of its output file +handle will be forced to UTF-8 if possible, overriding any existing +encoding. This will be done even if the file handle is not created by +Pod::Man and was passed in from outside. This maintains consistency +regardless of PERL_UNICODE and other settings. + +The handling of hyphens and em dashes is somewhat fragile, and one may get +the wrong one under some circumstances. This should only matter for +B<troff> output. + +When and whether to use small caps is somewhat tricky, and Pod::Man doesn't +necessarily get it right. + +Converting neutral double quotes to properly matched double quotes doesn't +work unless there are no formatting codes between the quote marks. This +only matters for troff output. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original +B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>. The modifications to +work with Pod::Simple instead of Pod::Parser were originally contributed by +Sean Burke (but I've since hacked them beyond recognition and all bugs are +mine). + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 +Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Pod::Simple>, L<perlpod(1)>, L<pod2man(1)>, L<nroff(1)>, L<troff(1)>, +L<man(1)>, L<man(7)> + +Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual," +Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is +the best documentation of standard B<nroff> and B<troff>. At the time of +this writing, it's available at +L<http://www.cs.bell-labs.com/cm/cs/cstr.html>. + +The man page documenting the man macro set may be L<man(5)> instead of +L<man(7)> on your system. Also, please see L<pod2man(1)> for extensive +documentation on writing manual pages if you've not done it before and +aren't familiar with the conventions. + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm b/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm new file mode 100644 index 00000000000..750fdfb88dc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm @@ -0,0 +1,192 @@ +# Pod::ParseLink -- Parse an L<> formatting code in POD text. +# +# Copyright 2001, 2008, 2009 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module implements parsing of the text of an L<> formatting code as +# defined in perlpodspec. It should be suitable for any POD formatter. It +# exports only one function, parselink(), which returns the five-item parse +# defined in perlpodspec. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::ParseLink; + +require 5.004; + +use strict; +use vars qw(@EXPORT @ISA $VERSION); + +use Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(parselink); + +$VERSION = '1.10'; + +############################################################################## +# Implementation +############################################################################## + +# Parse the name and section portion of a link into a name and section. +sub _parse_section { + my ($link) = @_; + $link =~ s/^\s+//; + $link =~ s/\s+$//; + + # If the whole link is enclosed in quotes, interpret it all as a section + # even if it contains a slash. + return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/); + + # Split into page and section on slash, and then clean up quoting in the + # section. If there is no section and the name contains spaces, also + # guess that it's an old section link. + my ($page, $section) = split (/\s*\/\s*/, $link, 2); + $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section; + if ($page && $page =~ / / && !defined ($section)) { + $section = $page; + $page = undef; + } else { + $page = undef unless $page; + $section = undef unless $section; + } + return ($page, $section); +} + +# Infer link text from the page and section. +sub _infer_text { + my ($page, $section) = @_; + my $inferred; + if ($page && !$section) { + $inferred = $page; + } elsif (!$page && $section) { + $inferred = '"' . $section . '"'; + } elsif ($page && $section) { + $inferred = '"' . $section . '" in ' . $page; + } + return $inferred; +} + +# Given the contents of an L<> formatting code, parse it into the link text, +# the possibly inferred link text, the name or URL, the section, and the type +# of link (pod, man, or url). +sub parselink { + my ($link) = @_; + $link =~ s/\s+/ /g; + my $text; + if ($link =~ /\|/) { + ($text, $link) = split (/\|/, $link, 2); + } + if ($link =~ /\A\w+:[^:\s]\S*\Z/) { + my $inferred; + if (defined ($text) && length ($text) > 0) { + return ($text, $text, $link, undef, 'url'); + } else { + return ($text, $link, $link, undef, 'url'); + } + } else { + my ($name, $section) = _parse_section ($link); + my $inferred; + if (defined ($text) && length ($text) > 0) { + $inferred = $text; + } else { + $inferred = _infer_text ($name, $section); + } + my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod'; + return ($text, $inferred, $name, $section, $type); + } +} + +############################################################################## +# Module return value and documentation +############################################################################## + +# Ensure we evaluate to true. +1; +__END__ + +=head1 NAME + +Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text + +=for stopwords +markup Allbery URL + +=head1 SYNOPSIS + + use Pod::ParseLink; + my ($text, $inferred, $name, $section, $type) = parselink ($link); + +=head1 DESCRIPTION + +This module only provides a single function, parselink(), which takes the +text of an LE<lt>E<gt> formatting code and parses it. It returns the +anchor text for the link (if any was given), the anchor text possibly +inferred from the name and section, the name or URL, the section if any, +and the type of link. The type will be one of C<url>, C<pod>, or C<man>, +indicating a URL, a link to a POD page, or a link to a Unix manual page. + +Parsing is implemented per L<perlpodspec>. For backward compatibility, +links where there is no section and name contains spaces, or links where the +entirety of the link (except for the anchor text if given) is enclosed in +double-quotes are interpreted as links to a section (LE<lt>/sectionE<gt>). + +The inferred anchor text is implemented per L<perlpodspec>: + + L<name> => L<name|name> + L</section> => L<"section"|/section> + L<name/section> => L<"section" in name|name/section> + +The name may contain embedded EE<lt>E<gt> and ZE<lt>E<gt> formatting codes, +and the section, anchor text, and inferred anchor text may contain any +formatting codes. Any double quotes around the section are removed as part +of the parsing, as is any leading or trailing whitespace. + +If the text of the LE<lt>E<gt> escape is entirely enclosed in double +quotes, it's interpreted as a link to a section for backward +compatibility. + +No attempt is made to resolve formatting codes. This must be done after +calling parselink() (since EE<lt>E<gt> formatting codes can be used to +escape characters that would otherwise be significant to the parser and +resolving them before parsing would result in an incorrect parse of a +formatting code like: + + L<verticalE<verbar>barE<sol>slash> + +which should be interpreted as a link to the C<vertical|bar/slash> POD page +and not as a link to the C<slash> section of the C<bar> POD page with an +anchor text of C<vertical>. Note that not only the anchor text will need to +have formatting codes expanded, but so will the target of the link (to deal +with EE<lt>E<gt> and ZE<lt>E<gt> formatting codes), and special handling of +the section may be necessary depending on whether the translator wants to +consider markup in sections to be significant when resolving links. See +L<perlpodspec> for more information. + +=head1 SEE ALSO + +L<Pod::Parser> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2001, 2008, 2009 Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm b/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm new file mode 100644 index 00000000000..f3c7ef46779 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm @@ -0,0 +1,855 @@ +############################################################################# +# 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.36'; ## 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<Pod::ParseUtils> 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<Pod::List> 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-E<gt>new() + +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-E<gt>file() + +Without argument, retrieves the file name the list is in. This must +have been set before by either specifying B<-file> in the B<new()> +method or by calling the B<file()> 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-E<gt>start() + +Without argument, retrieves the line number where the list started. +This must have been set before by either specifying B<-start> in the +B<new()> method or by calling the B<start()> 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-E<gt>indent() + +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<new()> method or by calling the B<indent()> method +with a scalar argument. + +=cut + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + +=item $list-E<gt>type() + +Without argument, retrieves the list type, which can be an arbitrary value, +e.g. C<OL>, C<UL>, ... when thinking the HTML way. +This must have been set before by either specifying +B<-type> in the B<new()> method or by calling the B<type()> method +with a scalar argument. + +=cut + +# The type of the list (UL, OL, ...) +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item $list-E<gt>rx() + +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 C<E<lt>OLE<gt>> already prints numbers itself. +This must have been set before by either specifying +B<-rx> in the B<new()> method or by calling the B<rx()> method +with a scalar argument. + +=cut + +# The regular expression to simplify the items +sub rx { + return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; +} + +=item $list-E<gt>item() + +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-E<gt>parent() + +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<new()> method or by calling the B<parent()> 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-E<gt>tag() + +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<new()> method or by calling the B<tag()> 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<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage: + + my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); + +The B<Pod::Hyperlink> class is mainly designed to parse the contents of the +C<LE<lt>...E<gt>> 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-E<gt>new() + +The B<new()> method can either be passed a set of key/value pairs or a single +scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object +of the class C<Pod::Hyperlink> is returned. The value C<undef> 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-E<gt>parse($string) + +This method can be used to (re)parse a (new) hyperlink, i.e. the contents +of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object. +Warnings are stored in the B<warnings> property. +E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point +to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> 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<func()> 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-E<gt>markup($string) + +Set/retrieve the textual value of the link. This string contains special +markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> 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-E<gt>text() + +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<perl> + *$|* in +perlvar+ L<perlvar/$|> + *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS"> + *DESCRIPTION* L<"DESCRIPTION"> + +=cut + +# The complete link's text +sub text { + return $_[0]->{_text}; +} + +=item $link-E<gt>warning() + +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-E<gt>file() + +=item $link-E<gt>line() + +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-E<gt>page() + +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-E<gt>node() + +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-E<gt>alttext() + +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-E<gt>type() + +The node type, either C<section> or C<item>. As an unofficial type, +there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>> + +=cut + +# The type: item or headn +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item $link-E<gt>link() + +Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>. + +=back + +=cut + +# The link itself +sub link { + my $self = shift; + my $link = $self->page() || ''; + if($self->node()) { + my $node = $self->node(); + $node =~ s/\|/E<verbar>/g; + $node =~ s{/}{E<sol>}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<verbar>/g; + $text =~ s{/}{E<sol>}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<Pod::Cache> holds information about a set of POD documents, +especially the nodes for hyperlinks. +The following methods are available: + +=over 4 + +=item Pod::Cache-E<gt>new() + +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-E<gt>item() + +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-E<gt>find_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<Pod::Cache::Item> 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-E<gt>new() + +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-E<gt>page() + +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-E<gt>description() + +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-E<gt>path() + +Set/retrieve the POD file storage path. + +=cut + +# The file path +sub path { + return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; +} + +=item $cacheitem-E<gt>file() + +Set/retrieve the POD file name. + +=cut + +# The POD file name +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $cacheitem-E<gt>nodes() + +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<find_node> 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-E<gt>find_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-E<gt>idx() + +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<http://rt.cpan.org>. + +Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing +a lot of things from L<pod2man> and L<pod2roff> as well as other POD +processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. + +=head1 SEE ALSO + +L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>, +L<pod2html> + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/Pod/Parser.pm b/Master/tlpkg/tlperl/lib/Pod/Parser.pm new file mode 100644 index 00000000000..c807f3fbade --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Parser.pm @@ -0,0 +1,1829 @@ +############################################################################# +# 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.37'; ## 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<Pod::Parser> 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<Pod::Parser> parses PODs, and makes method calls to handle the various +components of the POD. Subclasses of B<Pod::Parser> 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<Pod::Parser> which typically overrides +just the base class implementation for the following methods: + +=over 2 + +=item * + +B<command()> + +=item * + +B<verbatim()> + +=item * + +B<textblock()> + +=item * + +B<interior_sequence()> + +=back + +You may also want to override the B<begin_input()> and B<end_input()> +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<preprocess_line()> and/or +B<preprocess_paragraph()>. + +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<Pod::Parser> and override your methods to store the +intermediate results in memory somewhere for the B<end_pod()> method to +process. You could use B<Pod::Parser> 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<getline()> method (which is all that +B<parse_from_filehandle()> 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<Pod::Parser> 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<Pod::Parser> to do stream-based +parsing. It is also possible to use the B<Pod::Parser::parse_text> function +to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. + +=head1 PARSING OPTIONS + +A I<parse-option> is simply a named option of B<Pod::Parser> with a +value that corresponds to a certain specified behavior. These various +behaviors of B<Pod::Parser> may be enabled/disabled by setting +or unsetting one or more I<parse-options> using the B<parseopts()> method. +The set of currently accepted parse-options is as follows: + +=over 3 + +=item B<-want_nonPODs> (default: unset) + +Normally (by default) B<Pod::Parser> 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<preprocess_paragraph()>). Setting this option to a +non-empty, non-zero value will allow B<preprocess_paragraph()> to see +non-POD sections of the input as well as POD sections. The B<cutting()> +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<Pod::Parser> 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<Pod::Parser> to +pass the C<=cut> directive to the caller just like any other POD command +(and hence it may be processed by the B<command()> method). + +B<Pod::Parser> 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<Pod::Parser> recognizes a bare minimum of +pod syntax errors and warnings and issues diagnostic messages +for errors, but not for warnings. (Use B<Pod::Checker> to do more +thorough checking of POD syntax.) Setting this option to a non-empty, +non-zero value will cause B<Pod::Parser> 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<Pod::Parser> provides several methods which most subclasses will probably +want to override. These methods are as follows: + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<command()> + + $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<Pod::Paragraph> object which contains further +information about the paragraph command (see L<Pod::InputObjects> +for details). + +=back + +B<Note> that this method I<is> 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<textblock()> +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<verbatim()> + + $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<Pod::Paragraph> object which contains further +information about the paragraph (see L<Pod::InputObjects> +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<textblock()> + + $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<Pod::Paragraph> object which contains further +information about the paragraph (see L<Pod::InputObjects> +for details). + +=back + +In order to process interior sequences, subclasses implementations of +this method will probably want to invoke either B<interpolate()> or +B<parse_text()>, 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<interior_sequence()> + + $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<interpolate()> 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<Pod::InteriorSequence> +object which contains further information about the interior sequence. +Please see L<Pod::InputObjects> for details if you need to access this +additional information. + +Subclass implementations of this method may wish to invoke the +B<nested()> 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<interior_sequence()> 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<Pod::Parser> provides several methods which subclasses may want to override +to perform any special pre/post-processing. These methods do I<not> have to +be overridden, but it may be useful for subclasses to take advantage of them. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<new()> + + my $parser = Pod::Parser->new(); + +This is the constructor for B<Pod::Parser> and its subclasses. You +I<do not> 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<MyParser> is some subclass of B<Pod::Parser>. + +Using the syntax C<MyParser::new()> to invoke the constructor is I<not> +recommended, but if you insist on being able to do this, then the +subclass I<will> need to override the B<new()> constructor method. If +you do override the constructor, you I<must> be sure to invoke the +B<initialize()> 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<new()> +constructor, as in: + + my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 ); + my $parser2 = new MyParser( -myflag => 1 ); + +All arguments passed to the B<new()> 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<new()> 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<initialize()> + + $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<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>. + +=cut + +sub initialize { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<begin_pod()> + + $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<begin_input()> + + $parser->begin_input(); + +This method is invoked by B<parse_from_filehandle()> immediately I<before> +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<begin_pod()>. + +=cut + +sub begin_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<end_input()> + + $parser->end_input(); + +This method is invoked by B<parse_from_filehandle()> immediately I<after> +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<end_pod()>. + +=cut + +sub end_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<end_pod()> + + $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<preprocess_line()> + + $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<line> of input (I<before> 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<preprocess_line()> method is invoked I<before> +the B<preprocess_paragraph()> 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<preprocess_paragraph()> 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<preprocess_paragraph()> + + $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<preprocess_paragraph()> returns, the current cutting state (which +is returned by C<$self-E<gt>cutting()>) 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<preprocess_line()> method is invoked I<before> +the B<preprocess_paragraph()> 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<preprocess_paragraph()> 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<Pod::Parser> 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<parse_text()> + + $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<interpolate> 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<parse_text()> 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<Pod::InteriorSequence>. The result returned is a +parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects> +for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>. + +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<gt> I<code-ref>|I<method-name> + +Normally, the parse-tree returned by B<parse_text()> will contain an +unexpanded C<Pod::InteriorSequence> object for each interior-sequence +encountered. Specifying B<-expand_seq> tells B<parse_text()> 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<NOTE>: If the B<interior_sequence()> method is specified, then it is +invoked according to the interface specified in L<"interior_sequence()">]. + +=item B<-expand_text> =E<gt> I<code-ref>|I<method-name> + +Normally, the parse-tree returned by B<parse_text()> will contain a +text-string for each contiguous sequence of characters outside of an +interior-sequence. Specifying B<-expand_text> tells B<parse_text()> 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<not> 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<gt> I<code-ref>|I<method-name> + +Rather than returning a C<Pod::ParseTree>, 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]<(?:<+\s)?)/; + while ( @tokens ) { + $_ = shift @tokens; + ## Look for the beginning of a sequence + if ( /^([A-Z])(<(?:<+\s)?)$/ ) { + ## 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 += s/\r*\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<interpolate()> + + $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<interpolate()> 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<parse_text> 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<parse_paragraph()> + + $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<command()>, B<verbatim()>, or B<textblock()>). + +For performance reasons, this method is invoked directly without any +dynamic lookup; Hence subclasses may I<not> 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; + ## 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; + + return 1; +} + +##--------------------------------------------------------------------------- + +=head1 B<parse_from_filehandle()> + + $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<STDIN> is used. + +The C<$in_fh> parameter may be any object that provides a B<getline()> +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-E<gt>getline()>, 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<STDOUT> if no output filehandle is currently in use). + +B<NOTE:> 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<will not affect> the input stream used by the current +invocation of this method. + +This method does I<not> 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<parse_from_file()> + + $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<parse_from_filehandle()> 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<E<lt>$fhE<gt>> +or C<$fh-<Egt>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<print>, e.g. L<IO::String>) are also accepted; +the object must already be opened. + +This method does I<not> 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} = '<standard input>'; + $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} = '<standard output>'; + $out_fh = \*STDOUT; + } + } + elsif ($outfile =~ /^>&(STDERR|2)$/i) { + ## Not a filename, just a string implying STDERR + $myData{_OUTFILE} = '<standard error>'; + $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<Pod::Parser> should use the following methods to access +instance data fields: + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<errorsub()> + + $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<must> return TRUE upon +successful printing of the message. If C<undef> is given, then the B<carp> +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<undef> if the B<carp> builtin +is used to issue error messages (this is the default behavior). + +=cut + +sub errorsub { + return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; +} + +##--------------------------------------------------------------------------- + +=head1 B<cutting()> + + $boolean = $parser->cutting(); + +Returns the current C<cutting> state: a boolean-valued scalar which +evaluates to true if text from the input file is currently being "cut" +(meaning it is I<not> considered part of the POD document). + + $parser->cutting($boolean); + +Sets the current C<cutting> state to the given value and returns the +result. + +=cut + +sub cutting { + return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; +} + +##--------------------------------------------------------------------------- + +##--------------------------------------------------------------------------- + +=head1 B<parseopts()> + +When invoked with no additional arguments, B<parseopts> 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<parseopts> treats the string as the +name of a parse-option and returns its corresponding value if it exists +(returns C<undef> 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<parseopts> 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<parseopts> 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<output_file()> + + $fname = $parser->output_file(); + +Returns the name of the output file being written. + +=cut + +sub output_file { + return $_[0]->{_OUTFILE}; +} + +##--------------------------------------------------------------------------- + +=head1 B<output_handle()> + + $fhandle = $parser->output_handle(); + +Returns the output filehandle object. + +=cut + +sub output_handle { + return $_[0]->{_OUTPUT}; +} + +##--------------------------------------------------------------------------- + +=head1 B<input_file()> + + $fname = $parser->input_file(); + +Returns the name of the input file being read. + +=cut + +sub input_file { + return $_[0]->{_INFILE}; +} + +##--------------------------------------------------------------------------- + +=head1 B<input_handle()> + + $fhandle = $parser->input_handle(); + +Returns the current input filehandle object. + +=cut + +sub input_handle { + return $_[0]->{_INPUT}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B<input_streams()> + + $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<parse_from_file()> or B<parse_from_filehandle()> 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<Pod::InputSource> +object. Please see L<Pod::InputObjects> 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<top_stream()> + + $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<undef> +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<Pod::Parser> 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<Pod::Parser> source code. + +Private data fields are stored in the hash-object whose reference is +returned by the B<new()> constructor for this class. The names of all +private methods and data-fields used by B<Pod::Parser> begin with a +prefix of "_" and match the regular expression C</^_\w+$/>. + +=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<Please Note> 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<INPUT> +and C<OUTPUT> 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<interpolate()> method to expand sequences into text, it +may be desirable to instead create a parse-tree using the B<parse_text()> +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<Pod::InputObjects>. The former describes +the gory details and parameters for how to customize and extend the +parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides +several objects that may all be used interchangeably as parse-trees. The +most obvious one is the B<Pod::ParseTree> object. It defines the basic +interface and functionality that all things trying to be a POD parse-tree +should do. A B<Pod::ParseTree> is defined such that each "node" may be a +text-string, or a reference to another parse-tree. Each B<Pod::Paragraph> +object and each B<Pod::InteriorSequence> object also supports the basic +parse-tree interface. + +The B<parse_text()> 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<parse_text()> 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<parse_text()> method is the key to doing +this successfully. Every paragraph-callback (i.e. the polymorphic methods +for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes +a B<Pod::Paragraph> object as an argument. Each paragraph object has a +B<parse_tree()> method that can be used to get or set a corresponding +parse-tree. So for each of those paragraph-callback methods, simply call +B<parse_text()> 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<parse_text>. 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<Pod::ParseTree> 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({<<options>>}, $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({<<options>>}, $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<parse_text> to insert +whole different kinds of objects. Just don't expect B<Pod::Parser> +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<Pod::ParseTree> interface. + +One could use this to create subclasses of B<Pod::Paragraphs> and +B<Pod::InteriorSequences> for specific commands (or to create your own +custom node-types in the parse-tree) and add some kind of B<emit()> +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<emit()> method if they +are objects/references. + +=head1 CAVEATS + +Please note that POD has the notion of "paragraphs": this is something +starting I<after> 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<must> be preceded with a blank +line; C<__END__> is I<not> a blank line. + +=head1 SEE ALSO + +L<Pod::InputObjects>, L<Pod::Select> + +B<Pod::InputObjects> defines POD input objects corresponding to +command paragraphs, parse-trees, and interior-sequences. + +B<Pod::Select> is a subclass of B<Pod::Parser> 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<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users +the ability the employ I<callback functions> instead of, or in addition +to, overriding methods of the base class. + +=for __PRIVATE__ +B<Pod::Select> and B<Pod::Callbacks> do not override any +methods nor do they define any new methods with the same name. Because +of this, they may I<both> 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<http://rt.cpan.org>. + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<Pod::Text> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=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/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm new file mode 100644 index 00000000000..654785a1f70 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm @@ -0,0 +1,1966 @@ + +require 5; +use 5.006; # we use some open(X, "<", $y) syntax +package Pod::Perldoc; +use strict; +use warnings; +use Config '%Config'; + +use Fcntl; # for sysopen +use File::Spec::Functions qw(catfile catdir splitdir); + +use vars qw($VERSION @Pagers $Bindir $Pod2man + $Temp_Files_Created $Temp_File_Lifetime +); +$VERSION = '3.15_02'; +#.......................................................................... + +BEGIN { # Make a DEBUG constant very first thing... + unless(defined &DEBUG) { + if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint + eval("sub DEBUG () {$1}"); + die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; + } else { + *DEBUG = sub () {0}; + } + } +} + +use Pod::Perldoc::GetOptsOO; # uses the DEBUG. + +#.......................................................................... + +sub TRUE () {1} +sub FALSE () {return} +sub BE_LENIENT () {1} + +BEGIN { + *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; + *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; + *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; + *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; + *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin; + *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux; + *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX; +} + +$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; + # If it's older than five days, it's quite unlikely + # that anyone's still looking at it!! + # (Currently used only by the MSWin cleanup routine) + + +#.......................................................................... +{ my $pager = $Config{'pager'}; + push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS; +} +$Bindir = $Config{'scriptdirexp'}; +$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); + +# End of class-init stuff +# +########################################################################### +# +# Option accessors... + +foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) { + no strict 'refs'; + *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; +} + +# And these are so that GetOptsOO knows they take options: +sub opt_f_with { shift->_elem('opt_f', @_) } +sub opt_q_with { shift->_elem('opt_q', @_) } +sub opt_d_with { shift->_elem('opt_d', @_) } +sub opt_L_with { shift->_elem('opt_L', @_) } +sub opt_v_with { shift->_elem('opt_v', @_) } + +sub opt_w_with { # Specify an option for the formatter subclass + my($self, $value) = @_; + if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { + my $option = $1; + my $option_value = defined($2) ? $2 : "TRUE"; + $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" + $self->add_formatter_option( $option, $option_value ); + } else { + warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; + } + return; +} + +sub opt_M_with { # specify formatter class name(s) + my($self, $classes) = @_; + return unless defined $classes and length $classes; + DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; + my @classes_to_add; + foreach my $classname (split m/[,;]+/s, $classes) { + next unless $classname =~ m/\S/; + if( $classname =~ m/^(\w+(::\w+)+)$/s ) { + # A mildly restrictive concept of what modulenames are valid. + push @classes_to_add, $1; # untaint + } else { + warn "\"$classname\" isn't a valid classname. Ignoring.\n"; + } + } + + unshift @{ $self->{'formatter_classes'} }, @classes_to_add; + + DEBUG > 3 and print( + "Adding @classes_to_add to the list of formatter classes, " + . "making them @{ $self->{'formatter_classes'} }.\n" + ); + + return; +} + +sub opt_V { # report version and exit + print join '', + "Perldoc v$VERSION, under perl v$] for $^O", + + (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) + ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), + + (chr(65) eq 'A') ? () : " (non-ASCII)", + + "\n", + ; + exit; +} + +sub opt_t { # choose plaintext as output format + my $self = shift; + $self->opt_o_with('text') if @_ and $_[0]; + return $self->_elem('opt_t', @_); +} + +sub opt_u { # choose raw pod as output format + my $self = shift; + $self->opt_o_with('pod') if @_ and $_[0]; + return $self->_elem('opt_u', @_); +} + +sub opt_n_with { + # choose man as the output format, and specify the proggy to run + my $self = shift; + $self->opt_o_with('man') if @_ and $_[0]; + $self->_elem('opt_n', @_); +} + +sub opt_o_with { # "o" for output format + my($self, $rest) = @_; + return unless defined $rest and length $rest; + if($rest =~ m/^(\w+)$/s) { + $rest = $1; #untaint + } else { + warn "\"$rest\" isn't a valid output format. Skipping.\n"; + return; + } + + $self->aside("Noting \"$rest\" as desired output format...\n"); + + # Figure out what class(es) that could actually mean... + + my @classes; + foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { + # Messy but smart: + foreach my $stem ( + $rest, # Yes, try it first with the given capitalization + "\L$rest", "\L\u$rest", "\U$rest" # And then try variations + + ) { + push @classes, $prefix . $stem; + #print "Considering $prefix$stem\n"; + } + + # Tidier, but misses too much: + #push @classes, $prefix . ucfirst(lc($rest)); + } + $self->opt_M_with( join ";", @classes ); + return; +} + +########################################################################### +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % + +sub run { # to be called by the "perldoc" executable + my $class = shift; + if(DEBUG > 3) { + print "Parameters to $class\->run:\n"; + my @x = @_; + while(@x) { + $x[1] = '<undef>' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + return $class -> new(@_) -> process() || 0; +} + +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % +########################################################################### + +sub new { # yeah, nothing fancy + my $class = shift; + my $new = bless {@_}, (ref($class) || $class); + DEBUG > 1 and print "New $class object $new\n"; + $new->init(); + $new; +} + +#.......................................................................... + +sub aside { # If we're in -D or DEBUG mode, say this. + my $self = shift; + if( DEBUG or $self->opt_D ) { + my $out = join( '', + DEBUG ? do { + my $callsub = (caller(1))[3]; + my $package = quotemeta(__PACKAGE__ . '::'); + $callsub =~ s/^$package/'/os; + # the o is justified, as $package really won't change. + $callsub . ": "; + } : '', + @_, + ); + if(DEBUG) { print $out } else { print STDERR $out } + } + return; +} + +#.......................................................................... + +sub usage { + my $self = shift; + warn "@_\n" if @_; + + # Erase evidence of previous errors (if any), so exit status is simple. + $! = 0; + + die <<EOF; +perldoc [options] PageName|ModuleName|ProgramName... +perldoc [options] -f BuiltinFunction +perldoc [options] -q FAQRegex +perldoc [options] -v PerlVariable + +Options: + -h Display this help message + -V report version + -r Recursive search (slow) + -i Ignore case + -t Display pod using pod2text instead of pod2man and nroff + (-t is the default on win32 unless -n is specified) + -u Display unformatted pod text + -m Display module's file in its entirety + -n Specify replacement for nroff + -l Display the module's file name + -F Arguments are file names, not modules + -D Verbosely describe what's going on + -T Send output to STDOUT without any pager + -d output_filename_to_send_to + -o output_format_name + -M FormatterModuleNameToUse + -w formatter_option:option_value + -L translation_code Choose doc translation (if any) + -X use index if present (looks for pod.idx at $Config{archlib}) + -q Search the text of questions (not answers) in perlfaq[1-9] + -f Search Perl built-in functions + -v Search predefined Perl variables + +PageName|ModuleName... + is the name of a piece of documentation that you want to look at. You + may either give a descriptive name of the page (as in the case of + `perlfunc') the name of a module, either like `Term::Info' or like + `Term/Info', or the name of a program, like `perldoc'. + +BuiltinFunction + is the name of a perl function. Will extract documentation from + `perlfunc'. + +FAQRegex + is a regex. Will search perlfaq[1-9] for and extract any + questions that match. + +Any switches in the PERLDOC environment variable will be used before the +command line arguments. The optional pod index file contains a list of +filenames, one per line. + [Perldoc v$VERSION] +EOF + +} + +#.......................................................................... + +sub usage_brief { + my $me = $0; # Editing $0 is unportable + + $me =~ s,.*[/\\],,; # get basename + + die <<"EOUSAGE"; +Usage: $me [-h] [-V] [-r] [-i] [-D] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName + $me -f PerlFunc + $me -q FAQKeywords + $me -v PerlVar + +The -h option prints more help. Also try "perldoc perldoc" to get +acquainted with the system. [Perldoc v$VERSION] +EOUSAGE + +} + +#.......................................................................... + +sub pagers { @{ shift->{'pagers'} } } + +#.......................................................................... + +sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) + if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } + else { return $_[0]{ $_[1] } } +} +#.......................................................................... +########################################################################### +# +# Init formatter switches, and start it off with __bindir and all that +# other stuff that ToMan.pm needs. +# + +sub init { + my $self = shift; + + # Make sure creat()s are neither too much nor too little + eval { umask(0077) }; # doubtless someone has no mask + + $self->{'args'} ||= \@ARGV; + $self->{'found'} ||= []; + $self->{'temp_file_list'} ||= []; + + + $self->{'target'} = undef; + + $self->init_formatter_class_list; + + $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; + $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; + $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; + + push @{ $self->{'formatter_switches'} = [] }, ( + # Yeah, we could use a hashref, but maybe there's some class where options + # have to be ordered; so we'll use an arrayref. + + [ '__bindir' => $self->{'bindir' } ], + [ '__pod2man' => $self->{'pod2man'} ], + ); + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + $self->{'translators'} = []; + $self->{'extra_search_dirs'} = []; + + return; +} + +#.......................................................................... + +sub init_formatter_class_list { + my $self = shift; + $self->{'formatter_classes'} ||= []; + + # Remember, no switches have been read yet, when + # we've started this routine. + + $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru + $self->opt_o_with('text'); + $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos + || !($ENV{TERM} && ( + ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i + )); + + return; +} + +#.......................................................................... + +sub process { + # if this ever returns, its retval will be used for exit(RETVAL) + + my $self = shift; + DEBUG > 1 and print " Beginning process.\n"; + DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; + if(DEBUG > 3) { + print "Object contents:\n"; + my @x = %$self; + while(@x) { + $x[1] = '<undef>' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + + # TODO: make it deal with being invoked as various different things + # such as perlfaq". + + return $self->usage_brief unless @{ $self->{'args'} }; + $self->pagers_guessing; + $self->options_reading; + $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); + $self->drop_privs_maybe; + $self->options_processing; + + # Hm, we have @pages and @found, but we only really act on one + # file per call, with the exception of the opt_q hack, and with + # -l things + + $self->aside("\n"); + + my @pages; + $self->{'pages'} = \@pages; + if( $self->opt_f) { @pages = ("perlfunc") } + elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } + elsif( $self->opt_v) { @pages = ("perlvar") } + else { @pages = @{$self->{'args'}}; + # @pages = __FILE__ + # if @pages == 1 and $pages[0] eq 'perldoc'; + } + + return $self->usage_brief unless @pages; + + $self->find_good_formatter_class(); + $self->formatter_sanity_check(); + + $self->maybe_diddle_INC(); + # for when we're apparently in a module or extension directory + + my @found = $self->grand_search_init(\@pages); + exit (IS_VMS ? 98962 : 1) unless @found; + + if ($self->opt_l) { + DEBUG and print "We're in -l mode, so byebye after this:\n"; + print join("\n", @found), "\n"; + return; + } + + $self->tweak_found_pathnames(\@found); + $self->assert_closing_stdout; + return $self->page_module_file(@found) if $self->opt_m; + DEBUG > 2 and print "Found: [@found]\n"; + + return $self->render_and_page(\@found); +} + +#.......................................................................... +{ + +my( %class_seen, %class_loaded ); +sub find_good_formatter_class { + my $self = $_[0]; + my @class_list = @{ $self->{'formatter_classes'} || [] }; + die "WHAT? Nothing in the formatter class list!?" unless @class_list; + + my $good_class_found; + foreach my $c (@class_list) { + DEBUG > 4 and print "Trying to load $c...\n"; + if($class_loaded{$c}) { + DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; + $good_class_found = $c; + last; + } + + if($class_seen{$c}) { + DEBUG > 4 and print + "I've tried $c before, and it's no good. Skipping.\n"; + next; + } + + $class_seen{$c} = 1; + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print + "Interesting, the formatter class $c is already loaded!\n"; + + } elsif( + (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) + # the alway case-insensitive fs's + and $class_seen{lc("~$c")}++ + ) { + DEBUG > 4 and print + "We already used something quite like \"\L$c\E\", so no point using $c\n"; + # This avoids redefining the package. + } else { + DEBUG > 4 and print "Trying to eval 'require $c'...\n"; + + local $^W = $^W; + if(DEBUG() or $self->opt_D) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressable warnings from the the require! + } + + eval "require $c"; + if($@) { + DEBUG > 4 and print "Couldn't load $c: $!\n"; + next; + } + } + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print "Settling on $c\n"; + my $v = $c->VERSION; + $v = ( defined $v and length $v ) ? " version $v" : ''; + $self->aside("Formatter class $c$v successfully loaded!\n"); + $good_class_found = $c; + last; + } else { + DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; + } + } + + die "Can't find any loadable formatter class in @class_list?!\nAborting" + unless $good_class_found; + + $self->{'formatter_class'} = $good_class_found; + $self->aside("Will format with the class $good_class_found\n"); + + return; +} + +} +#.......................................................................... + +sub formatter_sanity_check { + my $self = shift; + my $formatter_class = $self->{'formatter_class'} + || die "NO FORMATTER CLASS YET!?"; + + if(!$self->opt_T # so -T can FORCE sending to STDOUT + and $formatter_class->can('is_pageable') + and !$formatter_class->is_pageable + and !$formatter_class->can('page_for_perldoc') + ) { + my $ext = + ($formatter_class->can('output_extension') + && $formatter_class->output_extension + ) || ''; + $ext = ".$ext" if length $ext; + + die + "When using Perldoc to format with $formatter_class, you have to\n" + . "specify -T or -dsomefile$ext\n" + . "See `perldoc perldoc' for more information on those switches.\n" + ; + } +} + +#.......................................................................... + +sub render_and_page { + my($self, $found_list) = @_; + + $self->maybe_generate_dynamic_pod($found_list); + + my($out, $formatter) = $self->render_findings($found_list); + + if($self->opt_d) { + printf "Perldoc (%s) output saved to %s\n", + $self->{'formatter_class'} || ref($self), + $out; + print "But notice that it's 0 bytes long!\n" unless -s $out; + + + } elsif( # Allow the formatter to "page" itself, if it wants. + $formatter->can('page_for_perldoc') + and do { + $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); + if( $formatter->page_for_perldoc($out, $self) ) { + $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); + 1; + } else { + $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); + ''; + } + } + ) { + # Do nothing, since the formatter has "paged" it for itself. + + } else { + # Page it normally (internally) + + if( -s $out ) { # Usual case: + $self->page($out, $self->{'output_to_stdout'}, $self->pagers); + + } else { + # Odd case: + $self->aside("Skipping $out (from $$found_list[0] " + . "via $$self{'formatter_class'}) as it is 0-length.\n"); + + push @{ $self->{'temp_file_list'} }, $out; + $self->unlink_if_temp_file($out); + } + } + + $self->after_rendering(); # any extra cleanup or whatever + + return; +} + +#.......................................................................... + +sub options_reading { + my $self = shift; + + if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { + require Text::ParseWords; + $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); + # Yes, appends to the beginning + unshift @{ $self->{'args'} }, + Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) + ; + DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; + } else { + DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; + } + + DEBUG > 1 + and print " Args right before switch processing: @{$self->{'args'}}\n"; + + Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) + or return $self->usage; + + DEBUG > 1 + and print " Args after switch processing: @{$self->{'args'}}\n"; + + return $self->usage if $self->opt_h; + + return; +} + +#.......................................................................... + +sub options_processing { + my $self = shift; + + if ($self->opt_X) { + my $podidx = "$Config{'archlib'}/pod.idx"; + $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; + $self->{'podidx'} = $podidx; + } + + $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; + + $self->options_sanity; + + $self->opt_n("nroff") unless $self->opt_n; + $self->add_formatter_option( '__nroffer' => $self->opt_n ); + + # Get language from PERLDOC_POD2 environment variable + if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) { + if ( $ENV{PERLDOC_POD2} eq '1' ) { + $self->_elem('opt_L',(split(/\_/, $ENV{LC_ALL} || $ENV{LC_LANG} || $ENV{LANG}))[0] ); + } + else { + $self->_elem('opt_L', $ENV{PERLDOC_POD2}); + } + }; + + # Adjust for using translation packages + $self->add_translator(split(/\s+/,$self->opt_L)) if $self->opt_L; + + return; +} + +#.......................................................................... + +sub options_sanity { + my $self = shift; + + # The opts-counting stuff interacts quite badly with + # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} + # set to -t, and I specify -u on the command line, I don't want + # to be hectored at that -u and -t don't make sense together. + + #my $opts = grep $_ && 1, # yes, the count of the set ones + # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l + #; + # + #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; + + + # Any sanity-checking need doing here? + + # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} + if( $self->opt_f or $self->opt_q ) { + $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q; + warn + "Perldoc is only really meant for reading one word at a time.\n", + "So these parameters are being ignored: ", + join(' ', @{$self->{'args'}}), + "\n" + if @{$self->{'args'}} + } + return; +} + +#.......................................................................... + +sub grand_search_init { + my($self, $pages, @found) = @_; + + foreach (@$pages) { + if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { + my $searchfor = catfile split '::', $_; + $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); + local $_; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; + } + close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; + next; + } + + $self->aside( "Searching for $_\n" ); + + if ($self->opt_F) { + next unless -r; + push @found, $_ if $self->opt_m or $self->containspod($_); + next; + } + + my @searchdirs; + + # prepend extra search directories (including language specific) + push @searchdirs, @{ $self->{'extra_search_dirs'} }; + + # We must look both in @INC for library modules and in $bindir + # for executables, like h2xs or perldoc itself. + push @searchdirs, ($self->{'bindir'}, @INC); + unless ($self->opt_m) { + if (IS_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); + } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); + } + } + my @files = $self->searchfor(0,$_,@searchdirs); + if (@files) { + $self->aside( "Found as @files\n" ); + } + # add "perl" prefix, so "perldoc foo" may find perlfoo.pod + elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) { + $self->aside( "Loosely found as @files\n" ); + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.\z/s,@INC); + @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; + if (@files) { + $self->aside( "Loosely found as @files\n" ); + } + else { + print STDERR "No " . + ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; + if ( @{ $self->{'found'} } ) { + print STDERR "However, try\n"; + for my $dir (@{ $self->{'found'} }) { + opendir(DIR, $dir) or die "opendir $dir: $!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./s); + $file =~ s/\.(pm|pod)\z//; # XXX: badfs + print STDERR "\tperldoc $_\::$file\n"; + } + closedir(DIR) or die "closedir $dir: $!"; + } + } + } + } + push(@found,@files); + } + return @found; +} + +#.......................................................................... + +sub maybe_generate_dynamic_pod { + my($self, $found_things) = @_; + my @dynamic_pod; + + $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; + + $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v; + + $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; + + if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) { + DEBUG > 4 and print "That's a non-dynamic pod search.\n"; + } elsif ( @dynamic_pod ) { + $self->aside("Hm, I found some Pod from that search!\n"); + my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); + + push @{ $self->{'temp_file_list'} }, $buffer; + # I.e., it MIGHT be deleted at the end. + + my $in_list = $self->opt_f || $self->opt_v; + + print $buffd "=over 8\n\n" if $in_list; + print $buffd @dynamic_pod or die "Can't print $buffer: $!"; + print $buffd "=back\n" if $in_list; + + close $buffd or die "Can't close $buffer: $!"; + + @$found_things = $buffer; + # Yes, so found_things never has more than one thing in + # it, by time we leave here + + $self->add_formatter_option('__filter_nroff' => 1); + + } else { + @$found_things = (); + $self->aside("I found no Pod from that search!\n"); + } + + return; +} + +#.......................................................................... + +sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); + my $self = shift; + push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + return; +} + +#......................................................................... + +sub new_translator { # $tr = $self->new_translator($lang); + my $self = shift; + my $lang = shift; + + my $pack = 'POD2::' . uc($lang); + eval "require $pack"; + if ( !$@ && $pack->can('new') ) { + return $pack->new(); + } + + eval { require POD2::Base }; + return if $@; + + return POD2::Base->new({ lang => $lang }); +} + +#......................................................................... + +sub add_translator { # $self->add_translator($lang); + my $self = shift; + for my $lang (@_) { + my $tr = $self->new_translator($lang); + if ( defined $tr ) { + push @{ $self->{'translators'} }, $tr; + push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs; + + $self->aside( "translator for '$lang' loaded\n" ); + } else { + # non-installed or bad translator package + warn "Perldoc cannot load translator package for '$lang': ignored\n"; + } + + } + return; +} + +#.......................................................................... + +sub search_perlvar { + my($self, $found_things, $pod) = @_; + + my $opt = $self->opt_v; + + if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) { + die "'$opt' does not look like a Perl variable\n"; + } + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $perlvar = shift @$found_things; + open(PVAR, "<", $perlvar) # "Funk is its own reward" + or die("Can't open $perlvar: $!"); + + if ( $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9 + $opt = '$<I<digits>>'; + } + my $search_re = quotemeta($opt); + + DEBUG > 2 and + print "Going to perlvar-scan for $search_re in $perlvar\n"; + + # Skip introduction + local $_; + while (<PVAR>) { + last if /^=over 8/; + } + + # Look for our variable + my $found = 0; + my $inheader = 1; + my $inlist = 0; + while (<PVAR>) { # "The Mothership Connection is here!" + last if /^=head2 Error Indicators/; + # \b at the end of $` and friends borks things! + if ( m/^=item\s+$search_re\s/ ) { + $found = 1; + } + elsif (/^=item/) { + last if $found && !$inheader && !$inlist; + } + elsif (!/^\s+$/) { # not a blank line + if ( $found ) { + $inheader = 0; # don't accept more =item (unless inlist) + } + else { + @$pod = (); # reset + $inheader = 1; # start over + next; + } + } + + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + last if $found && !$inheader && !$inlist; + --$inlist; + } + push @$pod, $_; +# ++$found if /^\w/; # found descriptive text + } + @$pod = () unless $found; + if (!@$pod) { + die "No documentation for perl variable '$opt' found\n"; + } + close PVAR or die "Can't open $perlvar: $!"; + + return; +} + +#.......................................................................... + +sub search_perlfunc { + my($self, $found_things, $pod) = @_; + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $perlfunc = shift @$found_things; + open(PFUNC, "<", $perlfunc) # "Funk is its own reward" + or die("Can't open $perlfunc: $!"); + + # Functions like -r, -e, etc. are listed under `-X'. + my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? '(?:I<)?-X' : quotemeta($self->opt_f) ; + + DEBUG > 2 and + print "Going to perlfunc-scan for $search_re in $perlfunc\n"; + + my $re = 'Alphabetical Listing of Perl Functions'; + + # Check available translator or backup to default (english) + if ( $self->opt_L && defined $self->{'translators'}->[0] ) { + my $tr = $self->{'translators'}->[0]; + $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re'); + } + + # Skip introduction + local $_; + while (<PFUNC>) { + last if /^=head2 $re/; + } + + # Look for our function + my $found = 0; + my $inlist = 0; + while (<PFUNC>) { # "The Mothership Connection is here!" + if ( m/^=item\s+$search_re\b/ ) { + $found = 1; + } + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + last if $found > 1 and not $inlist; + --$inlist; + } + push @$pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@$pod) { + die sprintf + "No documentation for perl function `%s' found\n", + $self->opt_f + ; + } + close PFUNC or die "Can't open $perlfunc: $!"; + + return; +} + +#.......................................................................... + +sub search_perlfaqs { + my( $self, $found_things, $pod) = @_; + + my $found = 0; + my %found_in; + my $search_key = $self->opt_q; + + my $rx = eval { qr/$search_key/ } + or die <<EOD; +Invalid regular expression '$search_key' given as -q pattern: +$@ +Did you mean \\Q$search_key ? + +EOD + + local $_; + foreach my $file (@$found_things) { + die "invalid file spec: $!" if $file =~ /[<>|]/; + open(INFAQ, "<", $file) # XXX 5.6ism + or die "Can't read-open $file: $!\nAborting"; + while (<INFAQ>) { + if ( m/^=head2\s+.*(?:$search_key)/i ) { + $found = 1; + push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; + } + elsif (/^=head[12]/) { + $found = 0; + } + next unless $found; + push @$pod, $_; + } + close(INFAQ); + } + die("No documentation for perl FAQ keyword `$search_key' found\n") + unless @$pod; + + return; +} + + +#.......................................................................... + +sub render_findings { + # Return the filename to open + + my($self, $found_things) = @_; + + my $formatter_class = $self->{'formatter_class'} + || die "No formatter class set!?"; + my $formatter = $formatter_class->can('new') + ? $formatter_class->new + : $formatter_class + ; + + if(! @$found_things) { + die "Nothing found?!"; + # should have been caught before here + } elsif(@$found_things > 1) { + warn + "Perldoc is only really meant for reading one document at a time.\n", + "So these parameters are being ignored: ", + join(' ', @$found_things[1 .. $#$found_things] ), + "\n" + } + + my $file = $found_things->[0]; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + # Set formatter options: + if( ref $formatter ) { + foreach my $f (@{ $self->{'formatter_switches'} || [] }) { + my($switch, $value, $silent_fail) = @$f; + if( $formatter->can($switch) ) { + eval { $formatter->$switch( defined($value) ? $value : () ) }; + warn "Got an error when setting $formatter_class\->$switch:\n$@\n" + if $@; + } else { + if( $silent_fail or $switch =~ m/^__/s ) { + DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; + } else { + warn "$formatter_class doesn't recognize the $switch switch.\n"; + } + } + } + } + + $self->{'output_is_binary'} = + $formatter->can('write_with_binmode') && $formatter->write_with_binmode; + + my ($out_fh, $out) = $self->new_output_file( + ( $formatter->can('output_extension') && $formatter->output_extension ) + || undef, + $self->useful_filename_bit, + ); + + # Now, finally, do the formatting! + { + local $^W = $^W; + if(DEBUG() or $self->opt_D) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressable warnings from the formatting! + } + + eval { $formatter->parse_from_file( $file, $out_fh ) }; + } + + warn "Error while formatting with $formatter_class:\n $@\n" if $@; + DEBUG > 2 and print "Back from formatting with $formatter_class\n"; + + close $out_fh + or warn "Can't close $out: $!\n(Did $formatter already close it?)"; + sleep 0; sleep 0; sleep 0; + # Give the system a few timeslices to meditate on the fact + # that the output file does in fact exist and is closed. + + $self->unlink_if_temp_file($file); + + unless( -s $out ) { + if( $formatter->can( 'if_zero_length' ) ) { + # Basically this is just a hook for Pod::Simple::Checker; since + # what other class could /happily/ format an input file with Pod + # as a 0-length output file? + $formatter->if_zero_length( $file, $out, $out_fh ); + } else { + warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" + } + } + + DEBUG and print "Finished writing to $out.\n"; + return($out, $formatter) if wantarray; + return $out; +} + +#.......................................................................... + +sub unlink_if_temp_file { + # Unlink the specified file IFF it's in the list of temp files. + # Really only used in the case of -f / -q things when we can + # throw away the dynamically generated source pod file once + # we've formatted it. + # + my($self, $file) = @_; + return unless defined $file and length $file; + + my $temp_file_list = $self->{'temp_file_list'} || return; + if(grep $_ eq $file, @$temp_file_list) { + $self->aside("Unlinking $file\n"); + unlink($file) or warn "Odd, couldn't unlink $file: $!"; + } else { + DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; + } + return; +} + +#.......................................................................... + +sub MSWin_temp_cleanup { + + # Nothing particularly MSWin-specific in here, but I don't know if any + # other OS needs its temp dir policed like MSWin does! + + my $self = shift; + + my $tempdir = $ENV{'TEMP'}; + return unless defined $tempdir and length $tempdir + and -e $tempdir and -d _ and -w _; + + $self->aside( + "Considering whether any old files of mine in $tempdir need unlinking.\n" + ); + + opendir(TMPDIR, $tempdir) || return; + my @to_unlink; + + my $limit = time() - $Temp_File_Lifetime; + + DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", + ($limit) x 2; + + my $filespec; + + while(defined($filespec = readdir(TMPDIR))) { + if( + $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s + ) { + if( hex($1) < $limit ) { + push @to_unlink, "$tempdir/$filespec"; + $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); + } else { + DEBUG > 5 and + printf " $tempdir/$filespec is too recent (after %x)\n", $limit; + } + } else { + DEBUG > 5 and + print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; + } + } + closedir(TMPDIR); + $self->aside(sprintf "Unlinked %s items of mine in %s\n", + scalar(unlink(@to_unlink)), + $tempdir + ); + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . + +sub MSWin_perldoc_tempfile { + my($self, $suffix, $infix) = @_; + + my $tempdir = $ENV{'TEMP'}; + return unless defined $tempdir and length $tempdir + and -e $tempdir and -d _ and -w _; + + my $spec; + + do { + $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup + # Yes, we embed the create-time in the filename! + $tempdir, + $infix || 'x', + time(), + $$, + defined( &Win32::GetTickCount ) + ? (Win32::GetTickCount() & 0xff) + : int(rand 256) + # Under MSWin, $$ values get reused quickly! So if we ran + # perldoc foo and then perldoc bar before there was time for + # time() to increment time."_$$" would likely be the same + # for each process! So we tack on the tick count's lower + # bits (or, in a pinch, rand) + , + $suffix || 'txt'; + ; + } while( -e $spec ); + + my $counter = 0; + + while($counter < 50) { + my $fh; + # If we are running before perl5.6.0, we can't autovivify + if ($] < 5.006) { + require Symbol; + $fh = Symbol::gensym(); + } + DEBUG > 3 and print "About to try making temp file $spec\n"; + return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism + $self->aside("Can't create temp file $spec: $!\n"); + } + + $self->aside("Giving up on making a temp file!\n"); + die "Can't make a tempfile!?"; +} + +#.......................................................................... + + +sub after_rendering { + my $self = $_[0]; + $self->after_rendering_VMS if IS_VMS; + $self->after_rendering_MSWin32 if IS_MSWin32; + $self->after_rendering_Dos if IS_Dos; + $self->after_rendering_OS2 if IS_OS2; + return; +} + +sub after_rendering_VMS { return } +sub after_rendering_Dos { return } +sub after_rendering_OS2 { return } + +sub after_rendering_MSWin32 { + shift->MSWin_temp_cleanup() if $Temp_Files_Created; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + + +sub minus_f_nocase { # i.e., do like -f, but without regard to case + + my($self, $dir, $file) = @_; + my $path = catfile($dir,$file); + return $path if -f $path and -r _; + + if(!$self->opt_i + or IS_VMS or IS_MSWin32 + or IS_Dos or IS_OS2 + ) { + # On a case-forgiving file system, or if case is important, + # that is it, all we can do. + warn "Ignored $path: unreadable\n" if -f _; + return ''; + } + + local *DIR; + my @p = ($dir); + my($p,$cip); + foreach $p (splitdir $file){ + my $try = catfile @p, $p; + $self->aside("Scrutinizing $try...\n"); + stat $try; + if (-d _) { + push @p, $p; + if ( $p eq $self->{'target'} ) { + my $tmp_path = catfile @p; + my $path_f = 0; + for (@{ $self->{'found'} }) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@{ $self->{'found'} }, $tmp_path) unless $path_f; + $self->aside( "Found as $tmp_path but directory\n" ); + } + } + elsif (-f _ && -r _) { + return $try; + } + elsif (-f _) { + warn "Ignored $try: unreadable\n"; + } + elsif (-d catdir(@p)) { # at least we see the containing directory! + my $found = 0; + my $lcp = lc $p; + my $p_dirspec = catdir(@p); + opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; + while(defined( $cip = readdir(DIR) )) { + if (lc $cip eq $lcp){ + $found++; + last; # XXX stop at the first? what if there's others? + } + } + closedir DIR or die "closedir $p_dirspec: $!"; + return "" unless $found; + + push @p, $cip; + my $p_filespec = catfile(@p); + return $p_filespec if -f $p_filespec and -r _; + warn "Ignored $p_filespec: unreadable\n" if -f _; + } + } + return ""; +} + +#.......................................................................... + +sub pagers_guessing { + my $self = shift; + + my @pagers; + push @pagers, $self->pagers; + $self->{'pagers'} = \@pagers; + + if (IS_MSWin32) { + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + elsif (IS_VMS) { + push @pagers, qw( most more less type/page ); + } + elsif (IS_Dos) { + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + else { + if (IS_OS2) { + unshift @pagers, 'less', 'cmd /c more <'; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + + if (IS_Cygwin) { + if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { + unshift @pagers, '/usr/bin/less -isrR'; + } + } + + unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; + + return; +} + +#.......................................................................... + +sub page_module_file { + my($self, @found) = @_; + + # Security note: + # Don't ever just pass this off to anything like MSWin's "start.exe", + # since we might be calling on a .pl file, and we wouldn't want that + # to actually /execute/ the file that we just want to page thru! + # Also a consideration if one were to use a web browser as a pager; + # doing so could trigger the browser's MIME mapping for whatever + # it thinks .pm/.pl/whatever is. Probably just a (useless and + # annoying) "Save as..." dialog, but potentially executing the file + # in question -- particularly in the case of MSIE and it's, ahem, + # occasionally hazy distinction between OS-local extension + # associations, and browser-specific MIME mappings. + + if ($self->{'output_to_stdout'}) { + $self->aside("Sending unpaged output to STDOUT.\n"); + local $_; + my $any_error = 0; + foreach my $output (@found) { + unless( open(TMP, "<", $output) ) { # XXX 5.6ism + warn("Can't open $output: $!"); + $any_error = 1; + next; + } + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $output: $!"; + $self->unlink_if_temp_file($output); + } + return $any_error; # successful + } + + foreach my $pager ( $self->pagers ) { + $self->aside("About to try calling $pager @found\n"); + if (system($pager, @found) == 0) { + $self->aside("Yay, it worked.\n"); + return 0; + } + $self->aside("That didn't work.\n"); + + # Odd -- when it fails, under Win32, this seems to neither + # return with a fail nor return with a success!! + # That's discouraging! + } + + $self->aside( + sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", + join(' ', @found), + join(' ', $self->pagers), + ); + + if (IS_VMS) { + DEBUG > 1 and print "Bailing out in a VMSish way.\n"; + eval q{ + use vmsish qw(status exit); + exit $?; + 1; + } or die; + } + + return 1; + # i.e., an UNSUCCESSFUL return value! +} + +#.......................................................................... + +sub check_file { + my($self, $dir, $file) = @_; + + unless( ref $self ) { + # Should never get called: + $Carp::Verbose = 1; + require Carp; + Carp::croak( join '', + "Crazy ", __PACKAGE__, " error:\n", + "check_file must be an object_method!\n", + "Aborting" + ); + } + + if(length $dir and not -d $dir) { + DEBUG > 3 and print " No dir $dir -- skipping.\n"; + return ""; + } + + if ($self->opt_m) { + return $self->minus_f_nocase($dir,$file); + } + + else { + my $path = $self->minus_f_nocase($dir,$file); + if( length $path and $self->containspod($path) ) { + DEBUG > 3 and print + " The file $path indeed looks promising!\n"; + return $path; + } + } + DEBUG > 3 and print " No good: $file in $dir\n"; + + return ""; +} + +#.......................................................................... + +sub containspod { + my($self, $file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod\z/i; + + + # Under cygwin the /usr/bin/perl is legal executable, but + # you cannot open a file with that name. It must be spelled + # out as "/usr/bin/perl.exe". + # + # The following if-case under cygwin prevents error + # + # $ perldoc perl + # Cannot open /usr/bin/perl: no such file or directory + # + # This would work though + # + # $ perldoc perl.pod + + if ( IS_Cygwin and -x $file and -f "$file.exe" ) + { + warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_D; + return 0; + } + + local($_); + open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism + while (<TEST>) { + if (/^=head/) { + close(TEST) or die "Can't close $file: $!"; + return 1; + } + } + close(TEST) or die "Can't close $file: $!"; + return 0; +} + +#.......................................................................... + +sub maybe_diddle_INC { + my $self = shift; + + # Does this look like a module or extension directory? + + if (-f "Makefile.PL" || -f "Build.PL") { + + # Add "." and "lib" to @INC (if they exist) + eval q{ use lib qw(. lib); 1; } or die; + + # don't add if superuser + if ($< && $> && -d "blib") { # don't be looking too hard now! + eval q{ use blib; 1 }; + warn $@ if $@ && $self->opt_D; + } + } + + return; +} + +#.......................................................................... + +sub new_output_file { + my $self = shift; + my $outspec = $self->opt_d; # Yes, -d overrides all else! + # So don't call this twice per format-job! + + return $self->new_tempfile(@_) unless defined $outspec and length $outspec; + + # Otherwise open a write-handle on opt_d!f + + my $fh; + # If we are running before perl5.6.0, we can't autovivify + if ($] < 5.006) { + require Symbol; + $fh = Symbol::gensym(); + } + DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; + die "Can't write-open $outspec: $!" + unless open($fh, ">", $outspec); # XXX 5.6ism + + DEBUG > 3 and print "Successfully opened $outspec\n"; + binmode($fh) if $self->{'output_is_binary'}; + return($fh, $outspec); +} + +#.......................................................................... + +sub useful_filename_bit { + # This tries to provide a meaningful bit of text to do with the query, + # such as can be used in naming the file -- since if we're going to be + # opening windows on temp files (as a "pager" may well do!) then it's + # better if the temp file's name (which may well be used as the window + # title) isn't ALL just random garbage! + # In other words "perldoc_LWPSimple_2371981429" is a better temp file + # name than "perldoc_2371981429". So this routine is what tries to + # provide the "LWPSimple" bit. + # + my $self = shift; + my $pages = $self->{'pages'} || return undef; + return undef unless @$pages; + + my $chunk = $pages->[0]; + return undef unless defined $chunk; + $chunk =~ s/:://g; + $chunk =~ s/\.\w+$//g; # strip any extension + if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file + $chunk = $1; + } else { + return undef; + } + $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! + $chunk = substr($chunk, -10) if length($chunk) > 10; + return $chunk; +} + +#.......................................................................... + +sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) + my $self = shift; + + ++$Temp_Files_Created; + + if( IS_MSWin32 ) { + my @out = $self->MSWin_perldoc_tempfile(@_); + return @out if @out; + # otherwise fall thru to the normal stuff below... + } + + require File::Temp; + return File::Temp::tempfile(UNLINK => 1); +} + +#.......................................................................... + +sub page { # apply a pager to the output file + my ($self, $output, $output_to_stdout, @pagers) = @_; + if ($output_to_stdout) { + $self->aside("Sending unpaged output to STDOUT.\n"); + open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism + local $_; + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $output: $!"; + $self->unlink_if_temp_file($output); + } else { + # On VMS, quoting prevents logical expansion, and temp files with no + # extension get the wrong default extension (such as .LIS for TYPE) + + $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; + + $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos; + # Altho "/" under MSWin is in theory good as a pathsep, + # many many corners of the OS don't like it. So we + # have to force it to be "\" to make everyone happy. + + foreach my $pager (@pagers) { + $self->aside("About to try calling $pager $output\n"); + if (IS_VMS) { + last if system("$pager $output") == 0; + } else { + last if system("$pager \"$output\"") == 0; + } + } + } + return; +} + +#.......................................................................... + +sub searchfor { + my($self, $recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if IS_VMS; + return $s if -f $s && $self->containspod($s); + $self->aside( "Looking for $s in @dirs\n" ); + my $ret; + my $i; + my $dir; + $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? + for ($i=0; $i<@dirs; $i++) { + $dir = $dirs[$i]; + next unless -d $dir; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS; + if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) + or ( $ret = $self->check_file($dir,"$s.pm")) + or ( $ret = $self->check_file($dir,$s)) + or ( IS_VMS and + $ret = $self->check_file($dir,"$s.com")) + or ( IS_OS2 and + $ret = $self->check_file($dir,"$s.cmd")) + or ( (IS_MSWin32 or IS_Dos or IS_OS2) and + $ret = $self->check_file($dir,"$s.bat")) + or ( $ret = $self->check_file("$dir/pod","$s.pod")) + or ( $ret = $self->check_file("$dir/pod",$s)) + or ( $ret = $self->check_file("$dir/pods","$s.pod")) + or ( $ret = $self->check_file("$dir/pods",$s)) + ) { + DEBUG > 1 and print " Found $ret\n"; + return $ret; + } + + if ($recurse) { + opendir(D,$dir) or die "Can't opendir $dir: $!"; + my @newdirs = map catfile($dir, $_), grep { + not /^\.\.?\z/s and + not /^auto\z/s and # save time! don't search auto dirs + -d catfile($dir, $_) + } readdir D; + closedir(D) or die "Can't closedir $dir: $!"; + next unless @newdirs; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; + $self->aside( "Also looking in @newdirs\n" ); + push(@dirs,@newdirs); + } + } + return (); +} + +#.......................................................................... +{ + my $already_asserted; + sub assert_closing_stdout { + my $self = shift; + + return if $already_asserted; + + eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; + # What for? to let the pager know that nothing more will come? + + die $@ if $@; + $already_asserted = 1; + return; + } +} + +#.......................................................................... + +sub tweak_found_pathnames { + my($self, $found) = @_; + if (IS_MSWin32) { + foreach (@$found) { s,/,\\,g } + } + return; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + +sub am_taint_checking { + my $self = shift; + die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way + my($k,$v) = each %ENV; + return is_tainted($v); +} + +#.......................................................................... + +sub is_tainted { # just a function + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length! + local $@; # preserve the caller's version of $@ + eval { eval "# $nada" }; + return length($@) != 0; +} + +#.......................................................................... + +sub drop_privs_maybe { + my $self = shift; + + # Attempt to drop privs if we should be tainting and aren't + if (!(IS_VMS || IS_MSWin32 || IS_Dos + || IS_OS2 + ) + && ($> == 0 || $< == 0) + && !$self->am_taint_checking() + ) { + my $id = eval { getpwnam("nobody") }; + $id = eval { getpwnam("nouser") } unless defined $id; + $id = -2 unless defined $id; + # + # According to Stevens' APUE and various + # (BSD, Solaris, HP-UX) man pages, setting + # the real uid first and effective uid second + # is the way to go if one wants to drop privileges, + # because if one changes into an effective uid of + # non-zero, one cannot change the real uid any more. + # + # Actually, it gets even messier. There is + # a third uid, called the saved uid, and as + # long as that is zero, one can get back to + # uid of zero. Setting the real-effective *twice* + # helps in *most* systems (FreeBSD and Solaris) + # but apparently in HP-UX even this doesn't help: + # the saved uid stays zero (apparently the only way + # in HP-UX to change saved uid is to call setuid() + # when the effective uid is zero). + # + eval { + $< = $id; # real uid + $> = $id; # effective uid + $< = $id; # real uid + $> = $id; # effective uid + }; + if( !$@ && $< && $> ) { + DEBUG and print "OK, I dropped privileges.\n"; + } elsif( $self->opt_U ) { + DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." + } else { + DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; + # We used to die here; but that seemed pointless. + } + } + return; +} + +#.......................................................................... + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc - Look up Perl documentation in Pod format. + +=head1 SYNOPSIS + + use Pod::Perldoc (); + + Pod::Perldoc->run(); + +=head1 DESCRIPTION + +The guts of L<perldoc> utility. + +=head1 SEE ALSO + +L<perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002-2007 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + +# +# +# Perldoc -- look up a piece of documentation in .pod format that +# is embedded in the perl installation tree. +# +#~~~~~~ +# +# See ChangeLog in CPAN dist for Pod::Perldoc for later notes. +# +# Version 3.01: Sun Nov 10 21:38:09 MST 2002 +# Sean M. Burke <sburke@cpan.org> +# Massive refactoring and code-tidying. +# Now it's a module(-family)! +# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm +# Added -T, -d, -o, -M, -w. +# Added some improved MSWin funk. +# +#~~~~~~ +# +# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 +# Hugo van der Sanden <hv@crypt.org> +# Made -U the default, based on patch from Simon Cozens +# Version 2.04: Sun Aug 18 13:27:12 BST 2002 +# Randy W. Sims <RandyS@ThePierianSpring.org> +# allow -n to enable nroff under Win32 +# Version 2.03: Sun Apr 23 16:56:34 BST 2000 +# Hugo van der Sanden <hv@crypt.org> +# don't die when 'use blib' fails +# Version 2.02: Mon Mar 13 18:03:04 MST 2000 +# Tom Christiansen <tchrist@perl.com> +# Added -U insecurity option +# Version 2.01: Sat Mar 11 15:22:33 MST 2000 +# Tom Christiansen <tchrist@perl.com>, querulously. +# Security and correctness patches. +# What a twisted bit of distasteful spaghetti code. +# Version 2.0: ???? +# +#~~~~~~ +# +# Version 1.15: Tue Aug 24 01:50:20 EST 1999 +# Charles Wilson <cwilson@ece.gatech.edu> +# changed /pod/ directory to /pods/ for cygwin +# to support cygwin/win32 +# Version 1.14: Wed Jul 15 01:50:20 EST 1998 +# Robin Barker <rmb1@cise.npl.co.uk> +# -strict, -w cleanups +# Version 1.13: Fri Feb 27 16:20:50 EST 1997 +# Gurusamy Sarathy <gsar@activestate.com> +# -doc tweaks for -F and -X options +# Version 1.12: Sat Apr 12 22:41:09 EST 1997 +# Gurusamy Sarathy <gsar@activestate.com> +# -various fixes for win32 +# Version 1.11: Tue Dec 26 09:54:33 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added Charles Bailey's further VMS patches, and -u switch +# -added -t switch, with pod2text support +# +# Version 1.10: Thu Nov 9 07:23:47 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added VMS support +# -added better error recognition (on no found pages, just exit. On +# missing nroff/pod2man, just display raw pod.) +# -added recursive/case-insensitive matching (thanks, Andreas). This +# slows things down a bit, unfortunately. Give a precise name, and +# it'll run faster. +# +# Version 1.01: Tue May 30 14:47:34 EDT 1995 +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# -added pod documentation. +# -added PATH searching. +# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod +# and friends. +# +#~~~~~~~ +# +# TODO: +# +# Cache the directories read during sloppy match +# (To disk, or just in-memory?) +# +# Backport this to perl 5.005? +# +# Implement at least part of the "perlman" interface described +# in Programming Perl 3e? diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm new file mode 100644 index 00000000000..29a3b7d108e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm @@ -0,0 +1,81 @@ + +require 5; +package Pod::Perldoc::BaseTo; +use strict; +use warnings; + +sub is_pageable { '' } +sub write_with_binmode { 1 } + +sub output_extension { 'txt' } # override in subclass! + +# sub new { my $self = shift; ... } +# sub parse_from_file( my($class, $in, $out) = ...; ... } + +#sub new { return bless {}, ref($_[0]) || $_[0] } + +sub _perldoc_elem { + my($self, $name) = splice @_,0,2; + if(@_) { + $self->{$name} = $_[0]; + } else { + $self->{$name}; + } +} + + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::BaseTo - Base for Pod::Perldoc formatters + +=head1 SYNOPSIS + + package Pod::Perldoc::ToMyFormat; + + use base qw( Pod::Perldoc::BaseTo ); + ... + +=head1 DESCRIPTION + +This package is meant as a base of Pod::Perldoc formatters, +like L<Pod::Perldoc::ToText>, L<Pod::Perldoc::ToMan>, etc. + +It provides default implementations for the methods + + is_pageable + write_with_binmode + output_extension + _perldoc_elem + +The concrete formatter must implement + + new + parse_from_file + +=head1 SEE ALSO + +L<perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002-2007 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm new file mode 100644 index 00000000000..fa83fb74ccf --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm @@ -0,0 +1,148 @@ + +require 5; +package Pod::Perldoc::GetOptsOO; +use strict; + +# Rather like Getopt::Std's getopts +# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) +# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) +# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") +# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) +# (Truth defaults to 1) +# Otherwise we try calling $object->handle_unknown_option('n') +# (and we increment the error count by the return value of it) +# If there's no handle_unknown_option, then we just warn, and then increment +# the error counter +# +# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, +# otherwise it's false. +# +## sburke@cpan.org 2002-10-31 + +BEGIN { # Make a DEBUG constant ASAP + *DEBUG = defined( &Pod::Perldoc::DEBUG ) + ? \&Pod::Perldoc::DEBUG + : sub(){10}; +} + + +sub getopts { + my($target, $args, $truth) = @_; + + $args ||= \@ARGV; + + $target->aside( + "Starting switch processing. Scanning arguments [@$args]\n" + ) if $target->can('aside'); + + return unless @$args; + + $truth = 1 unless @_ > 2; + + DEBUG > 3 and print " Truth is $truth\n"; + + + my $error_count = 0; + + while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { + my($first,$rest) = ($1,$2); + if ($_ eq '--') { # early exit if "--" + shift @$args; + last; + } + my $method = "opt_${first}_with"; + if( $target->can($method) ) { # it's argumental + if($rest eq '') { # like -f bar + shift @$args; + warn "Option $first needs a following argument!\n" unless @$args; + $rest = shift @$args; + } else { # like -fbar (== -f bar) + shift @$args; + } + + DEBUG > 3 and print " $method => $rest\n"; + $target->$method( $rest ); + + # Otherwise, it's not argumental... + } else { + + if( $target->can( $method = "opt_$first" ) ) { + DEBUG > 3 and print " $method is true ($truth)\n"; + $target->$method( $truth ); + + # Otherwise it's an unknown option... + + } elsif( $target->can('handle_unknown_option') ) { + DEBUG > 3 + and print " calling handle_unknown_option('$first')\n"; + + $error_count += ( + $target->handle_unknown_option( $first ) || 0 + ); + + } else { + ++$error_count; + warn "Unknown option: $first\n"; + } + + if($rest eq '') { # like -f + shift @$args + } else { # like -fbar (== -f -bar ) + DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; + $args->[0] = "-$rest"; + } + } + } + + + $target->aside( + "Ending switch processing. Args are [@$args] with $error_count errors.\n" + ) if $target->can('aside'); + + $error_count == 0; +} + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc + +=head1 SYNOPSIS + + use Pod::Perldoc::GetOptsOO (); + + Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth ) + or die "wrong usage"; + + +=head1 DESCRIPTION + +Implements a customized option parser used for +L<Pod::Perldoc>. + +=head1 SEE ALSO + + Pod::Perldoc + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002-2007 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm new file mode 100644 index 00000000000..10870109e60 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm @@ -0,0 +1,75 @@ + +require 5; +package Pod::Perldoc::ToChecker; +use strict; +use warnings; +use vars qw(@ISA); + +# Pick our superclass... +# +eval 'require Pod::Simple::Checker'; +if($@) { + require Pod::Checker; + @ISA = ('Pod::Checker'); +} else { + @ISA = ('Pod::Simple::Checker'); +} + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +sub if_zero_length { + my( $self, $file, $tmp, $tmpfd ) = @_; + print "No Pod errors in $file\n"; +} + + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::ToChecker - let Perldoc check Pod for errors + +=head1 SYNOPSIS + + % perldoc -o checker SomeFile.pod + No Pod errors in SomeFile.pod + (or an error report) + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::Checker as a "formatter" class (or if that is +not available, then Pod::Checker), to check for errors in a given +Pod file. + +This is actually a Pod::Simple::Checker (or Pod::Checker) subclass, and +inherits all its options. + +=head1 SEE ALSO + +L<Pod::Simple::Checker>, L<Pod::Simple>, L<Pod::Checker>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm new file mode 100644 index 00000000000..09b0e817377 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm @@ -0,0 +1,190 @@ + +require 5; +package Pod::Perldoc::ToMan; +use strict; +use warnings; + +# This class is unlike ToText.pm et al, because we're NOT paging thru +# the output in our particular format -- we make the output and +# then we run nroff (or whatever) on it, and then page thru the +# (plaintext) output of THAT! + +use base qw(Pod::Perldoc::BaseTo); +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) } +sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) } +sub __bindir { shift->_perldoc_elem('__bindir' , @_) } +sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) } +sub __output_file { shift->_perldoc_elem('__output_file' , @_) } + +sub center { shift->_perldoc_elem('center' , @_) } +sub date { shift->_perldoc_elem('date' , @_) } +sub fixed { shift->_perldoc_elem('fixed' , @_) } +sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } +sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } +sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub release { shift->_perldoc_elem('release' , @_) } +sub section { shift->_perldoc_elem('section' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +use File::Spec::Functions qw(catfile); + +sub parse_from_file { + my $self = shift; + my($file, $outfh) = @_; + + my $render = $self->{'__nroffer'} || die "no nroffer set!?"; + + # turn the switches into CLIs + my $switches = join ' ', + map qq{"--$_=$self->{$_}"}, + grep !m/^_/s, + keys %$self + ; + + my $pod2man = + catfile( + ($self->{'__bindir'} || die "no bindir set?!" ), + ($self->{'__pod2man'} || die "no pod2man set?!" ), + ) + ; + unless(-e $pod2man) { + # This is rarely needed, I think. + $pod2man = $self->{'__pod2man'} || die "no pod2man set?!"; + die "Can't find a pod2man?! (". $self->{'__pod2man'} .")\nAborting" + unless -e $pod2man; + } + + my $command = "$pod2man $switches --lax $file | $render -man"; + # no temp file, just a pipe! + + # Thanks to Brendan O'Dea for contributing the following block + if(Pod::Perldoc::IS_Linux and -t STDOUT + and my ($cols) = `stty -a` =~ m/\bcolumns\s+(\d+)/ + ) { + my $c = $cols * 39 / 40; + $cols = $c > $cols - 2 ? $c : $cols -2; + $command .= ' -rLL=' . (int $c) . 'n' if $cols > 80; + } + + if(Pod::Perldoc::IS_Cygwin) { + $command .= ' -c'; + } + + # I hear persistent reports that adding a -c switch to $render + # solves many people's problems. But I also hear that some mans + # don't have a -c switch, so that unconditionally adding it here + # would presumably be a Bad Thing -- sburke@cpan.org + + $command .= " | col -x" if Pod::Perldoc::IS_HPUX; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to run $command\n"; + ; + + my $rslt = `$command`; + + my $err; + + if( $self->{'__filter_nroff'} ) { + defined(&Pod::Perldoc::DEBUG) + and &Pod::Perldoc::DEBUG() + and print "filter_nroff is set, so filtering...\n"; + $rslt = $self->___Do_filter_nroff($rslt); + } else { + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "filter_nroff isn't set, so not filtering.\n"; + } + + if (($err = $?)) { + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "Nonzero exit ($?) while running $command.\n", + "Falling back to Pod::Perldoc::ToPod\n ", + ; + # A desperate fallthru: + require Pod::Perldoc::ToPod; + return Pod::Perldoc::ToPod->new->parse_from_file(@_); + + } else { + print $outfh $rslt + or die "Can't print to $$self{__output_file}: $!"; + } + + return; +} + + +sub ___Do_filter_nroff { + my $self = shift; + my @data = split /\n{2,}/, shift; + + shift @data while @data and $data[0] !~ /\S/; # Go to header + shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header + pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like + # 28/Jan/99 perl 5.005, patch 53 1 + join "\n\n", @data; +} + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::ToMan - let Perldoc render Pod as man pages + +=head1 SYNOPSIS + + perldoc -o man Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Man and C<nroff> for reading Pod pages. + +The following options are supported: center, date, fixed, fixedbold, +fixeditalic, fixedbolditalic, quotes, release, section + +(Those options are explained in L<Pod::Man>.) + +For example: + + perldoc -o man -w center:Pod Some::Modulename + +=head1 CAVEAT + +This module may change to use a different pod-to-nroff formatter class +in the future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm new file mode 100644 index 00000000000..991c1e3269c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm @@ -0,0 +1,103 @@ + +require 5; +package Pod::Perldoc::ToNroff; +use strict; +use warnings; + +# This is unlike ToMan.pm in that it emits the raw nroff source! + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } # well, if you ask for it... +sub write_with_binmode { 0 } +sub output_extension { 'man' } + +use Pod::Man (); + +sub center { shift->_perldoc_elem('center' , @_) } +sub date { shift->_perldoc_elem('date' , @_) } +sub fixed { shift->_perldoc_elem('fixed' , @_) } +sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } +sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } +sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub release { shift->_perldoc_elem('release' , @_) } +sub section { shift->_perldoc_elem('section' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my $self = shift; + my $file = $_[0]; + + my @options = + map {; $_, $self->{$_} } + grep !m/^_/s, + keys %$self + ; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to call new Pod::Man ", + $Pod::Man::VERSION ? "(v$Pod::Man::VERSION) " : '', + "with options: ", + @options ? "[@options]" : "(nil)", "\n"; + ; + + Pod::Man->new(@options)->parse_from_file(@_); +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToNroff - let Perldoc convert Pod to nroff + +=head1 SYNOPSIS + + perldoc -o nroff -d something.3 Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Man as a formatter class. + +The following options are supported: center, date, fixed, fixedbold, +fixeditalic, fixedbolditalic, quotes, release, section + +Those options are explained in L<Pod::Man>. + +For example: + + perldoc -o nroff -w center:Pod -d something.3 Some::Modulename + +=head1 CAVEAT + +This module may change to use a different pod-to-nroff formatter class +in the future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToMan> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm new file mode 100644 index 00000000000..c3173d43702 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm @@ -0,0 +1,93 @@ + +# This class is just a hack to act as a "formatter" for +# actually unformatted Pod. +# +# Note that this isn't the same as just passing thru whatever +# we're given -- we pass thru only the pod source, and suppress +# the Perl code (or whatever non-pod stuff is in the source file). + + +require 5; +package Pod::Perldoc::ToPod; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'pod' } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my( $self, $in, $outfh ) = @_; + + open(IN, "<", $in) or die "Can't read-open $in: $!\nAborting"; + + my $cut_mode = 1; + + # A hack for finding things between =foo and =cut, inclusive + local $_; + while (<IN>) { + if( m/^=(\w+)/s ) { + if($cut_mode = ($1 eq 'cut')) { + print $outfh "\n=cut\n\n"; + # Pass thru the =cut line with some harmless + # (and occasionally helpful) padding + } + } + next if $cut_mode; + print $outfh $_ or die "Can't print to $outfh: $!"; + } + + close IN or die "Can't close $in: $!"; + return; +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToPod - let Perldoc render Pod as ... Pod! + +=head1 SYNOPSIS + + perldoc -opod Some::Modulename + +(That's currently the same as the following:) + + perldoc -u Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to display Pod source as +itself! Pretty Zen, huh? + +Currently this class works by just filtering out the non-Pod stuff from +a given input file. + +=head1 SEE ALSO + +L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm new file mode 100644 index 00000000000..14d419fc313 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm @@ -0,0 +1,88 @@ + +require 5; +package Pod::Perldoc::ToRtf; +use strict; +use warnings; +use vars qw($VERSION); + +use base qw( Pod::Simple::RTF ); + +$VERSION # so that ->VERSION is happy +# stop CPAN from seeing this + = +$Pod::Simple::RTF::VERSION; + + +sub is_pageable { 0 } +sub write_with_binmode { 0 } +sub output_extension { 'rtf' } + +sub page_for_perldoc { + my($self, $tempfile, $perldoc) = @_; + return unless $perldoc->IS_MSWin32; + + my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe'; + + $perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" ); + + return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0; + return 0; +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToRtf - let Perldoc render Pod as RTF + +=head1 SYNOPSIS + + perldoc -o rtf Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::RTF as a formatter class. + +This is actually a Pod::Simple::RTF subclass, and inherits +all its options. + +You have to have Pod::Simple::RTF installed (from the Pod::Simple dist), +or this module won't work. + +If Perldoc is running under MSWin and uses this class as a formatter, +the output will be opened with F<write.exe> or whatever program is +specified in the environment variable C<RTFREADER>. For example, to +specify that RTF files should be opened the same as they are when you +double-click them, you would do C<set RTFREADER=start.exe> in your +F<autoexec.bat>. + +Handy tip: put C<set PERLDOC=-ortf> in your F<autoexec.bat> +and that will set this class as the default formatter to run when +you do C<perldoc whatever>. + +=head1 SEE ALSO + +L<Pod::Simple::RTF>, L<Pod::Simple>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm new file mode 100644 index 00000000000..7d1784cd59a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm @@ -0,0 +1,95 @@ + +require 5; +package Pod::Perldoc::ToText; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +use Pod::Text (); + +sub alt { shift->_perldoc_elem('alt' , @_) } +sub indent { shift->_perldoc_elem('indent' , @_) } +sub loose { shift->_perldoc_elem('loose' , @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub sentence { shift->_perldoc_elem('sentence', @_) } +sub width { shift->_perldoc_elem('width' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my $self = shift; + + my @options = + map {; $_, $self->{$_} } + grep !m/^_/s, + keys %$self + ; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to call new Pod::Text ", + $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '', + "with options: ", + @options ? "[@options]" : "(nil)", "\n"; + ; + + Pod::Text->new(@options)->parse_from_file(@_); +} + +1; + +=head1 NAME + +Pod::Perldoc::ToText - let Perldoc render Pod as plaintext + +=head1 SYNOPSIS + + perldoc -o text Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Text as a formatter class. + +It supports the following options, which are explained in +L<Pod::Text>: alt, indent, loose, quotes, sentence, width + +For example: + + perldoc -o text -w indent:5 Some::Modulename + +=head1 CAVEAT + +This module may change to use a different text formatter class in the +future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm new file mode 100644 index 00000000000..1562ec8bb3f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm @@ -0,0 +1,132 @@ + +require 5; +package Pod::Perldoc::ToTk; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } # doesn't matter +sub if_zero_length { } # because it will be 0-length! +sub new { return bless {}, ref($_[0]) || $_[0] } + +# TODO: document these and their meanings... +sub tree { shift->_perldoc_elem('tree' , @_) } +sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) } +sub forky { shift->_perldoc_elem('forky' , @_) } + +use Pod::Perldoc (); +use File::Spec::Functions qw(catfile); + +use Tk; +die join '', __PACKAGE__, " doesn't work nice with Tk.pm verison $Tk::VERSION" + if $Tk::VERSION eq '800.003'; + +BEGIN { eval { require Tk::FcyEntry; }; }; +use Tk::Pod; + +# The following was adapted from "tkpod" in the Tk-Pod dist. + +sub parse_from_file { + + my($self, $Input_File) = @_; + if($self->{'forky'}) { + return if fork; # i.e., parent process returns + } + + $Input_File =~ s{\\}{/}g + if Pod::Perldoc::IS_MSWin32 or Pod::Perldoc::IS_Dos + # and maybe OS/2 + ; + + my($tk_opt, $tree); + $tree = $self->{'tree' }; + $tk_opt = $self->{'tk_opt'}; + + #require Tk::ErrorDialog; + + # Add 'Tk' subdirectories to search path so, e.g., + # 'Scrolled' will find doc in 'Tk/Scrolled' + + if( $tk_opt ) { + push @INC, grep -d $_, map catfile($_,'Tk'), @INC; + } + + my $mw = MainWindow->new(); + #eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug'; + $mw->withdraw; + + # CDE use Font Settings if available + my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width + my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional + if (defined($ufont) and defined($sfont)) { + foreach ($ufont, $sfont) { s/:$//; }; + $mw->optionAdd('*Font', $sfont); + $mw->optionAdd('*Entry.Font', $ufont); + $mw->optionAdd('*Text.Font', $ufont); + } + + $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0); + + $mw->Pod( + '-file' => $Input_File, + (($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ()) + )->focusNext; + + # xxx dirty but it works. A simple $mw->destroy if $mw->children + # does not work because Tk::ErrorDialogs could be created. + # (they are withdrawn after Ok instead of destory'ed I guess) + + if ($mw->children) { + $mw->repeat(1000, sub { + # ErrorDialog is withdrawn not deleted :-( + foreach ($mw->children) { + return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod') + } + $mw->destroy; + }); + } else { + $mw->destroy; + } + #$mw->WidgetDump; + MainLoop(); + + exit if $self->{'forky'}; # we were the child! so exit now! + return; +} + +1; +__END__ + + +=head1 NAME + +Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod + +=head1 SYNOPSIS + + perldoc -o tk Some::Modulename & + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Tk::Pod as a formatter class. + +You have to have installed Tk::Pod first, or this class won't load. + +=head1 SEE ALSO + +L<Tk::Pod>, L<Pod::Perldoc> + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke C<sburke@cpan.org>, with significant portions copied from +F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm new file mode 100644 index 00000000000..439e736c20e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm @@ -0,0 +1,66 @@ + +require 5; +package Pod::Perldoc::ToXml; +use strict; +use warnings; +use vars qw($VERSION); + +use base qw( Pod::Simple::XMLOutStream ); + +$VERSION # so that ->VERSION is happy +# stop CPAN from seeing this + = +$Pod::Simple::XMLOutStream::VERSION; + + +sub is_pageable { 0 } +sub write_with_binmode { 0 } +sub output_extension { 'xml' } + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToXml - let Perldoc render Pod as XML + +=head1 SYNOPSIS + + perldoc -o xml -d out.xml Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::XMLOutStream as a formatter class. + +This is actually a Pod::Simple::XMLOutStream subclass, and inherits +all its options. + +You have to have installed Pod::Simple::XMLOutStream (from the Pod::Simple +dist), or this class won't work. + + +=head1 SEE ALSO + +L<Pod::Simple::XMLOutStream>, L<Pod::Simple>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> + +Past contributions from: +Sean M. Burke <sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Pod/PlainText.pm b/Master/tlpkg/tlperl/lib/Pod/PlainText.pm new file mode 100644 index 00000000000..0dce1799b2b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/PlainText.pm @@ -0,0 +1,738 @@ +# 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 <rra@stanford.edu> +# +# 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.04'; + +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</something>. + / + ( + [:\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]*\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<manpage/> forces a manpage interpretation, as does + # something looking like L<manpage(section)>. 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/\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/^([^\n]{0,$width})\s+// || s/^([^\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/\.\n/. \n/g; + s/\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 -<number>. + 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<Pod::Parser> for all the details; briefly, one creates a +new parser with C<Pod::PlainText-E<gt>new()> 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<Pod::Parser> 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 C<EE<lt>E<gt>> 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 C<XE<lt>E<gt>>) 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<Pod::Text::Termcap|Pod::Text::Termcap>. + +=head1 SEE ALSO + +L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>, +pod2text(1) + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the +original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and +its conversion to Pod::Parser by Brad Appleton +E<lt>bradapp@enteract.comE<gt>. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Plainer.pm b/Master/tlpkg/tlperl/lib/Pod/Plainer.pm new file mode 100644 index 00000000000..d9e57bee1e6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Plainer.pm @@ -0,0 +1,100 @@ +package Pod::Plainer; +use 5.006; +use strict; +use warnings; +use if $] >= 5.011, 'deprecate'; +use Pod::Parser; +our @ISA = qw(Pod::Parser); +our $VERSION = '1.02'; + +our %E = qw( < lt > gt ); + +sub escape_ltgt { + (undef, my $text) = @_; + $text =~ s/([<>])/E<$E{$1}>/g; + $text +} + +sub simple_delimiters { + (undef, my $seq) = @_; + $seq -> left_delimiter( '<' ); + $seq -> right_delimiter( '>' ); + $seq; +} + +sub textblock { + my($parser,$text,$line) = @_; + print {$parser->output_handle()} + $parser->parse_text( + { -expand_text => q(escape_ltgt), + -expand_seq => q(simple_delimiters) }, + $text, $line ) -> raw_text(); +} + +1; + +__END__ + +=head1 NAME + +Pod::Plainer - Perl extension for converting Pod to old-style Pod. + +=head1 SYNOPSIS + + use Pod::Plainer; + + my $parser = Pod::Plainer -> new (); + $parser -> parse_from_filehandle(\*STDIN); + +=head1 DESCRIPTION + +Pod::Plainer uses Pod::Parser which takes Pod with the (new) +'CE<lt>E<lt> .. E<gt>E<gt>' constructs +and returns the old(er) style with just 'CE<lt>E<gt>'; +'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'. + +This can be used to pre-process Pod before using tools which do not +recognise the new style Pods. + +=head2 METHODS + +=over + +=item escape_ltgt + +Replace '<' and '>' by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'. + +=item simple_delimiters + +Replace delimiters by 'E<lt>' and 'E<gt>'. + +=item textblock + +Redefine C<textblock> from L<Pod::Parser> to use C<escape_ltgt> +and C<simple_delimiters>. + +=back + +=head2 EXPORT + +None by default. + +=head1 AUTHOR + +Robin Barker, rmbarker@cpan.org + +=head1 SEE ALSO + +See L<Pod::Parser>. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2009 by Robin Barker + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.10.1 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +$Id: Plainer.pm 253 2010-02-11 16:28:10Z rmb1 $ diff --git a/Master/tlpkg/tlperl/lib/Pod/Select.pm b/Master/tlpkg/tlperl/lib/Pod/Select.pm new file mode 100644 index 00000000000..4724cb79cf9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Select.pm @@ -0,0 +1,746 @@ +############################################################################# +# 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.36'; ## 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<podselect()> is a function which will extract specified sections of +pod documentation from an input stream. This ability is provided by the +B<Pod::Select> module which is a subclass of B<Pod::Parser>. +B<Pod::Select> provides a method named B<select()> to specify the set of +POD sections to select for processing/printing. B<podselect()> merely +creates a B<Pod::Select> object and then invokes the B<podselect()> +followed by B<parse_from_file()>. + +=head1 SECTION SPECIFICATIONS + +B<podselect()> and B<Pod::Select::select()> 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<head1-title-regex>/I<head2-title-regex>/... + +=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<negated> (so C<!foo> would match anything I<except> +C<foo>). + +Some example section specifications follow. + +=over 4 + +=item * + +Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections: + +C<NAME|SYNOPSIS> + +=item * + +Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION> +section: + +C<DESCRIPTION/Question|Answer> + +=item * + +Match the C<Comments> subsection of I<all> sections: + +C</Comments> + +=item * + +Match all subsections of C<DESCRIPTION> I<except> for C<Comments>: + +C<DESCRIPTION/!Comments> + +=item * + +Match the C<DESCRIPTION> section but do I<not> match any of its subsections: + +C<DESCRIPTION/!.+> + +=item * + +Match all top level sections but none of their subsections: + +C</!.+> + +=back + +=begin _NOT_IMPLEMENTED_ + +=head1 RANGE SPECIFICATIONS + +B<podselect()> and B<Pod::Select::select()> 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<start-range-regex>/[../I<end-range-regex>/] + +=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<cmd-expr> is intended to match the name of one or more POD +commands, and I<text-expr> 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<must> 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<text-expr> 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<text-expr>. + +Unlike with section-specs, the '!' character does I<not> 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</=for html/> + +=item +Match all paragraphs between C<=begin html> and C<=end html> +(note that this will I<not> work correctly if such sections +are nested): + +C</=begin html/../=end html/> + +=item +Match all paragraphs between the given C<=item> name until the end of the +current section: + +C</=item mine/../=head\d/> + +=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<not> work as +desired if the item contains an itemized list nested within it): + +C</=item mine/../=(item|back)/> + +=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<curr_headings()> + + ($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<undef> 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<select()> + + $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<replaced> with the given set of sections. +See B<add_selection()> 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<all> sections will be +processed). + +This method should I<not> 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<add_selection()> + + $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 <select()> 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<not> normally be overridden by subclasses. + +=cut + +sub add_selection { + my $self = shift; + return $self->select('+', @_); +} + +##--------------------------------------------------------------------------- + +=head1 B<clear_selections()> + + $parser->clear_selections(); + +This method takes no arguments, it has the exact same effect as invoking +<select()> with no arguments. + +=cut + +sub clear_selections { + my $self = shift; + return $self->select(); +} + +##--------------------------------------------------------------------------- + +=head1 B<match_section()> + + $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<select()> and B<add_selection()> (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<not> 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<is_selected()> + + $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<do not> take an +implicit first argument. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<podselect()> + + podselect(\%options,@filelist); + +B<podselect> 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<podselect> 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<Pod::Select> 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<Pod::Select> source code. + +Private data fields are stored in the hash-object whose reference is +returned by the B<new()> constructor for this class. The names of all +private methods and data-fields used by B<Pod::Select> begin with a +prefix of "_" and match the regular expression C</^_\w+$/>. + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_compile_section_spec()> + + $listref = $parser->_compile_section_spec($section_spec); + +This function (note it is a function and I<not> 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<undef> is returned and an error message is printed (using +B<carp>) 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<gt>{_SECTION_HEADINGS}> +that it is to be matched against. + +=end _PRIVATE_ + +=cut + +############################################################################# + +=head1 SEE ALSO + +L<Pod::Parser> + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<pod2text> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + +1; +# vim: ts=4 sw=4 et diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pm b/Master/tlpkg/tlperl/lib/Pod/Simple.pm new file mode 100644 index 00000000000..51f9a698019 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple.pm @@ -0,0 +1,1535 @@ + +require 5; +package Pod::Simple; +use strict; +use Carp (); +BEGIN { *DEBUG = sub () {0} unless defined &DEBUG } +use integer; +use Pod::Escapes 1.04 (); +use Pod::Simple::LinkSection (); +use Pod::Simple::BlackBox (); +#use utf8; + +use vars qw( + $VERSION @ISA + @Known_formatting_codes @Known_directives + %Known_formatting_codes %Known_directives + $NL +); + +@ISA = ('Pod::Simple::BlackBox'); +$VERSION = '3.14'; + +@Known_formatting_codes = qw(I B C L E F S X Z); +%Known_formatting_codes = map(($_=>1), @Known_formatting_codes); +@Known_directives = qw(head1 head2 head3 head4 item over back); +%Known_directives = map(($_=>'Plain'), @Known_directives); +$NL = $/ unless defined $NL; + +#----------------------------------------------------------------------------- +# Set up some constants: + +BEGIN { + if(defined &ASCII) { } + elsif(chr(65) eq 'A') { *ASCII = sub () {1} } + else { *ASCII = sub () {''} } + + unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} } + DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n"; + unless(MANY_LINES() >= 1) { + die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting"; + } + if(defined &UNICODE) { } + elsif($] >= 5.008) { *UNICODE = sub() {1} } + else { *UNICODE = sub() {''} } +} +if(DEBUG > 2) { + print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n"; + print "# We are under a Unicode-safe Perl.\n"; +} + +# Design note: +# This is a parser for Pod. It is not a parser for the set of Pod-like +# languages which happens to contain Pod -- it is just for Pod, plus possibly +# some extensions. + +# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ +#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +__PACKAGE__->_accessorize( + 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters + 'source_filename', # Filename of the source, for use in warnings + 'source_dead', # Whether to consider this parser's source dead + + 'output_fh', # The filehandle we're writing to, if applicable. + # Used only in some derived classes. + + 'hide_line_numbers', # For some dumping subclasses: whether to pointedly + # suppress the start_line attribute + + 'line_count', # the current line number + 'pod_para_count', # count of pod paragraphs seen so far + + 'no_whining', # whether to suppress whining + 'no_errata_section', # whether to suppress the errata section + 'complain_stderr', # whether to complain to stderr + + 'doc_has_started', # whether we've fired the open-Document event yet + + 'bare_output', # For some subclasses: whether to prepend + # header-code and postpend footer-code + + 'nix_X_codes', # whether to ignore X<...> codes + 'merge_text', # whether to avoid breaking a single piece of + # text up into several events + + 'preserve_whitespace', # whether to try to keep whitespace as-is + 'strip_verbatim_indent', # What indent to strip from verbatim + + 'content_seen', # whether we've seen any real Pod content + 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not) + + 'codes_in_verbatim', # for PseudoPod extensions + + 'code_handler', # coderef to call when a code (non-pod) line is seen + 'cut_handler', # coderef to call when a =cut line is seen + #Called like: + # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler; + # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler; + +); + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub any_errata_seen { # good for using as an exit() value... + return shift->{'errors_seen'} || 0; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# Pull in some functions that, for some reason, I expect to see here too: +BEGIN { + *pretty = \&Pod::Simple::BlackBox::pretty; + *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub version_report { + my $class = ref($_[0]) || $_[0]; + if($class eq __PACKAGE__) { + return "$class $VERSION"; + } else { + my $v = $class->VERSION; + return "$class $v (" . __PACKAGE__ . " $VERSION)"; + } +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +#sub curr_open { # read-only list accessor +# return @{ $_[0]{'curr_open'} || return() }; +#} +#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] } + + +sub output_string { + # Works by faking out output_fh. Simplifies our code. + # + my $this = shift; + return $this->{'output_string'} unless @_; # GET. + + require Pod::Simple::TiedOutFH; + my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] ); + $$x = '' unless defined $$x; + DEBUG > 4 and print "# Output string set to $x ($$x)\n"; + $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]); + return + $this->{'output_string'} = $_[0]; + #${ ${ $this->{'output_fh'} } }; +} + +sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} } +sub abandon_output_fh { $_[0]->output_fh(undef) } +# These don't delete the string or close the FH -- they just delete our +# references to it/them. +# TODO: document these + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub new { + # takes no parameters + my $class = ref($_[0]) || $_[0]; + #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc " + # . __PACKAGE__ ); + return bless { + 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) }, + 'accept_directives' => { %Known_directives }, + 'accept_targets' => {}, + }, $class; +} + + + +# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes. + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_element_start { # OVERRIDE IN DERIVED CLASS + my($self, $element_name, $attr_hash_r) = @_; + return; +} + +sub _handle_element_end { # OVERRIDE IN DERIVED CLASS + my($self, $element_name) = @_; + return; +} + +sub _handle_text { # OVERRIDE IN DERIVED CLASS + my($self, $text) = @_; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And now directives (not targets) + +sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) } +sub accept_directive_as_data { shift->_accept_directives('Data', @_) } +sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) } + +sub _accept_directives { + my($this, $type) = splice @_,0,2; + foreach my $d (@_) { + next unless defined $d and length $d; + Carp::croak "\"$d\" isn't a valid directive name" + unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s; + Carp::croak "\"$d\" is already a reserved Pod directive name" + if exists $Known_directives{$d}; + $this->{'accept_directives'}{$d} = $type; + DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n"; + } + DEBUG > 6 and print "$this\'s accept_directives : ", + pretty($this->{'accept_directives'}), "\n"; + + return sort keys %{ $this->{'accept_directives'} } if wantarray; + return; +} + +#-------------------------------------------------------------------------- +# TODO: document these: + +sub unaccept_directive { shift->unaccept_directives(@_) }; + +sub unaccept_directives { + my $this = shift; + foreach my $d (@_) { + next unless defined $d and length $d; + Carp::croak "\"$d\" isn't a valid directive name" + unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s; + Carp::croak "But you must accept \"$d\" directives -- it's a builtin!" + if exists $Known_directives{$d}; + delete $this->{'accept_directives'}{$d}; + DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n"; + } + return sort keys %{ $this->{'accept_directives'} } if wantarray; + return +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And now targets (not directives) + +sub accept_target { shift->accept_targets(@_) } # alias +sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias + + +sub accept_targets { shift->_accept_targets('1', @_) } + +sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) } + # forces them to be processed, even when there's no ":". + +sub _accept_targets { + my($this, $type) = splice @_,0,2; + foreach my $t (@_) { + next unless defined $t and length $t; + # TODO: enforce some limitations on what a target name can be? + $this->{'accept_targets'}{$t} = $type; + DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n"; + } + return sort keys %{ $this->{'accept_targets'} } if wantarray; + return; +} + +#-------------------------------------------------------------------------- +sub unaccept_target { shift->unaccept_targets(@_) } + +sub unaccept_targets { + my $this = shift; + foreach my $t (@_) { + next unless defined $t and length $t; + # TODO: enforce some limitations on what a target name can be? + delete $this->{'accept_targets'}{$t}; + DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n"; + } + return sort keys %{ $this->{'accept_targets'} } if wantarray; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And now codes (not targets or directives) + +sub accept_code { shift->accept_codes(@_) } # alias + +sub accept_codes { # Add some codes + my $this = shift; + + foreach my $new_code (@_) { + next unless defined $new_code and length $new_code; + if(ASCII) { + # A good-enough check that it's good as an XML Name symbol: + Carp::croak "\"$new_code\" isn't a valid element name" + if $new_code =~ + m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ + # Characters under 0x80 that aren't legal in an XML Name. + or $new_code =~ m/^[-\.0-9]/s + or $new_code =~ m/:[-\.0-9]/s; + # The legal under-0x80 Name characters that + # an XML Name still can't start with. + } + + $this->{'accept_codes'}{$new_code} = $new_code; + + # Yes, map to itself -- just so that when we + # see "=extend W [whatever] thatelementname", we say that W maps + # to whatever $this->{accept_codes}{thatelementname} is, + # i.e., "thatelementname". Then when we go re-mapping, + # a "W" in the treelet turns into "thatelementname". We only + # remap once. + # If we say we accept "W", then a "W" in the treelet simply turns + # into "W". + } + + return; +} + +#-------------------------------------------------------------------------- +sub unaccept_code { shift->unaccept_codes(@_) } + +sub unaccept_codes { # remove some codes + my $this = shift; + + foreach my $new_code (@_) { + next unless defined $new_code and length $new_code; + if(ASCII) { + # A good-enough check that it's good as an XML Name symbol: + Carp::croak "\"$new_code\" isn't a valid element name" + if $new_code =~ + m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ + # Characters under 0x80 that aren't legal in an XML Name. + or $new_code =~ m/^[-\.0-9]/s + or $new_code =~ m/:[-\.0-9]/s; + # The legal under-0x80 Name characters that + # an XML Name still can't start with. + } + + Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!" + if grep $new_code eq $_, @Known_formatting_codes; + + delete $this->{'accept_codes'}{$new_code}; + + DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n"; + } + + return; +} + + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub parse_string_document { + my $self = shift; + my @lines; + foreach my $line_group (@_) { + next unless defined $line_group and length $line_group; + pos($line_group) = 0; + while($line_group =~ + m/([^\n\r]*)((?:\r?\n)?)/g + ) { + #print(">> $1\n"), + $self->parse_lines($1) + if length($1) or length($2) + or pos($line_group) != length($line_group); + # I.e., unless it's a zero-length "empty line" at the very + # end of "foo\nbar\n" (i.e., between the \n and the EOS). + } + } + $self->parse_lines(undef); # to signal EOF + return $self; +} + +sub _init_fh_source { + my($self, $source) = @_; + + #DEBUG > 1 and print "Declaring $source as :raw for starters\n"; + #$self->_apply_binmode($source, ':raw'); + #binmode($source, ":raw"); + + return; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. +# + +sub parse_file { + my($self, $source) = (@_); + + if(!defined $source) { + Carp::croak("Can't use empty-string as a source for parse_file"); + } elsif(ref(\$source) eq 'GLOB') { + $self->{'source_filename'} = '' . ($source); + } elsif(ref $source) { + $self->{'source_filename'} = '' . ($source); + } elsif(!length $source) { + Carp::croak("Can't use empty-string as a source for parse_file"); + } else { + { + local *PODSOURCE; + open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!"); + $self->{'source_filename'} = $source; + $source = *PODSOURCE{IO}; + } + $self->_init_fh_source($source); + } + # By here, $source is a FH. + + $self->{'source_fh'} = $source; + + my($i, @lines); + until( $self->{'source_dead'} ) { + splice @lines; + for($i = MANY_LINES; $i--;) { # read those many lines at a time + local $/ = $NL; + push @lines, scalar(<$source>); # readline + last unless defined $lines[-1]; + # but pass thru the undef, which will set source_dead to true + } + $self->parse_lines(@lines); + } + delete($self->{'source_fh'}); # so it can be GC'd + return $self; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub parse_from_file { + # An emulation of Pod::Parser's interface, for the sake of Perldoc. + # Basically just a wrapper around parse_file. + + my($self, $source, $to) = @_; + $self = $self->new unless ref($self); # so we tolerate being a class method + + if(!defined $source) { $source = *STDIN{IO} + } elsif(ref(\$source) eq 'GLOB') { # stet + } elsif(ref($source) ) { # stet + } elsif(!length $source + or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i + ) { + $source = *STDIN{IO}; + } + + if(!defined $to) { $self->output_fh( *STDOUT{IO} ); + } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to ); + } elsif(ref($to)) { $self->output_fh( $to ); + } elsif(!length $to + or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i + ) { + $self->output_fh( *STDOUT{IO} ); + } else { + require Symbol; + my $out_fh = Symbol::gensym(); + DEBUG and print "Write-opening to $to\n"; + open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!"; + binmode($out_fh) + if $self->can('write_with_binmode') and $self->write_with_binmode; + $self->output_fh($out_fh); + } + + return $self->parse_file($source); +} + +#----------------------------------------------------------------------------- + +sub whine { + #my($self,$line,$complaint) = @_; + my $self = shift(@_); + ++$self->{'errors_seen'}; + if($self->{'no_whining'}) { + DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n"; + return; + } + return $self->_complain_warn(@_) if $self->{'complain_stderr'}; + return $self->_complain_errata(@_); +} + +sub scream { # like whine, but not suppressable + #my($self,$line,$complaint) = @_; + my $self = shift(@_); + ++$self->{'errors_seen'}; + return $self->_complain_warn(@_) if $self->{'complain_stderr'}; + return $self->_complain_errata(@_); +} + +sub _complain_warn { + my($self,$line,$complaint) = @_; + return printf STDERR "%s around line %s: %s\n", + $self->{'source_filename'} || 'Pod input', $line, $complaint; +} + +sub _complain_errata { + my($self,$line,$complaint) = @_; + if( $self->{'no_errata_section'} ) { + DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n"; + } else { + DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n"; + push @{$self->{'errata'}{$line}}, $complaint + # for a report to be generated later! + } + return 1; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _get_initial_item_type { + # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n" + my($self, $para) = @_; + return $para->[1]{'~type'} if $para->[1]{'~type'}; + + return $para->[1]{'~type'} = 'text' + if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1'; + # Else fall thru to the general case: + return $self->_get_item_type($para); +} + + + +sub _get_item_type { # mutates the item!! + my($self, $para) = @_; + return $para->[1]{'~type'} if $para->[1]{'~type'}; + + + # Otherwise we haven't yet been to this node. Maybe alter it... + + my $content = join "\n", @{$para}[2 .. $#$para]; + + if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) { + # Like: "=item *", "=item * ", "=item" + splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] + $para->[1]{'~orig_content'} = $content; + return $para->[1]{'~type'} = 'bullet'; + + } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance + + # Like: "=item * Foo bar baz"; + $para->[1]{'~orig_content'} = $content; + $para->[1]{'~_freaky_para_hack'} = $1; + DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n"; + splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] + return $para->[1]{'~type'} = 'bullet'; + + } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) { + # Like: "=item 1.", "=item 123412" + + $para->[1]{'~orig_content'} = $content; + $para->[1]{'number'} = $1; # Yes, stores the number there! + + splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] + return $para->[1]{'~type'} = 'number'; + + } else { + # It's anything else. + return $para->[1]{'~type'} = 'text'; + + } +} + +#----------------------------------------------------------------------------- + +sub _make_treelet { + my $self = shift; # and ($para, $start_line) + my $treelet; + if(!@_) { + return ['']; + } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') { + # Hack so we can pass in fake-o pre-cooked paragraphs: + # just have the first line be a reference to a ['~Top', {}, ...] + # We use this feechure in gen_errata and stuff. + + DEBUG and print "Applying precooked treelet hack to $_[0][0]\n"; + $treelet = $_[0][0]; + splice @$treelet, 0, 2; # lop the top off + return $treelet; + } else { + $treelet = $self->_treelet_from_formatting_codes(@_); + } + + if( $self->_remap_sequences($treelet) ) { + $self->_treat_Zs($treelet); # Might as well nix these first + $self->_treat_Ls($treelet); # L has to precede E and S + $self->_treat_Es($treelet); + $self->_treat_Ss($treelet); # S has to come after E + + $self->_wrap_up($treelet); # Nix X's and merge texties + + } else { + DEBUG and print "Formatless treelet gets fast-tracked.\n"; + # Very common case! + } + + splice @$treelet, 0, 2; # lop the top off + + return $treelet; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub _wrap_up { + my($self, @stack) = @_; + my $nixx = $self->{'nix_X_codes'}; + my $merge = $self->{'merge_text' }; + return unless $nixx or $merge; + + DEBUG > 2 and print "\nStarting _wrap_up traversal.\n", + $merge ? (" Merge mode on\n") : (), + $nixx ? (" Nix-X mode on\n") : (), + ; + + + my($i, $treelet); + while($treelet = shift @stack) { + DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n"; + for($i = 2; $i < @$treelet; ++$i) { # iterate over children + DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n"; + if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') { + DEBUG > 3 and print " Nixing X node at $i\n"; + splice(@$treelet, $i, 1); # just nix this node (and its descendants) + # no need to back-update the counter just yet + redo; + + } elsif($merge and $i != 2 and # non-initial + !ref $treelet->[$i] and !ref $treelet->[$i - 1] + ) { + DEBUG > 3 and print " Merging ", $i-1, + ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n"; + $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0]; + DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n"; + --$i; + next; + # since we just pulled the possibly last node out from under + # ourselves, we can't just redo() + + } elsif( ref $treelet->[$i] ) { + DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n"; + push @stack, $treelet->[$i]; + + if($treelet->[$i][0] eq 'L') { + my $thing; + foreach my $attrname ('section', 'to') { + if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { + unshift @stack, $thing; + DEBUG > 4 and print " +Enqueuing ", + pretty( $treelet->[$i][1]{$attrname} ), + " as an attribute value to tweak.\n"; + } + } + } + } + } + } + DEBUG > 2 and print "End of _wrap_up traversal.\n\n"; + + return; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub _remap_sequences { + my($self,@stack) = @_; + + if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) { + # VERY common case: abort it. + DEBUG and print "Skipping _remap_sequences: formatless treelet.\n"; + return 0; + } + + my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?"); + + my $start_line = $stack[0][1]{'start_line'}; + DEBUG > 2 and printf + "\nAbout to start _remap_sequences on treelet from line %s.\n", + $start_line || '[?]' + ; + DEBUG > 3 and print " Map: ", + join('; ', map "$_=" . ( + ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_} + ), + sort keys %$map ), + ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map) + ? " (all normal)\n" : "\n" + ; + + # A recursive algorithm implemented iteratively! Whee! + + my($is, $was, $i, $treelet); # scratch + while($treelet = shift @stack) { + DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n"; + for($i = 2; $i < @$treelet; ++$i) { # iterate over children + next unless ref $treelet->[$i]; # text nodes are uninteresting + + DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n"; + + $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] }; + if( DEBUG > 3 ) { + if(!defined $is) { + print " Code $was<> is UNKNOWN!\n"; + } elsif($is eq $was) { + DEBUG > 4 and print " Code $was<> stays the same.\n"; + } else { + print " Code $was<> maps to ", + ref($is) + ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" ) + : "tag $is<...>.\n"; + } + } + + if(!defined $is) { + $self->whine($start_line, "Deleting unknown formatting code $was<>"); + $is = $treelet->[$i][0] = '1'; # But saving the children! + # I could also insert a leading "$was<" and tailing ">" as + # children of this node, but something about that seems icky. + } + if(ref $is) { + my @dynasty = @$is; + DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n"; + $treelet->[$i][0] = pop @dynasty; + my $nugget; + while(@dynasty) { + DEBUG > 4 and printf + " Grafting a new %s node between %s and %s\n", + $dynasty[-1], $treelet->[0], $treelet->[$i][0], + ; + + #$nugget = ; + splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]]; + # relace node with a new parent + } + } elsif($is eq '0') { + splice(@$treelet, $i, 1); # just nix this node (and its descendants) + --$i; # back-update the counter + } elsif($is eq '1') { + splice(@$treelet, $i, 1 # replace this node with its children! + => splice @{ $treelet->[$i] },2 + # (not catching its first two (non-child) items) + ); + --$i; # back up for new stuff + } else { + # otherwise it's unremarkable + unshift @stack, $treelet->[$i]; # just recurse + } + } + } + + DEBUG > 2 and print "End of _remap_sequences traversal.\n\n"; + + if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) { + DEBUG and print "Noting that the treelet is now formatless.\n"; + return 0; + } + return 1; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _ponder_extend { + + # "Go to an extreme, move back to a more comfortable place" + # -- /Oblique Strategies/, Brian Eno and Peter Schmidt + + my($self, $para) = @_; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + + DEBUG > 2 and print "Ogling extensor: =extend $content\n"; + + if($content =~ + m/^ + (\S+) # 1 : new item + \s+ + (\S+) # 2 : fallback(s) + (?:\s+(\S+))? # 3 : element name(s) + \s* + $ + /xs + ) { + my $new_letter = $1; + my $fallbacks_one = $2; + my $elements_one; + $elements_one = defined($3) ? $3 : $1; + + DEBUG > 2 and print "Extensor has good syntax.\n"; + + unless($new_letter =~ m/^[A-Z]$/s or $new_letter) { + DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n"; + $self->whine( + $para->[1]{'start_line'}, + "You can extend only formatting codes A-Z, not like \"$new_letter\"" + ); + return; + } + + if(grep $new_letter eq $_, @Known_formatting_codes) { + DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n"; + $self->whine( + $para->[1]{'start_line'}, + "You can't extend an established code like \"$new_letter\"" + ); + + #TODO: or allow if last bit is same? + + return; + } + + unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc. + or $fallbacks_one eq '0' or $fallbacks_one eq '1' + ) { + $self->whine( + $para->[1]{'start_line'}, + "Format for second =extend parameter must be like" + . " M or 1 or 0 or M,N or M,N,O but you have it like " + . $fallbacks_one + ); + return; + } + + unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc. + $self->whine( + $para->[1]{'start_line'}, + "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like " + . $elements_one + ); + return; + } + + my @fallbacks = split ',', $fallbacks_one, -1; + my @elements = split ',', $elements_one, -1; + + foreach my $f (@fallbacks) { + next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1'; + DEBUG > 2 and print " Can't fall back on unknown code $f\n"; + $self->whine( + $para->[1]{'start_line'}, + "Can't use unknown formatting code '$f' as a fallback for '$new_letter'" + ); + return; + } + + DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n", + @fallbacks, @elements; + + my $canonical_form; + foreach my $e (@elements) { + if(exists $self->{'accept_codes'}{$e}) { + DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n"; + $canonical_form = $e; + last; # first acceptable elementname wins! + } else { + DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n"; + } + } + + + if( defined $canonical_form ) { + # We found a good N => elementname mapping + $self->{'accept_codes'}{$new_letter} = $canonical_form; + DEBUG > 2 and print + "Extensor maps $new_letter => known element $canonical_form.\n"; + } else { + # We have to use the fallback(s), which might be '0', or '1'. + $self->{'accept_codes'}{$new_letter} + = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks; + DEBUG > 2 and print + "Extensor maps $new_letter => fallbacks @fallbacks.\n"; + } + + } else { + DEBUG > 2 and print "Extensor has bad syntax.\n"; + $self->whine( + $para->[1]{'start_line'}, + "Unknown =extend syntax: $content" + ) + } + return; +} + + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub _treat_Zs { # Nix Z<...>'s + my($self,@stack) = @_; + + my($i, $treelet); + my $start_line = $stack[0][1]{'start_line'}; + + # A recursive algorithm implemented iteratively! Whee! + + while($treelet = shift @stack) { + for($i = 2; $i < @$treelet; ++$i) { # iterate over children + next unless ref $treelet->[$i]; # text nodes are uninteresting + unless($treelet->[$i][0] eq 'Z') { + unshift @stack, $treelet->[$i]; # recurse + next; + } + + DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n"; + + # bitch UNLESS it's empty + unless( @{$treelet->[$i]} == 2 + or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') + ) { + $self->whine( $start_line, "A non-empty Z<>" ); + } # but kill it anyway + + splice(@$treelet, $i, 1); # thereby just nix this node. + --$i; + + } + } + + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +# Quoting perlpodspec: + +# In parsing an L<...> code, Pod parsers must distinguish at least four +# attributes: + +############# Not used. Expressed via the element children plus +############# the value of the "content-implicit" flag. +# First: +# The link-text. If there is none, this must be undef. (E.g., in "L<Perl +# Functions|perlfunc>", the link-text is "Perl Functions". In +# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note +# that link text may contain formatting.) +# + +############# The element children +# Second: +# The possibly inferred link-text -- i.e., if there was no real link text, +# then this is the text that we'll infer in its place. (E.g., for +# "L<Getopt::Std>", the inferred link text is "Getopt::Std".) +# + +############# The "to" attribute (which might be text, or a treelet) +# Third: +# The name or URL, or undef if none. (E.g., in "L<Perl +# Functions|perlfunc>", the name -- also sometimes called the page -- is +# "perlfunc". In "L</CAVEATS>", the name is undef.) +# + +############# The "section" attribute (which might be next, or a treelet) +# Fourth: +# The section (AKA "item" in older perlpods), or undef if none. E.g., in +# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this +# is not the same as a manpage section like the "5" in "man 5 crontab". +# "Section Foo" in the Pod sense means the part of the text that's +# introduced by the heading or item whose text is "Foo".) +# +# Pod parsers may also note additional attributes including: +# + +############# The "type" attribute. +# Fifth: +# A flag for whether item 3 (if present) is a URL (like +# "http://lists.perl.org" is), in which case there should be no section +# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or +# possibly a man page name (like "crontab(5)" is). +# + +############# Not implemented, I guess. +# Sixth: +# The raw original L<...> content, before text is split on "|", "/", etc, +# and before E<...> codes are expanded. + + +# For L<...> codes without a "name|" part, only E<...> and Z<> codes may +# occur -- no other formatting codes. That is, authors should not use +# "L<B<Foo::Bar>>". +# +# Note, however, that formatting codes and Z<>'s can occur in any and all +# parts of an L<...> (i.e., in name, section, text, and url). + +sub _treat_Ls { # Process our dear dear friends, the L<...> sequences + + # L<name> + # L<name/"sec"> or L<name/sec> + # L</"sec"> or L</sec> or L<"sec"> + # L<text|name> + # L<text|name/"sec"> or L<text|name/sec> + # L<text|/"sec"> or L<text|/sec> or L<text|"sec"> + # L<scheme:...> + # L<text|scheme:...> + + my($self,@stack) = @_; + + my($i, $treelet); + my $start_line = $stack[0][1]{'start_line'}; + + # A recursive algorithm implemented iteratively! Whee! + + while($treelet = shift @stack) { + for(my $i = 2; $i < @$treelet; ++$i) { + # iterate over children of current tree node + next unless ref $treelet->[$i]; # text nodes are uninteresting + unless($treelet->[$i][0] eq 'L') { + unshift @stack, $treelet->[$i]; # recurse + next; + } + + + # By here, $treelet->[$i] is definitely an L node + my $ell = $treelet->[$i]; + DEBUG > 1 and print "Ogling L node $ell\n"; + + # bitch if it's empty + if( @{$ell} == 2 + or (@{$ell} == 3 and $ell->[2] eq '') + ) { + $self->whine( $start_line, "An empty L<>" ); + $treelet->[$i] = 'L<>'; # just make it a text node + next; # and move on + } + + # Catch URLs: + + # there are a number of possible cases: + # 1) text node containing url: http://foo.com + # -> [ 'http://foo.com' ] + # 2) text node containing url and text: foo|http://foo.com + # -> [ 'foo|http://foo.com' ] + # 3) text node containing url start: mailto:xE<at>foo.com + # -> [ 'mailto:x', [ E ... ], 'foo.com' ] + # 4) text node containing url start and text: foo|mailto:xE<at>foo.com + # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ] + # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com + # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ] + # ... etc. + + # anything before the url is part of the text. + # anything after it is part of the url. + # the url text node itself may contain parts of both. + + if (my ($url_index, $text_part, $url_part) = + # grep is no good here; we want to bail out immediately so that we can + # use $1, $2, etc. without having to do the match twice. + sub { + for (2..$#$ell) { + next if ref $ell->[$_]; + next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s; + return ($_, $1, $2); + } + return; + }->() + ) { + $ell->[1]{'type'} = 'url'; + + my @text = @{$ell}[2..$url_index-1]; + push @text, $text_part if defined $text_part; + + my @url = @{$ell}[$url_index+1..$#$ell]; + unshift @url, $url_part; + + unless (@text) { + $ell->[1]{'content-implicit'} = 'yes'; + @text = @url; + } + + $ell->[1]{to} = Pod::Simple::LinkSection->new( + @url == 1 + ? $url[0] + : [ '', {}, @url ], + ); + + splice @$ell, 2, $#$ell, @text; + + next; + } + + # Catch some very simple and/or common cases + if(@{$ell} == 3 and ! ref $ell->[2]) { + my $it = $ell->[2]; + if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections + # Hopefully neither too broad nor too restrictive a RE + DEBUG > 1 and print "Catching \"$it\" as manpage link.\n"; + $ell->[1]{'type'} = 'man'; + # This's the only place where man links can get made. + $ell->[1]{'content-implicit'} = 'yes'; + $ell->[1]{'to' } = + Pod::Simple::LinkSection->new( $it ); # treelet! + + next; + } + if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) { + # Extremely forgiving idea of what constitutes a bare + # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala> + DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n"; + $ell->[1]{'type'} = 'pod'; + $ell->[1]{'content-implicit'} = 'yes'; + $ell->[1]{'to' } = + Pod::Simple::LinkSection->new( $it ); # treelet! + next; + } + # else fall thru... + } + + + + # ...Uhoh, here's the real L<...> parsing stuff... + # "With the ill behavior, with the ill behavior, with the ill behavior..." + + DEBUG > 1 and print "Running a real parse on this non-trivial L\n"; + + + my $link_text; # set to an arrayref if found + my @ell_content = @$ell; + splice @ell_content,0,2; # Knock off the 'L' and {} bits + + DEBUG > 3 and print " Ell content to start: ", + pretty(@ell_content), "\n"; + + + # Look for the "|" -- only in CHILDREN (not all underlings!) + # Like L<I like the strictness|strict> + DEBUG > 3 and + print " Peering at L content for a '|' ...\n"; + for(my $j = 0; $j < @ell_content; ++$j) { + next if ref $ell_content[$j]; + DEBUG > 3 and + print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n"; + + if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) { + my @link_text = ($1); # might be 0-length + $ell_content[$j] = $2; # might be 0-length + + DEBUG > 3 and + print " FOUND a '|' in it. Splitting into [$1] + [$2]\n"; + + unshift @link_text, splice @ell_content, 0, $j; + # leaving only things at J and after + @ell_content = grep ref($_)||length($_), @ell_content ; + $link_text = [grep ref($_)||length($_), @link_text ]; + DEBUG > 3 and printf + " So link text is %s\n and remaining ell content is %s\n", + pretty($link_text), pretty(@ell_content); + last; + } + } + + + # Now look for the "/" -- only in CHILDREN (not all underlings!) + # And afterward, anything left in @ell_content will be the raw name + # Like L<Foo::Bar/Object Methods> + my $section_name; # set to arrayref if found + DEBUG > 3 and print " Peering at L-content for a '/' ...\n"; + for(my $j = 0; $j < @ell_content; ++$j) { + next if ref $ell_content[$j]; + DEBUG > 3 and + print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n"; + + if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) { + my @section_name = ($2); # might be 0-length + $ell_content[$j] = $1; # might be 0-length + + DEBUG > 3 and + print " FOUND a '/' in it.", + " Splitting to page [...$1] + section [$2...]\n"; + + push @section_name, splice @ell_content, 1+$j; + # leaving only things before and including J + + @ell_content = grep ref($_)||length($_), @ell_content ; + @section_name = grep ref($_)||length($_), @section_name ; + + # Turn L<.../"foo"> into L<.../foo> + if(@section_name + and !ref($section_name[0]) and !ref($section_name[-1]) + and $section_name[ 0] =~ m/^\"/s + and $section_name[-1] =~ m/\"$/s + and !( # catch weird degenerate case of L<"> ! + @section_name == 1 and $section_name[0] eq '"' + ) + ) { + $section_name[ 0] =~ s/^\"//s; + $section_name[-1] =~ s/\"$//s; + DEBUG > 3 and + print " Quotes removed: ", pretty(@section_name), "\n"; + } else { + DEBUG > 3 and + print " No need to remove quotes in ", pretty(@section_name), "\n"; + } + + $section_name = \@section_name; + last; + } + } + + # Turn L<"Foo Bar"> into L</Foo Bar> + if(!$section_name and @ell_content + and !ref($ell_content[0]) and !ref($ell_content[-1]) + and $ell_content[ 0] =~ m/^\"/s + and $ell_content[-1] =~ m/\"$/s + and !( # catch weird degenerate case of L<"> ! + @ell_content == 1 and $ell_content[0] eq '"' + ) + ) { + $section_name = [splice @ell_content]; + $section_name->[ 0] =~ s/^\"//s; + $section_name->[-1] =~ s/\"$//s; + } + + # Turn L<Foo Bar> into L</Foo Bar>. + if(!$section_name and !$link_text and @ell_content + and grep !ref($_) && m/ /s, @ell_content + ) { + $section_name = [splice @ell_content]; + # That's support for the now-deprecated syntax. + # (Maybe generate a warning eventually?) + # Note that it deliberately won't work on L<...|Foo Bar> + } + + + # Now make up the link_text + # L<Foo> -> L<Foo|Foo> + # L</Bar> -> L<"Bar"|Bar> + # L<Foo/Bar> -> L<"Bar" in Foo/Foo> + unless($link_text) { + $ell->[1]{'content-implicit'} = 'yes'; + $link_text = []; + push @$link_text, '"', @$section_name, '"' if $section_name; + + if(@ell_content) { + $link_text->[-1] .= ' in ' if $section_name; + push @$link_text, @ell_content; + } + } + + + # And the E resolver will have to deal with all our treeletty things: + + if(@ell_content == 1 and !ref($ell_content[0]) + and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s + ) { + $ell->[1]{'type'} = 'man'; + DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n"; + } else { + $ell->[1]{'type'} = 'pod'; + DEBUG > 3 and print "Considering this a pod link (not man or url).\n"; + } + + if( defined $section_name ) { + $ell->[1]{'section'} = Pod::Simple::LinkSection->new( + ['', {}, @$section_name] + ); + DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n"; + } + + if( @ell_content ) { + $ell->[1]{'to'} = Pod::Simple::LinkSection->new( + ['', {}, @ell_content] + ); + DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n"; + } + + # And update children to be the link-text: + @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : ''); + + DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n"; + + unshift @stack, $treelet->[$i]; # might as well recurse + } + } + + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _treat_Es { + my($self,@stack) = @_; + + my($i, $treelet, $content, $replacer, $charnum); + my $start_line = $stack[0][1]{'start_line'}; + + # A recursive algorithm implemented iteratively! Whee! + + + # Has frightening side effects on L nodes' attributes. + + #my @ells_to_tweak; + + while($treelet = shift @stack) { + for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children + next unless ref $treelet->[$i]; # text nodes are uninteresting + if($treelet->[$i][0] eq 'L') { + # SPECIAL STUFF for semi-processed L<>'s + + my $thing; + foreach my $attrname ('section', 'to') { + if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { + unshift @stack, $thing; + DEBUG > 2 and print " Enqueuing ", + pretty( $treelet->[$i][1]{$attrname} ), + " as an attribute value to tweak.\n"; + } + } + + unshift @stack, $treelet->[$i]; # recurse + next; + } elsif($treelet->[$i][0] ne 'E') { + unshift @stack, $treelet->[$i]; # recurse + next; + } + + DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n"; + + # bitch if it's empty + if( @{$treelet->[$i]} == 2 + or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') + ) { + $self->whine( $start_line, "An empty E<>" ); + $treelet->[$i] = 'E<>'; # splice in a literal + next; + } + + # bitch if content is weird + unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) { + $self->whine( $start_line, "An E<...> surrounding strange content" ); + $replacer = $treelet->[$i]; # scratch + splice(@$treelet, $i, 1, # fake out a literal + 'E<', + splice(@$replacer,2), # promote its content + '>' + ); + # Don't need to do --$i, as the 'E<' we just added isn't interesting. + next; + } + + DEBUG > 1 and print "Ogling E<$content>\n"; + + $charnum = Pod::Escapes::e2charnum($content); + DEBUG > 1 and print " Considering E<$content> with char ", + defined($charnum) ? $charnum : "undef", ".\n"; + + if(!defined( $charnum )) { + DEBUG > 1 and print "I don't know how to deal with E<$content>.\n"; + $self->whine( $start_line, "Unknown E content in E<$content>" ); + $replacer = "E<$content>"; # better than nothing + } elsif($charnum >= 255 and !UNICODE) { + $replacer = ASCII ? "\xA4" : "?"; + DEBUG > 1 and print "This Perl version can't handle ", + "E<$content> (chr $charnum), so replacing with $replacer\n"; + } else { + $replacer = Pod::Escapes::e2char($content); + DEBUG > 1 and print " Replacing E<$content> with $replacer\n"; + } + + splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho + } + } + + return; +} + + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _treat_Ss { + my($self,$treelet) = @_; + + _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'}; + + # TODO: or a change_nbsp_to_S + # Normalizing nbsp's to S is harder: for each text node, make S content + # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/ + + + return; +} + + +sub _change_S_to_nbsp { # a recursive function + # Sanely assumes that the top node in the excursion won't be an S node. + my($treelet, $in_s) = @_; + + my $is_s = ('S' eq $treelet->[0]); + $in_s ||= $is_s; # So in_s is on either by this being an S element, + # or by an ancestor being an S element. + + for(my $i = 2; $i < @$treelet; ++$i) { + if(ref $treelet->[$i]) { + if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) { + my $to_pull_up = $treelet->[$i]; + splice @$to_pull_up,0,2; # ...leaving just its content + splice @$treelet, $i, 1, @$to_pull_up; # Pull up content + $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff + } + } else { + $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s; + # (If not in ASCIIland, we can't assume that \xA0 == nbsp.) + + # Note that if you apply nbsp_for_S to text, and so turn + # "foo S<bar baz> quux" into "foo bar faz quux", you + # end up with something that fails to say "and don't hyphenate + # any part of 'bar baz'". However, hyphenation is such a vexing + # problem anyway, that most Pod renderers just don't render it + # at all. But if you do want to implement hyphenation, I guess + # that you'd better have nbsp_for_S off. + } + } + + return $is_s; +} + +#----------------------------------------------------------------------------- + +sub _accessorize { # A simple-minded method-maker + no strict 'refs'; + foreach my $attrname (@_) { + next if $attrname =~ m/::/; # a hack + *{caller() . '::' . $attrname} = sub { + use strict; + $Carp::CarpLevel = 1, Carp::croak( + "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" + ) unless (@_ == 1 or @_ == 2) and ref $_[0]; + (@_ == 1) ? $_[0]->{$attrname} + : ($_[0]->{$attrname} = $_[1]); + }; + } + # Ya know, they say accessories make the ensemble! + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +#============================================================================= + +sub filter { + my($class, $source) = @_; + my $new = $class->new; + $new->output_fh(*STDOUT{IO}); + + if(ref($source || '') eq 'SCALAR') { + $new->parse_string_document( $$source ); + } elsif(ref($source)) { # it's a file handle + $new->parse_file($source); + } else { # it's a filename + $new->parse_file($source); + } + + return $new; +} + + +#----------------------------------------------------------------------------- + +sub _out { + # For use in testing: Class->_out($source) + # returns the transformation of $source + + my $class = shift(@_); + + my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; + + DEBUG and print "\n\n", '#' x 76, + "\nAbout to parse source: {{\n$_[0]\n}}\n\n"; + + + my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new; + $parser->hide_line_numbers(1); + + my $out = ''; + $parser->output_string( \$out ); + DEBUG and print " _out to ", \$out, "\n"; + + $mutor->($parser) if $mutor; + + $parser->parse_string_document( $_[0] ); + # use Data::Dumper; print Dumper($parser), "\n"; + return $out; +} + + +sub _duo { + # For use in testing: Class->_duo($source1, $source2) + # returns the parse trees of $source1 and $source2. + # Good in things like: &ok( Class->duo(... , ...) ); + + my $class = shift(@_); + + Carp::croak "But $class->_duo is useful only in list context!" + unless wantarray; + + my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; + + Carp::croak "But $class->_duo takes two parameters, not: @_" + unless @_ == 2; + + my(@out); + + while( @_ ) { + my $parser = $class->new; + + push @out, ''; + $parser->output_string( \( $out[-1] ) ); + + DEBUG and print " _duo out to ", $parser->output_string(), + " = $parser->{'output_string'}\n"; + + $parser->hide_line_numbers(1); + $mutor->($parser) if $mutor; + $parser->parse_string_document( shift( @_ ) ); + # use Data::Dumper; print Dumper($parser), "\n"; + } + + return @out; +} + + + +#----------------------------------------------------------------------------- +1; +__END__ + +TODO: +A start_formatting_code and end_formatting_code methods, which in the +base class call start_L, end_L, start_C, end_C, etc., if they are +defined. + +have the POD FORMATTING ERRORS section note the localtime, and the +version of Pod::Simple. + +option to delete all E<shy>s? +option to scream if under-0x20 literals are found in the input, or +under-E<32> E codes are found in the tree. And ditto \x7f-\x9f + +Option to turn highbit characters into their compromised form? (applies +to E parsing too) + +TODO: BOM/encoding things. + +TODO: ascii-compat things in the XML classes? + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pod b/Master/tlpkg/tlperl/lib/Pod/Simple.pod new file mode 100644 index 00000000000..d3f168d7e0a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple.pod @@ -0,0 +1,274 @@ + +=head1 NAME + +Pod::Simple - framework for parsing Pod + +=head1 SYNOPSIS + + TODO + +=head1 DESCRIPTION + +Pod::Simple is a Perl library for parsing text in the Pod ("plain old +documentation") markup language that is typically used for writing +documentation for Perl and for Perl modules. The Pod format is explained +L<perlpod>; the most common formatter is called C<perldoc>. + +Pod formatters can use Pod::Simple to parse Pod documents and render them into +plain text, HTML, or any number of other formats. Typically, such formatters +will be subclasses of Pod::Simple, and so they will inherit its methods, like +C<parse_file>. + +If you're reading this document just because you have a Pod-processing +subclass that you want to use, this document (plus the documentation for the +subclass) is probably all you need to read. + +If you're reading this document because you want to write a formatter +subclass, continue reading it and then read L<Pod::Simple::Subclassing>, and +then possibly even read L<perlpodspec> (some of which is for parser-writers, +but much of which is notes to formatter-writers). + +=head1 MAIN METHODS + +=over + +=item C<< $parser = I<SomeClass>->new(); >> + +This returns a new parser object, where I<C<SomeClass>> is a subclass +of Pod::Simple. + +=item C<< $parser->output_fh( *OUT ); >> + +This sets the filehandle that C<$parser>'s output will be written to. +You can pass C<*STDOUT>, otherwise you should probably do something +like this: + + my $outfile = "output.txt"; + open TXTOUT, ">$outfile" or die "Can't write to $outfile: $!"; + $parser->output_fh(*TXTOUT); + +...before you call one of the C<< $parser->parse_I<whatever> >> methods. + +=item C<< $parser->output_string( \$somestring ); >> + +This sets the string that C<$parser>'s output will be sent to, +instead of any filehandle. + + +=item C<< $parser->parse_file( I<$some_filename> ); >> + +=item C<< $parser->parse_file( *INPUT_FH ); >> + +This reads the Pod content of the file (or filehandle) that you specify, +and processes it with that C<$parser> object, according to however +C<$parser>'s class works, and according to whatever parser options you +have set up for this C<$parser> object. + +=item C<< $parser->parse_string_document( I<$all_content> ); >> + +This works just like C<parse_file> except that it reads the Pod +content not from a file, but from a string that you have already +in memory. + +=item C<< $parser->parse_lines( I<...@lines...>, undef ); >> + +This processes the lines in C<@lines> (where each list item must be a +defined value, and must contain exactly one line of content -- so no +items like C<"foo\nbar"> are allowed). The final C<undef> is used to +indicate the end of document being parsed. + +The other C<parser_I<whatever>> methods are meant to be called only once +per C<$parser> object; but C<parse_lines> can be called as many times per +C<$parser> object as you want, as long as the last call (and only +the last call) ends with an C<undef> value. + + +=item C<< $parser->content_seen >> + +This returns true only if there has been any real content seen +for this document. + + +=item C<< I<SomeClass>->filter( I<$filename> ); >> + +=item C<< I<SomeClass>->filter( I<*INPUT_FH> ); >> + +=item C<< I<SomeClass>->filter( I<\$document_content> ); >> + +This is a shortcut method for creating a new parser object, setting the +output handle to STDOUT, and then processing the specified file (or +filehandle, or in-memory document). This is handy for one-liners like +this: + + perl -MPod::Simple::Text -e "Pod::Simple::Text->filter('thingy.pod')" + +=back + + + +=head1 SECONDARY METHODS + +Some of these methods might be of interest to general users, as +well as of interest to formatter-writers. + +Note that the general pattern here is that the accessor-methods +read the attribute's value with C<< $value = $parser->I<attribute> >> +and set the attribute's value with +C<< $parser->I<attribute>(I<newvalue>) >>. For each accessor, I typically +only mention one syntax or another, based on which I think you are actually +most likely to use. + + +=over + +=item C<< $parser->no_whining( I<SOMEVALUE> ) >> + +If you set this attribute to a true value, you will suppress the +parser's complaints about irregularities in the Pod coding. By default, +this attribute's value is false, meaning that irregularities will +be reported. + +Note that turning this attribute to true won't suppress one or two kinds +of complaints about rarely occurring unrecoverable errors. + + +=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >> + +If you set this attribute to a true value, you will stop the parser from +generating a "POD ERRORS" section at the end of the document. By +default, this attribute's value is false, meaning that an errata section +will be generated, as necessary. + + +=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >> + +If you set this attribute to a true value, it will send reports of +parsing errors to STDERR. By default, this attribute's value is false, +meaning that no output is sent to STDERR. + +Setting C<complain_stderr> also sets C<no_errata_section>. + + +=item C<< $parser->source_filename >> + +This returns the filename that this parser object was set to read from. + + +=item C<< $parser->doc_has_started >> + +This returns true if C<$parser> has read from a source, and has seen +Pod content in it. + + +=item C<< $parser->source_dead >> + +This returns true if C<$parser> has read from a source, and come to the +end of that source. + +=item C<< $parser->strip_verbatim_indent( I<SOMEVALUE> ) >> + +The perlpod spec for a Verbatim paragraph is "It should be reproduced +exactly...", which means that the whitespace you've used to indent your +verbatim blocks will be preserved in the output. This can be annoying for +outputs such as HTML, where that whitespace will remain in front of every +line. It's an unfortunate case where syntax is turned into semantics. + +If the POD your parsing adheres to a consistent indentation policy, you can +have such indentation stripped from the beginning of every line of your +verbatim blocks. This method tells Pod::Simple what to strip. For two-space +indents, you'd use: + + $parser->strip_verbatim_indent(' '); + +For tab indents, you'd use a tab character: + + $parser->strip_verbatim_indent("\t"); + +If the POD is inconsistent about the indentation of verbatim blocks, but you +have figured out a heuristic to determine how much a particular verbatim block +is indented, you can pass a code reference instead. The code reference will be +executed with one argument, an array reference of all the lines in the +verbatim block, and should return the value to be stripped from each line. For +example, if you decide that you're fine to use the first line of the verbatim +block to set the standard for indentation of the rest of the block, you can +look at the first line and return the appropriate value, like so: + + $new->strip_verbatim_indent(sub { + my $lines = shift; + (my $indent = $lines->[0]) =~ s/\S.*//; + return $indent; + }); + +If you'd rather treat each line individually, you can do that, too, by just +transforming them in-place in the code reference and returning C<undef>. Say +that you don't want I<any> lines indented. You can do something like this: + + $new->strip_verbatim_indent(sub { + my $lines = shift; + sub { s/^\s+// for @{ $lines }, + return undef; + }); + +=back + +=head1 CAVEATS + +This is just a beta release -- there are a good number of things still +left to do. Notably, support for EBCDIC platforms is still half-done, +an untested. + + +=head1 SEE ALSO + +L<Pod::Simple::Subclassing> + +L<perlpod|perlpod> + +L<perlpodspec|perlpodspec> + +L<Pod::Escapes|Pod::Escapes> + +L<perldoc> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm new file mode 100644 index 00000000000..9917898cff7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm @@ -0,0 +1,1930 @@ + +package Pod::Simple::BlackBox; +# +# "What's in the box?" "Pain." +# +########################################################################### +# +# This is where all the scary things happen: parsing lines into +# paragraphs; and then into directives, verbatims, and then also +# turning formatting sequences into treelets. +# +# Are you really sure you want to read this code? +# +#----------------------------------------------------------------------------- +# +# The basic work of this module Pod::Simple::BlackBox is doing the dirty work +# of parsing Pod into treelets (generally one per non-verbatim paragraph), and +# to call the proper callbacks on the treelets. +# +# Every node in a treelet is a ['name', {attrhash}, ...children...] + +use integer; # vroom! +use strict; +use Carp (); +use vars qw($VERSION ); +$VERSION = '3.14'; +#use constant DEBUG => 7; +BEGIN { + require Pod::Simple; + *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub parse_line { shift->parse_lines(@_) } # alias + +# - - - Turn back now! Run away! - - - + +sub parse_lines { # Usage: $parser->parse_lines(@lines) + # an undef means end-of-stream + my $self = shift; + + my $code_handler = $self->{'code_handler'}; + my $cut_handler = $self->{'cut_handler'}; + $self->{'line_count'} ||= 0; + + my $scratch; + + DEBUG > 4 and + print "# Parsing starting at line ", $self->{'line_count'}, ".\n"; + + DEBUG > 5 and + print "# About to parse lines: ", + join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n"; + + my $paras = ($self->{'paras'} ||= []); + # paragraph buffer. Because we need to defer processing of =over + # directives and verbatim paragraphs. We call _ponder_paragraph_buffer + # to process this. + + $self->{'pod_para_count'} ||= 0; + + my $line; + foreach my $source_line (@_) { + if( $self->{'source_dead'} ) { + DEBUG > 4 and print "# Source is dead.\n"; + last; + } + + unless( defined $source_line ) { + DEBUG > 4 and print "# Undef-line seen.\n"; + + push @$paras, ['~end', {'start_line' => $self->{'line_count'}}]; + push @$paras, $paras->[-1], $paras->[-1]; + # So that it definitely fills the buffer. + $self->{'source_dead'} = 1; + $self->_ponder_paragraph_buffer; + next; + } + + + if( $self->{'line_count'}++ ) { + ($line = $source_line) =~ tr/\n\r//d; + # If we don't have two vars, we'll end up with that there + # tr/// modding the (potentially read-only) original source line! + + } else { + DEBUG > 2 and print "First line: [$source_line]\n"; + + if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) { + DEBUG and print "UTF-8 BOM seen. Faking a '=encode utf8'.\n"; + $self->_handle_encoding_line( "=encode utf8" ); + $line =~ tr/\n\r//d; + + } elsif( $line =~ s/^\xFE\xFF//s ) { + DEBUG and print "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; + $self->scream( + $self->{'line_count'}, + "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." + ); + splice @_; + push @_, undef; + next; + + # TODO: implement somehow? + + } elsif( $line =~ s/^\xFF\xFE//s ) { + DEBUG and print "Little-endian UTF-16 BOM seen. Aborting parsing.\n"; + $self->scream( + $self->{'line_count'}, + "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." + ); + splice @_; + push @_, undef; + next; + + # TODO: implement somehow? + + } else { + DEBUG > 2 and print "First line is BOM-less.\n"; + ($line = $source_line) =~ tr/\n\r//d; + } + } + + + DEBUG > 5 and print "# Parsing line: [$line]\n"; + + if(!$self->{'in_pod'}) { + if($line =~ m/^=([a-zA-Z]+)/s) { + if($1 eq 'cut') { + $self->scream( + $self->{'line_count'}, + "=cut found outside a pod block. Skipping to next block." + ); + + ## Before there were errata sections in the world, it was + ## least-pessimal to abort processing the file. But now we can + ## just barrel on thru (but still not start a pod block). + #splice @_; + #push @_, undef; + + next; + } else { + $self->{'in_pod'} = $self->{'start_of_pod_block'} + = $self->{'last_was_blank'} = 1; + # And fall thru to the pod-mode block further down + } + } else { + DEBUG > 5 and print "# It's a code-line.\n"; + $code_handler->(map $_, $line, $self->{'line_count'}, $self) + if $code_handler; + # Note: this may cause code to be processed out of order relative + # to pods, but in order relative to cuts. + + # Note also that we haven't yet applied the transcoding to $line + # by time we call $code_handler! + + if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) { + # That RE is from perlsyn, section "Plain Old Comments (Not!)", + #$fname = $2 if defined $2; + #DEBUG > 1 and defined $2 and print "# Setting fname to \"$fname\"\n"; + DEBUG > 1 and print "# Setting nextline to $1\n"; + $self->{'line_count'} = $1 - 1; + } + + next; + } + } + + # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + # Else we're in pod mode: + + # Apply any necessary transcoding: + $self->{'_transcoder'} && $self->{'_transcoder'}->($line); + + # HERE WE CATCH =encoding EARLY! + if( $line =~ m/^=encoding\s+\S+\s*$/s ) { + $line = $self->_handle_encoding_line( $line ); + } + + if($line =~ m/^=cut/s) { + # here ends the pod block, and therefore the previous pod para + DEBUG > 1 and print "Noting =cut at line ${$self}{'line_count'}\n"; + $self->{'in_pod'} = 0; + # ++$self->{'pod_para_count'}; + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + $cut_handler->(map $_, $line, $self->{'line_count'}, $self) + if $cut_handler; + + # TODO: add to docs: Note: this may cause cuts to be processed out + # of order relative to pods, but in order relative to code. + + } elsif($line =~ m/^\s*$/s) { # it's a blank line + if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { + DEBUG > 1 and print "Saving blank line at line ${$self}{'line_count'}\n"; + push @{$paras->[-1]}, $line; + } # otherwise it's not interesting + + if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) { + DEBUG > 1 and print "Noting para ends with blank line at ${$self}{'line_count'}\n"; + } + + $self->{'last_was_blank'} = 1; + + } elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para... + + if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) { + # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS + my $new = [$1, {'start_line' => $self->{'line_count'}}, $2]; + # Note that in "=head1 foo", the WS is lost. + # Example: ['=head1', {'start_line' => 123}, ' foo'] + + ++$self->{'pod_para_count'}; + + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + + push @$paras, $new; # the new incipient paragraph + DEBUG > 1 and print "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n"; + + } elsif($line =~ m/^\s/s) { + + if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { + DEBUG > 1 and print "Resuming verbatim para at line ${$self}{'line_count'}\n"; + push @{$paras->[-1]}, $line; + } else { + ++$self->{'pod_para_count'}; + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + DEBUG > 1 and print "Starting verbatim para at line ${$self}{'line_count'}\n"; + push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line]; + } + } else { + ++$self->{'pod_para_count'}; + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + push @$paras, ['~Para', {'start_line' => $self->{'line_count'}}, $line]; + DEBUG > 1 and print "Starting plain para at line ${$self}{'line_count'}\n"; + } + $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; + + } else { + # It's a non-blank line /continuing/ the current para + if(@$paras) { + DEBUG > 2 and print "Line ${$self}{'line_count'} continues current paragraph\n"; + push @{$paras->[-1]}, $line; + } else { + # Unexpected case! + die "Continuing a paragraph but \@\$paras is empty?"; + } + $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; + } + + } # ends the big while loop + + DEBUG > 1 and print(pretty(@$paras), "\n"); + return $self; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_encoding_line { + my($self, $line) = @_; + + # The point of this routine is to set $self->{'_transcoder'} as indicated. + + return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s; + DEBUG > 1 and print "Found an encoding line \"=encoding $1\"\n"; + + my $e = $1; + my $orig = $e; + push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig"; + + my $enc_error; + + # Cf. perldoc Encode and perldoc Encode::Supported + + require Pod::Simple::Transcode; + + if( $self->{'encoding'} ) { + my $norm_current = $self->{'encoding'}; + my $norm_e = $e; + foreach my $that ($norm_current, $norm_e) { + $that = lc($that); + $that =~ s/[-_]//g; + } + if($norm_current eq $norm_e) { + DEBUG > 1 and print "The '=encoding $orig' line is ", + "redundant. ($norm_current eq $norm_e). Ignoring.\n"; + $enc_error = ''; + # But that doesn't necessarily mean that the earlier one went okay + } else { + $enc_error = "Encoding is already set to " . $self->{'encoding'}; + DEBUG > 1 and print $enc_error; + } + } elsif ( + # OK, let's turn on the encoding + do { + DEBUG > 1 and print " Setting encoding to $e\n"; + $self->{'encoding'} = $e; + 1; + } + and $e eq 'HACKRAW' + ) { + DEBUG and print " Putting in HACKRAW (no-op) encoding mode.\n"; + + } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) { + + die($enc_error = "WHAT? _transcoder is already set?!") + if $self->{'_transcoder'}; # should never happen + require Pod::Simple::Transcode; + $self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e); + eval { + my @x = ('', "abc", "123"); + $self->{'_transcoder'}->(@x); + }; + $@ && die( $enc_error = + "Really unexpected error setting up encoding $e: $@\nAborting" + ); + + } else { + my @supported = Pod::Simple::Transcode::->all_encodings; + + # Note unsupported, and complain + DEBUG and print " Encoding [$e] is unsupported.", + "\nSupporteds: @supported\n"; + my $suggestion = ''; + + # Look for a near match: + my $norm = lc($e); + $norm =~ tr[-_][]d; + my $n; + foreach my $enc (@supported) { + $n = lc($enc); + $n =~ tr[-_][]d; + next unless $n eq $norm; + $suggestion = " (Maybe \"$e\" should be \"$enc\"?)"; + last; + } + my $encmodver = Pod::Simple::Transcode::->encmodver; + $enc_error = join '' => + "This document probably does not appear as it should, because its ", + "\"=encoding $e\" line calls for an unsupported encoding.", + $suggestion, " [$encmodver\'s supported encodings are: @supported]" + ; + + $self->scream( $self->{'line_count'}, $enc_error ); + } + push @{ $self->{'encoding_command_statuses'} }, $enc_error; + + return '=encoding ALREADYDONE'; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _handle_encoding_second_level { + # By time this is called, the encoding (if well formed) will already + # have been acted one. + my($self, $para) = @_; + my @x = @$para; + my $content = join ' ', splice @x, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + + DEBUG > 2 and print "Ogling encoding directive: =encoding $content\n"; + + if($content eq 'ALREADYDONE') { + # It's already been handled. Check for errors. + if(! $self->{'encoding_command_statuses'} ) { + DEBUG > 2 and print " CRAZY ERROR: It wasn't really handled?!\n"; + } elsif( $self->{'encoding_command_statuses'}[-1] ) { + $self->whine( $para->[1]{'start_line'}, + sprintf "Couldn't do %s: %s", + $self->{'encoding_command_reqs' }[-1], + $self->{'encoding_command_statuses'}[-1], + ); + } else { + DEBUG > 2 and print " (Yup, it was successfully handled already.)\n"; + } + + } else { + # Otherwise it's a syntax error + $self->whine( $para->[1]{'start_line'}, + "Invalid =encoding syntax: $content" + ); + } + + return; +} + +#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~` + +{ +my $m = -321; # magic line number + +sub _gen_errata { + my $self = $_[0]; + # Return 0 or more fake-o paragraphs explaining the accumulated + # errors on this document. + + return() unless $self->{'errata'} and keys %{$self->{'errata'}}; + + my @out; + + foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) { + push @out, + ['=item', {'start_line' => $m}, "Around line $line:"], + map( ['~Para', {'start_line' => $m, '~cooked' => 1}, + #['~Top', {'start_line' => $m}, + $_ + #] + ], + @{$self->{'errata'}{$line}} + ) + ; + } + + # TODO: report of unknown entities? unrenderable characters? + + unshift @out, + ['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'], + ['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1}, + "Hey! ", + ['B', {}, + 'The above document had some coding errors, which are explained below:' + ] + ], + ['=over', {'start_line' => $m, 'errata' => 1}, ''], + ; + + push @out, + ['=back', {'start_line' => $m, 'errata' => 1}, ''], + ; + + DEBUG and print "\n<<\n", pretty(\@out), "\n>>\n\n"; + + return @out; +} + +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +############################################################################## +## +## stop reading now stop reading now stop reading now stop reading now stop +## +## HERE IT BECOMES REALLY SCARY +## +## stop reading now stop reading now stop reading now stop reading now stop +## +############################################################################## + +sub _ponder_paragraph_buffer { + + # Para-token types as found in the buffer. + # ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end, + # =over, =back, =item + # and the null =pod (to be complained about if over one line) + # + # "~data" paragraphs are something we generate at this level, depending on + # a currently open =over region + + # Events fired: Begin and end for: + # directivename (like head1 .. head4), item, extend, + # for (from =begin...=end, =for), + # over-bullet, over-number, over-text, over-block, + # item-bullet, item-number, item-text, + # Document, + # Data, Para, Verbatim + # B, C, longdirname (TODO -- wha?), etc. for all directives + # + + my $self = $_[0]; + my $paras; + return unless @{$paras = $self->{'paras'}}; + my $curr_open = ($self->{'curr_open'} ||= []); + + my $scratch; + + DEBUG > 10 and print "# Paragraph buffer: <<", pretty($paras), ">>\n"; + + # We have something in our buffer. So apparently the document has started. + unless($self->{'doc_has_started'}) { + $self->{'doc_has_started'} = 1; + + my $starting_contentless; + $starting_contentless = + ( + !@$curr_open + and @$paras and ! grep $_->[0] ne '~end', @$paras + # i.e., if the paras is all ~ends + ) + ; + DEBUG and print "# Starting ", + $starting_contentless ? 'contentless' : 'contentful', + " document\n" + ; + + $self->_handle_element_start( + ($scratch = 'Document'), + { + 'start_line' => $paras->[0][1]{'start_line'}, + $starting_contentless ? ( 'contentless' => 1 ) : (), + }, + ); + } + + my($para, $para_type); + while(@$paras) { + last if @$paras == 1 and + ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim' + or $paras->[0][0] eq '=item' ) + ; + # Those're the three kinds of paragraphs that require lookahead. + # Actually, an "=item Foo" inside an <over type=text> region + # and any =item inside an <over type=block> region (rare) + # don't require any lookahead, but all others (bullets + # and numbers) do. + +# TODO: winge about many kinds of directives in non-resolving =for regions? +# TODO: many? like what? =head1 etc? + + $para = shift @$paras; + $para_type = $para->[0]; + + DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (", + $self->_dump_curr_open(), ")\n"; + + if($para_type eq '=for') { + next if $self->_ponder_for($para,$curr_open,$paras); + + } elsif($para_type eq '=begin') { + next if $self->_ponder_begin($para,$curr_open,$paras); + + } elsif($para_type eq '=end') { + next if $self->_ponder_end($para,$curr_open,$paras); + + } elsif($para_type eq '~end') { # The virtual end-document signal + next if $self->_ponder_doc_end($para,$curr_open,$paras); + } + + + # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + if(grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and + print "Skipping $para_type paragraph because in ignore mode.\n"; + next; + } + #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + + if($para_type eq '=pod') { + $self->_ponder_pod($para,$curr_open,$paras); + + } elsif($para_type eq '=over') { + next if $self->_ponder_over($para,$curr_open,$paras); + + } elsif($para_type eq '=back') { + next if $self->_ponder_back($para,$curr_open,$paras); + + } else { + + # All non-magical codes!!! + + # Here we start using $para_type for our own twisted purposes, to + # mean how it should get treated, not as what the element name + # should be. + + DEBUG > 1 and print "Pondering non-magical $para_type\n"; + + my $i; + + # Enforce some =headN discipline + if($para_type =~ m/^=head\d$/s + and ! $self->{'accept_heads_anywhere'} + and @$curr_open + and $curr_open->[-1][0] eq '=over' + ) { + DEBUG > 2 and print "'=$para_type' inside an '=over'!\n"; + $self->whine( + $para->[1]{'start_line'}, + "You forgot a '=back' before '$para_type'" + ); + unshift @$paras, ['=back', {}, ''], $para; # close the =over + next; + } + + + if($para_type eq '=item') { + + my $over; + unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') { + $self->whine( + $para->[1]{'start_line'}, + "'=item' outside of any '=over'" + ); + unshift @$paras, + ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], + $para + ; + next; + } + + + my $over_type = $over->[1]{'~type'}; + + if(!$over_type) { + # Shouldn't happen1 + die "Typeless over in stack, starting at line " + . $over->[1]{'start_line'}; + + } elsif($over_type eq 'block') { + unless($curr_open->[-1][1]{'~bitched_about'}) { + $curr_open->[-1][1]{'~bitched_about'} = 1; + $self->whine( + $curr_open->[-1][1]{'start_line'}, + "You can't have =items (as at line " + . $para->[1]{'start_line'} + . ") unless the first thing after the =over is an =item" + ); + } + # Just turn it into a paragraph and reconsider it + $para->[0] = '~Para'; + unshift @$paras, $para; + next; + + } elsif($over_type eq 'text') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'text') { + # Nothing special needs doing for 'text' + } elsif($item_type eq 'number' or $item_type eq 'bullet') { + die "Unknown item type $item_type" + unless $item_type eq 'number' or $item_type eq 'bullet'; + # Undo our clobbering: + push @$para, $para->[1]{'~orig_content'}; + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + # =item-text thingies don't need any assimilation, it seems. + + } elsif($over_type eq 'number') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; + + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; + + if($item_type eq 'bullet') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + push @$para, $para->[1]{'~orig_content'}; + # restore the bullet, blocking the assimilation of next para + + } elsif($item_type eq 'text') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + # Text content will still be there and will block next ~Para + + } elsif($item_type ne 'number') { + die "Unknown item type $item_type"; # should never happen + + } elsif($expected_value == $para->[1]{'number'}) { + DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n"; + + } else { + DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, + " instead of the expected value of $expected_value\n"; + $self->whine( + $para->[1]{'start_line'}, + "You have '=item " . $para->[1]{'number'} . + "' instead of the expected '=item $expected_value'" + ); + $para->[1]{'number'} = $expected_value; # correcting!! + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + + } elsif($over_type eq 'bullet') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'bullet') { + # as expected! + + if( $para->[1]{'~_freaky_para_hack'} ) { + DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; + push @$para, delete $para->[1]{'~_freaky_para_hack'}; + } + + } elsif($item_type eq 'number') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + push @$para, $para->[1]{'~orig_content'}; + # and block assimilation of the next paragraph + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } elsif($item_type eq 'text') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + # But doesn't need processing. But it'll block assimilation + # of the next para. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + } else { + die "Unhandled =over type \"$over_type\"?"; + # Shouldn't happen! + } + + $para_type = 'Plain'; + $para->[0] .= '-' . $over_type; + # Whew. Now fall thru and process it. + + + } elsif($para_type eq '=extend') { + # Well, might as well implement it here. + $self->_ponder_extend($para); + next; # and skip + } elsif($para_type eq '=encoding') { + # Not actually acted on here, but we catch errors here. + $self->_handle_encoding_second_level($para); + + next; # and skip + } elsif($para_type eq '~Verbatim') { + $para->[0] = 'Verbatim'; + $para_type = '?Verbatim'; + } elsif($para_type eq '~Para') { + $para->[0] = 'Para'; + $para_type = '?Plain'; + } elsif($para_type eq 'Data') { + $para->[0] = 'Data'; + $para_type = '?Data'; + } elsif( $para_type =~ s/^=//s + and defined( $para_type = $self->{'accept_directives'}{$para_type} ) + ) { + DEBUG > 1 and print " Pondering known directive ${$para}[0] as $para_type\n"; + } else { + # An unknown directive! + DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n", + $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} ) + ; + $self->whine( + $para->[1]{'start_line'}, + "Unknown directive: $para->[0]" + ); + + # And maybe treat it as text instead of just letting it go? + next; + } + + if($para_type =~ s/^\?//s) { + if(! @$curr_open) { # usual case + DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n"; + } else { + my @fors = grep $_->[0] eq '=for', @$curr_open; + DEBUG > 1 and print "Containing fors: ", + join(',', map $_->[1]{'target'}, @fors), "\n"; + + if(! @fors) { + DEBUG and print "Treating $para_type paragraph as such because stack has no =for's\n"; + + #} elsif(grep $_->[1]{'~resolve'}, @fors) { + #} elsif(not grep !$_->[1]{'~resolve'}, @fors) { + } elsif( $fors[-1][1]{'~resolve'} ) { + # Look to the immediately containing for + + if($para_type eq 'Data') { + DEBUG and print "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; + $para->[0] = 'Para'; + $para_type = 'Plain'; + } else { + DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; + } + } else { + DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n"; + $para->[0] = $para_type = 'Data'; + } + } + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if($para_type eq 'Plain') { + $self->_ponder_Plain($para); + } elsif($para_type eq 'Verbatim') { + $self->_ponder_Verbatim($para); + } elsif($para_type eq 'Data') { + $self->_ponder_Data($para); + } else { + die "\$para type is $para_type -- how did that happen?"; + # Shouldn't happen. + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + $para->[0] =~ s/^[~=]//s; + + DEBUG and print "\n", pretty($para), "\n"; + + # traverse the treelet (which might well be just one string scalar) + $self->{'content_seen'} ||= 1; + $self->_traverse_treelet_bit(@$para); + } + } + + return; +} + +########################################################################### +# The sub-ponderers... + + + +sub _ponder_for { + my ($self,$para,$curr_open,$paras) = @_; + + # Fake it out as a begin/end + my $target; + + if(grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and print "Ignoring ignorable =for\n"; + return 1; + } + + for(my $i = 2; $i < @$para; ++$i) { + if($para->[$i] =~ s/^\s*(\S+)\s*//s) { + $target = $1; + last; + } + } + unless(defined $target) { + $self->whine( + $para->[1]{'start_line'}, + "=for without a target?" + ); + return 1; + } + DEBUG > 1 and + print "Faking out a =for $target as a =begin $target / =end $target\n"; + + $para->[0] = 'Data'; + + unshift @$paras, + ['=begin', + {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, + $target, + ], + $para, + ['=end', + {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, + $target, + ], + ; + + return 1; +} + +sub _ponder_begin { + my ($self,$para,$curr_open,$paras) = @_; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + unless(length($content)) { + $self->whine( + $para->[1]{'start_line'}, + "=begin without a target?" + ); + DEBUG and print "Ignoring targetless =begin\n"; + return 1; + } + + my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/; + $para->[1]{'title'} = $title if ($title); + $para->[1]{'target'} = $target; # without any ':' + $content = $target; # strip off the title + + $content =~ s/^:!/!:/s; + my $neg; # whether this is a negation-match + $neg = 1 if $content =~ s/^!//s; + my $to_resolve; # whether to process formatting codes + $to_resolve = 1 if $content =~ s/^://s; + + my $dont_ignore; # whether this target matches us + + foreach my $target_name ( + split(',', $content, -1), + $neg ? () : '*' + ) { + DEBUG > 2 and + print " Considering whether =begin $content matches $target_name\n"; + next unless $self->{'accept_targets'}{$target_name}; + + DEBUG > 2 and + print " It DOES match the acceptable target $target_name!\n"; + $to_resolve = 1 + if $self->{'accept_targets'}{$target_name} eq 'force_resolve'; + $dont_ignore = 1; + $para->[1]{'target_matching'} = $target_name; + last; # stop looking at other target names + } + + if($neg) { + if( $dont_ignore ) { + $dont_ignore = ''; + delete $para->[1]{'target_matching'}; + DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n"; + } else { + $dont_ignore = 1; + $para->[1]{'target_matching'} = '!'; + DEBUG > 2 and print " But the leading ! means that this IS a match!\n"; + } + } + + $para->[0] = '=for'; # Just what we happen to call these, internally + $para->[1]{'~really'} ||= '=begin'; + $para->[1]{'~ignore'} = (! $dont_ignore) || 0; + $para->[1]{'~resolve'} = $to_resolve || 0; + + DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '', + "ignore contents of this region\n"; + DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ", + ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n"; + DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n"; + + push @$curr_open, $para; + if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and print "Ignoring ignorable =begin\n"; + } else { + $self->{'content_seen'} ||= 1; + $self->_handle_element_start((my $scratch='for'), $para->[1]); + } + + return 1; +} + +sub _ponder_end { + my ($self,$para,$curr_open,$paras) = @_; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + DEBUG and print "Ogling '=end $content' directive\n"; + + unless(length($content)) { + $self->whine( + $para->[1]{'start_line'}, + "'=end' without a target?" . ( + ( @$curr_open and $curr_open->[-1][0] eq '=for' ) + ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' ) + : '' + ) + ); + DEBUG and print "Ignoring targetless =end\n"; + return 1; + } + + unless($content =~ m/^\S+$/) { # i.e., unless it's one word + $self->whine( + $para->[1]{'start_line'}, + "'=end $content' is invalid. (Stack: " + . $self->_dump_curr_open() . ')' + ); + DEBUG and print "Ignoring mistargetted =end $content\n"; + return 1; + } + + unless(@$curr_open and $curr_open->[-1][0] eq '=for') { + $self->whine( + $para->[1]{'start_line'}, + "=end $content without matching =begin. (Stack: " + . $self->_dump_curr_open() . ')' + ); + DEBUG and print "Ignoring mistargetted =end $content\n"; + return 1; + } + + unless($content eq $curr_open->[-1][1]{'target'}) { + $self->whine( + $para->[1]{'start_line'}, + "=end $content doesn't match =begin " + . $curr_open->[-1][1]{'target'} + . ". (Stack: " + . $self->_dump_curr_open() . ')' + ); + DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; + return 1; + } + + # Else it's okay to close... + if(grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n"; + # And that may be because of this to-be-closed =for region, or some + # other one, but it doesn't matter. + } else { + $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; + # what's that for? + + $self->{'content_seen'} ||= 1; + $self->_handle_element_end( my $scratch = 'for' ); + } + DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; + pop @$curr_open; + + return 1; +} + +sub _ponder_doc_end { + my ($self,$para,$curr_open,$paras) = @_; + if(@$curr_open) { # Deal with things left open + DEBUG and print "Stack is nonempty at end-document: (", + $self->_dump_curr_open(), ")\n"; + + DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n"; + unshift @$paras, $self->_closers_for_all_curr_open; + # Make sure there is exactly one ~end in the parastack, at the end: + @$paras = grep $_->[0] ne '~end', @$paras; + push @$paras, $para, $para; + # We need two -- once for the next cycle where we + # generate errata, and then another to be at the end + # when that loop back around to process the errata. + return 1; + + } else { + DEBUG and print "Okay, stack is empty now.\n"; + } + + # Try generating errata section, if applicable + unless($self->{'~tried_gen_errata'}) { + $self->{'~tried_gen_errata'} = 1; + my @extras = $self->_gen_errata(); + if(@extras) { + unshift @$paras, @extras; + DEBUG and print "Generated errata... relooping...\n"; + return 1; # I.e., loop around again to process these fake-o paragraphs + } + } + + splice @$paras; # Well, that's that for this paragraph buffer. + DEBUG and print "Throwing end-document event.\n"; + + $self->_handle_element_end( my $scratch = 'Document' ); + return 1; # Hasta la byebye +} + +sub _ponder_pod { + my ($self,$para,$curr_open,$paras) = @_; + $self->whine( + $para->[1]{'start_line'}, + "=pod directives shouldn't be over one line long! Ignoring all " + . (@$para - 2) . " lines of content" + ) if @$para > 3; + # Content is always ignored. + return; +} + +sub _ponder_over { + my ($self,$para,$curr_open,$paras) = @_; + return 1 unless @$paras; + my $list_type; + + if($paras->[0][0] eq '=item') { # most common case + $list_type = $self->_get_initial_item_type($paras->[0]); + + } elsif($paras->[0][0] eq '=back') { + # Ignore empty lists. TODO: make this an option? + shift @$paras; + return 1; + + } elsif($paras->[0][0] eq '~end') { + $self->whine( + $para->[1]{'start_line'}, + "=over is the last thing in the document?!" + ); + return 1; # But feh, ignore it. + } else { + $list_type = 'block'; + } + $para->[1]{'~type'} = $list_type; + push @$curr_open, $para; + # yes, we reuse the paragraph as a stack item + + my $content = join ' ', splice @$para, 2; + my $overness; + if($content =~ m/^\s*$/s) { + $para->[1]{'indent'} = 4; + } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) { + no integer; + $para->[1]{'indent'} = $1; + if($1 == 0) { + $self->whine( + $para->[1]{'start_line'}, + "Can't have a 0 in =over $content" + ); + $para->[1]{'indent'} = 4; + } + } else { + $self->whine( + $para->[1]{'start_line'}, + "=over should be: '=over' or '=over positive_number'" + ); + $para->[1]{'indent'} = 4; + } + DEBUG > 1 and print "=over found of type $list_type\n"; + + $self->{'content_seen'} ||= 1; + $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); + + return; +} + +sub _ponder_back { + my ($self,$para,$curr_open,$paras) = @_; + # TODO: fire off </item-number> or </item-bullet> or </item-text> ?? + + my $content = join ' ', splice @$para, 2; + if($content =~ m/\S/) { + $self->whine( + $para->[1]{'start_line'}, + "=back doesn't take any parameters, but you said =back $content" + ); + } + + if(@$curr_open and $curr_open->[-1][0] eq '=over') { + DEBUG > 1 and print "=back happily closes matching =over\n"; + # Expected case: we're closing the most recently opened thing + #my $over = pop @$curr_open; + $self->{'content_seen'} ||= 1; + $self->_handle_element_end( my $scratch = + 'over-' . ( (pop @$curr_open)->[1]{'~type'} ) + ); + } else { + DEBUG > 1 and print "=back found without a matching =over. Stack: (", + join(', ', map $_->[0], @$curr_open), ").\n"; + $self->whine( + $para->[1]{'start_line'}, + '=back without =over' + ); + return 1; # and ignore it + } +} + +sub _ponder_item { + my ($self,$para,$curr_open,$paras) = @_; + my $over; + unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') { + $self->whine( + $para->[1]{'start_line'}, + "'=item' outside of any '=over'" + ); + unshift @$paras, + ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], + $para + ; + return 1; + } + + + my $over_type = $over->[1]{'~type'}; + + if(!$over_type) { + # Shouldn't happen1 + die "Typeless over in stack, starting at line " + . $over->[1]{'start_line'}; + + } elsif($over_type eq 'block') { + unless($curr_open->[-1][1]{'~bitched_about'}) { + $curr_open->[-1][1]{'~bitched_about'} = 1; + $self->whine( + $curr_open->[-1][1]{'start_line'}, + "You can't have =items (as at line " + . $para->[1]{'start_line'} + . ") unless the first thing after the =over is an =item" + ); + } + # Just turn it into a paragraph and reconsider it + $para->[0] = '~Para'; + unshift @$paras, $para; + return 1; + + } elsif($over_type eq 'text') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'text') { + # Nothing special needs doing for 'text' + } elsif($item_type eq 'number' or $item_type eq 'bullet') { + die "Unknown item type $item_type" + unless $item_type eq 'number' or $item_type eq 'bullet'; + # Undo our clobbering: + push @$para, $para->[1]{'~orig_content'}; + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + # =item-text thingies don't need any assimilation, it seems. + + } elsif($over_type eq 'number') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; + + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; + + if($item_type eq 'bullet') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + push @$para, $para->[1]{'~orig_content'}; + # restore the bullet, blocking the assimilation of next para + + } elsif($item_type eq 'text') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + # Text content will still be there and will block next ~Para + + } elsif($item_type ne 'number') { + die "Unknown item type $item_type"; # should never happen + + } elsif($expected_value == $para->[1]{'number'}) { + DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n"; + + } else { + DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, + " instead of the expected value of $expected_value\n"; + $self->whine( + $para->[1]{'start_line'}, + "You have '=item " . $para->[1]{'number'} . + "' instead of the expected '=item $expected_value'" + ); + $para->[1]{'number'} = $expected_value; # correcting!! + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + + } elsif($over_type eq 'bullet') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'bullet') { + # as expected! + + if( $para->[1]{'~_freaky_para_hack'} ) { + DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; + push @$para, delete $para->[1]{'~_freaky_para_hack'}; + } + + } elsif($item_type eq 'number') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + push @$para, $para->[1]{'~orig_content'}; + # and block assimilation of the next paragraph + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } elsif($item_type eq 'text') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + # But doesn't need processing. But it'll block assimilation + # of the next para. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + } else { + die "Unhandled =over type \"$over_type\"?"; + # Shouldn't happen! + } + $para->[0] .= '-' . $over_type; + + return; +} + +sub _ponder_Plain { + my ($self,$para) = @_; + DEBUG and print " giving plain treatment...\n"; + unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' ) + or $para->[1]{'~cooked'} + ) { + push @$para, + @{$self->_make_treelet( + join("\n", splice(@$para, 2)), + $para->[1]{'start_line'} + )}; + } + # Empty paragraphs don't need a treelet for any reason I can see. + # And precooked paragraphs already have a treelet. + return; +} + +sub _ponder_Verbatim { + my ($self,$para) = @_; + DEBUG and print " giving verbatim treatment...\n"; + + $para->[1]{'xml:space'} = 'preserve'; + + my $indent = $self->strip_verbatim_indent; + if ($indent && ref $indent eq 'CODE') { + my @shifted = (shift @{$para}, shift @{$para}); + $indent = $indent->($para); + unshift @{$para}, @shifted; + } + + for(my $i = 2; $i < @$para; $i++) { + foreach my $line ($para->[$i]) { # just for aliasing + # Strip indentation. + $line =~ s/^\E$indent// if $indent + && !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted}); + while( $line =~ + # Sort of adapted from Text::Tabs -- yes, it's hardwired in that + # tabs are at every EIGHTH column. For portability, it has to be + # one setting everywhere, and 8th wins. + s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e + ) {} + + # TODO: whinge about (or otherwise treat) unindented or overlong lines + + } + } + + # Now the VerbatimFormatted hoodoo... + if( $self->{'accept_codes'} and + $self->{'accept_codes'}{'VerbatimFormatted'} + ) { + while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para } + # Kill any number of terminal newlines + $self->_verbatim_format($para); + } elsif ($self->{'codes_in_verbatim'}) { + push @$para, + @{$self->_make_treelet( + join("\n", splice(@$para, 2)), + $para->[1]{'start_line'}, $para->[1]{'xml:space'} + )}; + $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines + } else { + push @$para, join "\n", splice(@$para, 2) if @$para > 3; + $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines + } + return; +} + +sub _ponder_Data { + my ($self,$para) = @_; + DEBUG and print " giving data treatment...\n"; + $para->[1]{'xml:space'} = 'preserve'; + push @$para, join "\n", splice(@$para, 2) if @$para > 3; + return; +} + + + + +########################################################################### + +sub _traverse_treelet_bit { # for use only by the routine above + my($self, $name) = splice @_,0,2; + + my $scratch; + $self->_handle_element_start(($scratch=$name), shift @_); + + foreach my $x (@_) { + if(ref($x)) { + &_traverse_treelet_bit($self, @$x); + } else { + $self->_handle_text($x); + } + } + + $self->_handle_element_end($scratch=$name); + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _closers_for_all_curr_open { + my $self = $_[0]; + my @closers; + foreach my $still_open (@{ $self->{'curr_open'} || return }) { + my @copy = @$still_open; + $copy[1] = {%{ $copy[1] }}; + #$copy[1]{'start_line'} = -1; + if($copy[0] eq '=for') { + $copy[0] = '=end'; + } elsif($copy[0] eq '=over') { + $copy[0] = '=back'; + } else { + die "I don't know how to auto-close an open $copy[0] region"; + } + + unless( @copy > 2 ) { + push @copy, $copy[1]{'target'}; + $copy[-1] = '' unless defined $copy[-1]; + # since =over's don't have targets + } + + DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n"; + unshift @closers, \@copy; + } + return @closers; +} + +#-------------------------------------------------------------------------- + +sub _verbatim_format { + my($it, $p) = @_; + + my $formatting; + + for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines + DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n"; + $p->[$i] .= "\n"; + # Unlike with simple Verbatim blocks, we don't end up just doing + # a join("\n", ...) on the contents, so we have to append a + # newline to ever line, and then nix the last one later. + } + + if( DEBUG > 4 ) { + print "<<\n"; + for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines + print "_verbatim_format $i: $p->[$i]"; + } + print ">>\n"; + } + + for(my $i = $#$p; $i > 2; $i--) { + # work backwards over the lines, except the first (#2) + + #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s + # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s; + # look at a formatty line preceding a nonformatty one + DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n"; + if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) { + DEBUG > 5 and print " It's a formatty line. ", + "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n"; + + if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) { + DEBUG > 5 and print " Previous line is formatty! Skipping this one.\n"; + next; + } else { + DEBUG > 5 and print " Previous line is non-formatty! Yay!\n"; + } + } else { + DEBUG > 5 and print " It's not a formatty line. Ignoring\n"; + next; + } + + # A formatty line has to have #: in the first two columns, and uses + # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic. + # Example: + # What do you want? i like pie. [or whatever] + # #:^^^^^^^^^^^^^^^^^ ///////////// + + + DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; + + $formatting = ' ' . $1; + $formatting =~ s/\s+$//s; # nix trailing whitespace + unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op + splice @$p,$i,1; # remove this line + $i--; # don't consider next line + next; + } + + if( length($formatting) >= length($p->[$i-1]) ) { + $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' '; + } else { + $formatting .= ' ' x (length($p->[$i-1]) - length($formatting)); + } + # Make $formatting and the previous line be exactly the same length, + # with $formatting having a " " as the last character. + + DEBUG > 4 and print "Formatting <$formatting> on <", $p->[$i-1], ">\n"; + + + my @new_line; + while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) { + #print "Format matches $1\n"; + + if($2) { + #print "SKIPPING <$2>\n"; + push @new_line, + substr($p->[$i-1], pos($formatting)-length($1), length($1)); + } else { + #print "SNARING $+\n"; + push @new_line, [ + ( + $3 ? 'VerbatimB' : + $4 ? 'VerbatimI' : + $5 ? 'VerbatimBI' : die("Should never get called") + ), {}, + substr($p->[$i-1], pos($formatting)-length($1), length($1)) + ]; + #print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; + } + } + my @nixed = + splice @$p, $i-1, 2, @new_line; # replace myself and the next line + DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n"; + + DEBUG > 6 and print "New version of the above line is these tokens (", + scalar(@new_line), "):", + map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n"; + $i--; # So the next line we scrutinize is the line before the one + # that we just went and formatted + } + + $p->[0] = 'VerbatimFormatted'; + + # Collapse adjacent text nodes, just for kicks. + for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last + if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) { + DEBUG > 5 and print "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n"; + $p->[$i] .= splice @$p, $i+1, 1; # merge + --$i; # and back up + } + } + + # Now look for the last text token, and remove the terminal newline + for( my $i = $#$p; $i >= 2; $i-- ) { + # work backwards over the tokens, even the first + if( !ref($p->[$i]) ) { + if($p->[$i] =~ s/\n$//s) { + DEBUG > 5 and print "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n"; + } else { + DEBUG > 5 and print + "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n"; + } + last; # we only want the next one + } + } + + return; +} + + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + +sub _treelet_from_formatting_codes { + # Given a paragraph, returns a treelet. Full of scary tokenizing code. + # Like [ '~Top', {'start_line' => $start_line}, + # "I like ", + # [ 'B', {}, "pie" ], + # "!" + # ] + + my($self, $para, $start_line, $preserve_space) = @_; + + my $treelet = ['~Top', {'start_line' => $start_line},]; + + unless ($preserve_space || $self->{'preserve_whitespace'}) { + $para =~ s/\s+/ /g; # collapse and trim all whitespace first. + $para =~ s/ $//; + $para =~ s/^ //; + } + + # Only apparent problem the above code is that N<< >> turns into + # N<< >>. But then, word wrapping does that too! So don't do that! + + my @stack; + my @lineage = ($treelet); + + DEBUG > 4 and print "Paragraph:\n$para\n\n"; + + # Here begins our frightening tokenizer RE. The following regex matches + # text in four main parts: + # + # * Start-codes. The first alternative matches C< or C<<, the latter + # followed by some whitespace. $1 will hold the entire start code + # (including any space following a multiple-angle-bracket delimiter), + # and $2 will hold only the additional brackets past the first in a + # multiple-bracket delimiter. length($2) + 1 will be the number of + # closing brackets we have to find. + # + # * Closing brackets. Match some amount of whitespace followed by + # multiple close brackets. The logic to see if this closes anything + # is down below. Note that in order to parse C<< >> correctly, we + # have to use look-behind (?<=\s\s), since the match of the starting + # code will have consumed the whitespace. + # + # * A single closing bracket, to close a simple code like C<>. + # + # * Something that isn't a start or end code. We have to be careful + # about accepting whitespace, since perlpodspec says that any whitespace + # before a multiple-bracket closing delimiter should be ignored. + # + while($para =~ + m/\G + (?: + # Match starting codes, including the whitespace following a + # multiple-delimiter start code. $1 gets the whole start code and + # $2 gets all but one of the <s in the multiple-bracket case. + ([A-Z]<(?:(<+)\s+)?) + | + # Match multiple-bracket end codes. $3 gets the whitespace that + # should be discarded before an end bracket but kept in other cases + # and $4 gets the end brackets themselves. + (\s+|(?<=\s\s))(>{2,}) + | + (\s?>) # $5: simple end-codes + | + ( # $6: stuff containing no start-codes or end-codes + (?: + [^A-Z\s>] + | + (?: + [A-Z](?!<) + ) + | + # whitespace is ok, but we don't want to eat the whitespace before + # a multiple-bracket end code. + # NOTE: we may still have problems with e.g. S<< >> + (?: + \s(?!\s*>{2,}) + ) + )+ + ) + ) + /xgo + ) { + DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n"; + if(defined $1) { + if(defined $2) { + DEBUG > 3 and print "Found complex start-text code \"$1\"\n"; + push @stack, length($2) + 1; + # length of the necessary complex end-code string + } else { + DEBUG > 3 and print "Found simple start-text code \"$1\"\n"; + push @stack, 0; # signal that we're looking for simple + } + push @lineage, [ substr($1,0,1), {}, ]; # new node object + push @{ $lineage[-2] }, $lineage[-1]; + + } elsif(defined $4) { + DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n"; + # This is where it gets messy... + if(! @stack) { + # We saw " >>>>" but needed nothing. This is ALL just stuff then. + DEBUG > 4 and print " But it's really just stuff.\n"; + push @{ $lineage[-1] }, $3, $4; + next; + } elsif(!$stack[-1]) { + # We saw " >>>>" but needed only ">". Back pos up. + DEBUG > 4 and print " And that's more than we needed to close simple.\n"; + push @{ $lineage[-1] }, $3; # That was a for-real space, too. + pos($para) = pos($para) - length($4) + 1; + } elsif($stack[-1] == length($4)) { + # We found " >>>>", and it was exactly what we needed. Commonest case. + DEBUG > 4 and print " And that's exactly what we needed to close complex.\n"; + } elsif($stack[-1] < length($4)) { + # We saw " >>>>" but needed only " >>". Back pos up. + DEBUG > 4 and print " And that's more than we needed to close complex.\n"; + pos($para) = pos($para) - length($4) + $stack[-1]; + } else { + # We saw " >>>>" but needed " >>>>>>". So this is all just stuff! + DEBUG > 4 and print " But it's really just stuff, because we needed more.\n"; + push @{ $lineage[-1] }, $3, $4; + next; + } + #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; + + push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; + # Keep the element from being childless + + pop @stack; + pop @lineage; + + } elsif(defined $5) { + DEBUG > 3 and print "Found apparent simple end-text code \"$5\"\n"; + + if(@stack and ! $stack[-1]) { + # We're indeed expecting a simple end-code + DEBUG > 4 and print " It's indeed an end-code.\n"; + + if(length($5) == 2) { # There was a space there: " >" + push @{ $lineage[-1] }, ' '; + } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element + push @{ $lineage[-1] }, ''; # keep it from being really childless + } + + pop @stack; + pop @lineage; + } else { + DEBUG > 4 and print " It's just stuff.\n"; + push @{ $lineage[-1] }, $5; + } + + } elsif(defined $6) { + DEBUG > 3 and print "Found stuff \"$6\"\n"; + push @{ $lineage[-1] }, $6; + + } else { + # should never ever ever ever happen + DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n"; + die "SPORK 512512!"; + } + } + + if(@stack) { # Uhoh, some sequences weren't closed. + my $x= "..."; + while(@stack) { + push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; + # Hmmmmm! + + my $code = (pop @lineage)->[0]; + my $ender_length = pop @stack; + if($ender_length) { + --$ender_length; + $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length); + } else { + $x = $code . "<$x>"; + } + } + DEBUG > 1 and print "Unterminated $x sequence\n"; + $self->whine($start_line, + "Unterminated $x sequence", + ); + } + + return $treelet; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub text_content_of_treelet { # method: $parser->text_content_of_treelet($lol) + return stringify_lol($_[1]); +} + +sub stringify_lol { # function: stringify_lol($lol) + my $string_form = ''; + _stringify_lol( $_[0] => \$string_form ); + return $string_form; +} + +sub _stringify_lol { # the real recursor + my($lol, $to) = @_; + for(my $i = 2; $i < @$lol; ++$i) { + if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) { + _stringify_lol( $lol->[$i], $to); # recurse! + } else { + $$to .= $lol->[$i]; + } + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _dump_curr_open { # return a string representation of the stack + my $curr_open = $_[0]{'curr_open'}; + + return '[empty]' unless @$curr_open; + return join '; ', + map {; + ($_->[0] eq '=for') + ? ( ($_->[1]{'~really'} || '=over') + . ' ' . $_->[1]{'target'}) + : $_->[0] + } + @$curr_open + ; +} + +########################################################################### +my %pretty_form = ( + "\a" => '\a', # ding! + "\b" => '\b', # BS + "\e" => '\e', # ESC + "\f" => '\f', # FF + "\t" => '\t', # tab + "\cm" => '\cm', + "\cj" => '\cj', + "\n" => '\n', # probably overrides one of either \cm or \cj + '"' => '\"', + '\\' => '\\\\', + '$' => '\\$', + '@' => '\\@', + '%' => '\\%', + '#' => '\\#', +); + +sub pretty { # adopted from Class::Classless + # Not the most brilliant routine, but passable. + # Don't give it a cyclic data structure! + my @stuff = @_; # copy + my $x; + my $out = + # join ",\n" . + join ", ", + map {; + if(!defined($_)) { + "undef"; + } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') { + $x = "[ " . pretty(@$_) . " ]" ; + $x; + } elsif(ref($_) eq 'SCALAR') { + $x = "\\" . pretty($$_) ; + $x; + } elsif(ref($_) eq 'HASH') { + my $hr = $_; + $x = "{" . join(", ", + map(pretty($_) . '=>' . pretty($hr->{$_}), + sort keys %$hr ) ) . "}" ; + $x; + } elsif(!length($_)) { q{''} # empty string + } elsif( + $_ eq '0' # very common case + or( + m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s + and $_ ne '-0' # the strange case that that RE lets thru + ) + ) { $_; + } else { + if( chr(65) eq 'A' ) { + s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> + #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; + <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; + } else { + # We're in some crazy non-ASCII world! + s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])> + #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; + <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; + } + qq{"$_"}; + } + } @stuff; + # $out =~ s/\n */ /g if length($out) < 75; + return $out; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +# A rather unsubtle method of blowing away all the state information +# from a parser object so it can be reused. Provided as a utility for +# backward compatibilty in Pod::Man, etc. but not recommended for +# general use. + +sub reinit { + my $self = shift; + foreach (qw(source_dead source_filename doc_has_started +start_of_pod_block content_seen last_was_blank paras curr_open +line_count pod_para_count in_pod ~tried_gen_errata errata errors_seen +Title)) { + + delete $self->{$_}; + } +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm new file mode 100644 index 00000000000..26a60237236 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm @@ -0,0 +1,196 @@ + +# A quite dimwitted pod2plaintext that need only know how to format whatever +# text comes out of Pod::BlackBox's _gen_errata + +require 5; +package Pod::Simple::Checker; +use strict; +use Carp (); +use Pod::Simple::Methody (); +use Pod::Simple (); +use vars qw( @ISA $VERSION ); +$VERSION = '3.14'; +@ISA = ('Pod::Simple::Methody'); +BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) + ? \&Pod::Simple::DEBUG + : sub() {0} + } + +use Text::Wrap 98.112902 (); # was 2001.0131, but I don't think we need that +$Text::Wrap::wrap = 'overflow'; +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub any_errata_seen { # read-only accessor + return $_[1]->{'Errata_seen'}; +} + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->{'Thispara'} = ''; + $new->{'Indent'} = 0; + $new->{'Indentstring'} = ' '; + $new->{'Errata_seen'} = 0; + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub handle_text { $_[0]{'Errata_seen'} and $_[0]{'Thispara'} .= $_[1] } + +sub start_Para { $_[0]{'Thispara'} = '' } + +sub start_head1 { + if($_[0]{'Errata_seen'}) { + $_[0]{'Thispara'} = ''; + } else { + if($_[1]{'errata'}) { # start of errata! + $_[0]{'Errata_seen'} = 1; + $_[0]{'Thispara'} = $_[0]{'source_filename'} ? + "$_[0]{'source_filename'} -- " : '' + } + } +} +sub start_head2 { $_[0]{'Thispara'} = '' } +sub start_head3 { $_[0]{'Thispara'} = '' } +sub start_head4 { $_[0]{'Thispara'} = '' } + +sub start_Verbatim { $_[0]{'Thispara'} = '' } +sub start_item_bullet { $_[0]{'Thispara'} = '* ' } +sub start_item_number { $_[0]{'Thispara'} = "$_[1]{'number'}. " } +sub start_item_text { $_[0]{'Thispara'} = '' } + +sub start_over_bullet { ++$_[0]{'Indent'} } +sub start_over_number { ++$_[0]{'Indent'} } +sub start_over_text { ++$_[0]{'Indent'} } +sub start_over_block { ++$_[0]{'Indent'} } + +sub end_over_bullet { --$_[0]{'Indent'} } +sub end_over_number { --$_[0]{'Indent'} } +sub end_over_text { --$_[0]{'Indent'} } +sub end_over_block { --$_[0]{'Indent'} } + + +# . . . . . Now the actual formatters: + +sub end_head1 { $_[0]->emit_par(-4) } +sub end_head2 { $_[0]->emit_par(-3) } +sub end_head3 { $_[0]->emit_par(-2) } +sub end_head4 { $_[0]->emit_par(-1) } +sub end_Para { $_[0]->emit_par( 0) } +sub end_item_bullet { $_[0]->emit_par( 0) } +sub end_item_number { $_[0]->emit_par( 0) } +sub end_item_text { $_[0]->emit_par(-2) } + +sub emit_par { + return unless $_[0]{'Errata_seen'}; + my($self, $tweak_indent) = splice(@_,0,2); + my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) ); + # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0 + + $self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII; + my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); + $out =~ tr{\xA0}{ } if Pod::Simple::ASCII; + print {$self->{'output_fh'}} $out, + #"\n" + ; + $self->{'Thispara'} = ''; + + return; +} + +# . . . . . . . . . . And then off by its lonesome: + +sub end_Verbatim { + return unless $_[0]{'Errata_seen'}; + my $self = shift; + if(Pod::Simple::ASCII) { + $self->{'Thispara'} =~ tr{\xA0}{ }; + $self->{'Thispara'} =~ tr{\xAD}{}d; + } + + my $i = ' ' x ( 2 * $self->{'Indent'} + 4); + + $self->{'Thispara'} =~ s/^/$i/mg; + + print { $self->{'output_fh'} } '', + $self->{'Thispara'}, + "\n\n" + ; + $self->{'Thispara'} = ''; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + +__END__ + +=head1 NAME + +Pod::Simple::Checker -- check the Pod syntax of a document + +=head1 SYNOPSIS + + perl -MPod::Simple::Checker -e \ + "exit Pod::Simple::Checker->filter(shift)->any_errata_seen" \ + thingy.pod + +=head1 DESCRIPTION + +This class is for checking the syntactic validity of Pod. +It works by basically acting like a simple-minded version of +L<Pod::Simple::Text> that formats only the "Pod Errors" section +(if Pod::Simple even generates one for the given document). + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Checker> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm new file mode 100644 index 00000000000..1349be32cb6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm @@ -0,0 +1,178 @@ + +require 5; +package Pod::Simple::Debug; +use strict; +use vars qw($VERSION ); +$VERSION = '3.14'; + +sub import { + my($value,$variable); + + if(@_ == 2) { + $value = $_[1]; + } elsif(@_ == 3) { + ($variable, $value) = @_[1,2]; + + ($variable, $value) = ($value, $variable) + if defined $value and ref($value) eq 'SCALAR' + and not(defined $variable and ref($variable) eq 'SCALAR') + ; # tolerate getting it backwards + + unless( defined $variable and ref($variable) eq 'SCALAR') { + require Carp; + Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor" + . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting"); + } + } else { + require Carp; + Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor" + . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting"); + } + + if( defined &Pod::Simple::DEBUG ) { + require Carp; + Carp::croak("It's too late to call Pod::Simple::Debug -- " + . "Pod::Simple has already loaded\nAborting"); + } + + $value = 0 unless defined $value; + + unless($value =~ m/^-?\d+$/) { + require Carp; + Carp::croak( "$value isn't a numeric value." + . "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor" + . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting"); + } + + if( defined $variable ) { + # make a not-really-constant + *Pod::Simple::DEBUG = sub () { $$variable } ; + $$variable = $value; + print "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n"; + } else { + *Pod::Simple::DEBUG = eval " sub () { $value } "; + print "# Starting Pod::Simple::DEBUG = $value\n"; + } + + require Pod::Simple; + return; +} + +1; + + +__END__ + +=head1 NAME + +Pod::Simple::Debug -- put Pod::Simple into trace/debug mode + +=head1 SYNOPSIS + + use Pod::Simple::Debug (5); # or some integer + +Or: + + my $debuglevel; + use Pod::Simple::Debug (\$debuglevel, 0); + ...some stuff that uses Pod::Simple to do stuff, but which + you don't want debug output from... + + $debug_level = 4; + ...some stuff that uses Pod::Simple to do stuff, but which + you DO want debug output from... + + $debug_level = 0; + +=head1 DESCRIPTION + +This is an internal module for controlling the debug level (a.k.a. trace +level) of Pod::Simple. This is of interest only to Pod::Simple +developers. + + +=head1 CAVEATS + +Note that you should load this module I<before> loading Pod::Simple (or +any Pod::Simple-based class). If you try loading Pod::Simple::Debug +after &Pod::Simple::DEBUG is already defined, Pod::Simple::Debug will +throw a fatal error to the effect that +"it's s too late to call Pod::Simple::Debug". + +Note that the C<use Pod::Simple::Debug (\$x, I<somenum>)> mode will make +Pod::Simple (et al) run rather slower, since &Pod::Simple::DEBUG won't +be a constant sub anymore, and so Pod::Simple (et al) won't compile with +constant-folding. + + +=head1 GUTS + +Doing this: + + use Pod::Simple::Debug (5); # or some integer + +is basically equivalent to: + + BEGIN { sub Pod::Simple::DEBUG () {5} } # or some integer + use Pod::Simple (); + +And this: + + use Pod::Simple::Debug (\$debug_level,0); # or some integer + +is basically equivalent to this: + + my $debug_level; + BEGIN { $debug_level = 0 } + BEGIN { sub Pod::Simple::DEBUG () { $debug_level } + use Pod::Simple (); + +=head1 SEE ALSO + +L<Pod::Simple> + +The article "Constants in Perl", in I<The Perl Journal> issue +21. See L<http://interglacial.com/tpj/21/> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm new file mode 100644 index 00000000000..91554341e35 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm @@ -0,0 +1,155 @@ + +require 5; +package Pod::Simple::DumpAsText; +$VERSION = '3.14'; +use Pod::Simple (); +BEGIN {@ISA = ('Pod::Simple')} + +use strict; + +use Carp (); + +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->accept_codes('VerbatimFormatted'); + return $new; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_element_start { + # ($self, $element_name, $attr_hash_r) + my $fh = $_[0]{'output_fh'}; + my($key, $value); + DEBUG and print "++ $_[1]\n"; + + print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n"; + $_[0]{'indent'}++; + while(($key,$value) = each %{$_[2]}) { + unless($key =~ m/^~/s) { + next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; + _perly_escape($key); + _perly_escape($value); + printf $fh qq{%s \\ "%s" => "%s"\n}, + ' ' x ($_[0]{'indent'} || 0), $key, $value; + } + } + return; +} + +sub _handle_text { + DEBUG and print "== \"$_[1]\"\n"; + + if(length $_[1]) { + my $indent = ' ' x $_[0]{'indent'}; + my $text = $_[1]; + _perly_escape($text); + $text =~ # A not-totally-brilliant wrapping algorithm: + s/( + [^\n]{55} # Snare some characters from a line + [^\n\ ]{0,50} # and finish any current word + ) + \x20{1,10}(?!\n) # capture some spaces not at line-end + /$1"\n$indent . "/gx # => line-break here + ; + + print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n"; + } + return; +} + +sub _handle_element_end { + DEBUG and print "-- $_[1]\n"; + print {$_[0]{'output_fh'}} + ' ' x --$_[0]{'indent'}, "--", $_[1], "\n"; + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _perly_escape { + foreach my $x (@_) { + $x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg; + # Escape things very cautiously: + $x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg; + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +__END__ + +=head1 NAME + +Pod::Simple::DumpAsText -- dump Pod-parsing events as text + +=head1 SYNOPSIS + + perl -MPod::Simple::DumpAsText -e \ + "exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \ + thingy.pod + +=head1 DESCRIPTION + +This class is for dumping, as text, the events gotten from parsing a Pod +document. This class is of interest to people writing Pod formatters +based on Pod::Simple. It is useful for seeing exactly what events you +get out of some Pod that you feed in. + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +=head1 SEE ALSO + +L<Pod::Simple::DumpAsXML> + +L<Pod::Simple> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm new file mode 100644 index 00000000000..d83f8d33f55 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm @@ -0,0 +1,170 @@ + +require 5; +package Pod::Simple::DumpAsXML; +$VERSION = '3.14'; +use Pod::Simple (); +BEGIN {@ISA = ('Pod::Simple')} + +use strict; + +use Carp (); + +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->accept_codes('VerbatimFormatted'); + return $new; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_element_start { + # ($self, $element_name, $attr_hash_r) + my $fh = $_[0]{'output_fh'}; + my($key, $value); + DEBUG and print "++ $_[1]\n"; + + print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1]; + + foreach my $key (sort keys %{$_[2]}) { + unless($key =~ m/^~/s) { + next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; + _xml_escape($value = $_[2]{$key}); + print $fh ' ', $key, '="', $value, '"'; + } + } + + + print $fh ">\n"; + $_[0]{'indent'}++; + return; +} + +sub _handle_text { + DEBUG and print "== \"$_[1]\"\n"; + if(length $_[1]) { + my $indent = ' ' x $_[0]{'indent'}; + my $text = $_[1]; + _xml_escape($text); + $text =~ # A not-totally-brilliant wrapping algorithm: + s/( + [^\n]{55} # Snare some characters from a line + [^\n\ ]{0,50} # and finish any current word + ) + \x20{1,10}(?!\n) # capture some spaces not at line-end + /$1\n$indent/gx # => line-break here + ; + + print {$_[0]{'output_fh'}} $indent, $text, "\n"; + } + return; +} + +sub _handle_element_end { + DEBUG and print "-- $_[1]\n"; + print {$_[0]{'output_fh'}} + ' ' x --$_[0]{'indent'}, "</", $_[1], ">\n"; + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _xml_escape { + foreach my $x (@_) { + # Escape things very cautiously: + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + # Yes, stipulate the list without a range, so that this can work right on + # all charsets that this module happens to run under. + # Altho, hmm, what about that ord? Presumably that won't work right + # under non-ASCII charsets. Something should be done about that. + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + +__END__ + +=head1 NAME + +Pod::Simple::DumpAsXML -- turn Pod into XML + +=head1 SYNOPSIS + + perl -MPod::Simple::DumpAsXML -e \ + "exit Pod::Simple::DumpAsXML->filter(shift)->any_errata_seen" \ + thingy.pod + +=head1 DESCRIPTION + +Pod::Simple::DumpAsXML is a subclass of L<Pod::Simple> that parses Pod +and turns it into indented and wrapped XML. This class is of +interest to people writing Pod formatters based on Pod::Simple. + +Pod::Simple::DumpAsXML inherits methods from +L<Pod::Simple>. + + +=head1 SEE ALSO + +L<Pod::Simple::XMLOutStream> is rather like this class. +Pod::Simple::XMLOutStream's output is space-padded in a way +that's better for sending to an XML processor (that is, it has +no ignoreable whitespace). But +Pod::Simple::DumpAsXML's output is much more human-readable, being +(more-or-less) one token per line, with line-wrapping. + +L<Pod::Simple::DumpAsText> is rather like this class, +except that it doesn't dump with XML syntax. Try them and see +which one you like best! + +L<Pod::Simple>, L<Pod::Simple::DumpAsXML> + +The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm new file mode 100644 index 00000000000..b1a75cb4e39 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm @@ -0,0 +1,978 @@ + +require 5; +package Pod::Simple::HTML; +use strict; +use Pod::Simple::PullParser (); +use vars qw( + @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION + $Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix + $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex + $Doctype_decl $Content_decl +); +@ISA = ('Pod::Simple::PullParser'); +$VERSION = '3.14'; + +BEGIN { + if(defined &DEBUG) { } # no-op + elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } + else { *DEBUG = sub () {0}; } +} + +$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it. + # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" + # "http://www.w3.org/TR/html4/loose.dtd">\n}; + +$Content_decl ||= + q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >}; + +$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION; +$Computerese = "" unless defined $Computerese; +$LamePad = '' unless defined $LamePad; + +$Linearization_Limit = 120 unless defined $Linearization_Limit; + # headings/items longer than that won't get an <a name="..."> +$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?' + unless defined $Perldoc_URL_Prefix; +$Perldoc_URL_Postfix = '' + unless defined $Perldoc_URL_Postfix; + + +$Man_URL_Prefix = 'http://man.he.net/man'; +$Man_URL_Postfix = ''; + +$Title_Prefix = '' unless defined $Title_Prefix; +$Title_Postfix = '' unless defined $Title_Postfix; +%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text + # 'item-text' stuff in the index doesn't quite work, and may + # not be a good idea anyhow. + + +__PACKAGE__->_accessorize( + 'perldoc_url_prefix', + # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what + # to put before the "Foo%3a%3aBar". + # (for singleton mode only?) + 'perldoc_url_postfix', + # what to put after "Foo%3a%3aBar" in the URL. Normally "". + + 'man_url_prefix', + # In turning L<crontab(5)> into http://whatever/man/1/crontab, what + # to put before the "1/crontab". + 'man_url_postfix', + # what to put after the "1/crontab" in the URL. Normally "". + + 'batch_mode', # whether we're in batch mode + 'batch_mode_current_level', + # When in batch mode, how deep the current module is: 1 for "LWP", + # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc + + 'title_prefix', 'title_postfix', + # What to put before and after the title in the head. + # Should already be &-escaped + + 'html_h_level', + + 'html_header_before_title', + 'html_header_after_title', + 'html_footer', + + 'index', # whether to add an index at the top of each page + # (actually it's a table-of-contents, but we'll call it an index, + # out of apparently longstanding habit) + + 'html_css', # URL of CSS file to point to + 'html_javascript', # URL of CSS file to point to + + 'force_title', # should already be &-escaped + 'default_title', # should already be &-escaped +); + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +my @_to_accept; + +%Tagmap = ( + 'Verbatim' => "\n<pre$Computerese>", + '/Verbatim' => "</pre>\n", + 'VerbatimFormatted' => "\n<pre$Computerese>", + '/VerbatimFormatted' => "</pre>\n", + 'VerbatimB' => "<b>", + '/VerbatimB' => "</b>", + 'VerbatimI' => "<i>", + '/VerbatimI' => "</i>", + 'VerbatimBI' => "<b><i>", + '/VerbatimBI' => "</i></b>", + + + 'Data' => "\n", + '/Data' => "\n", + + 'head1' => "\n<h1>", # And also stick in an <a name="..."> + 'head2' => "\n<h2>", # '' + 'head3' => "\n<h3>", # '' + 'head4' => "\n<h4>", # '' + '/head1' => "</a></h1>\n", + '/head2' => "</a></h2>\n", + '/head3' => "</a></h3>\n", + '/head4' => "</a></h4>\n", + + 'X' => "<!--\n\tINDEX: ", + '/X' => "\n-->", + + changes(qw( + Para=p + B=b I=i + over-bullet=ul + over-number=ol + over-text=dl + over-block=blockquote + item-bullet=li + item-number=li + item-text=dt + )), + changes2( + map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ } + qw[ + sample=samp + definition=dfn + kbd=keyboard + variable=var + citation=cite + abbreviation=abbr + acronym=acronym + subscript=sub + superscript=sup + big=big + small=small + underline=u + strikethrough=s + ] # no point in providing a way to get <q>...</q>, I think + ), + + '/item-bullet' => "</li>$LamePad\n", + '/item-number' => "</li>$LamePad\n", + '/item-text' => "</a></dt>$LamePad\n", + 'item-body' => "\n<dd>", + '/item-body' => "</dd>\n", + + + 'B' => "<b>", '/B' => "</b>", + 'I' => "<i>", '/I' => "</i>", + 'F' => "<em$Computerese>", '/F' => "</em>", + 'C' => "<code$Computerese>", '/C' => "</code>", + 'L' => "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used! + '/L' => "</a>", +); + +sub changes { + return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s + ? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_" + } @_; +} +sub changes2 { + return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s + ? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_" + } @_; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 } + # Just so we can run from the command line. No options. + # For that, use perldoc! +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub new { + my $new = shift->SUPER::new(@_); + #$new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->accept_targets( 'html', 'HTML' ); + $new->accept_codes('VerbatimFormatted'); + $new->accept_codes(@_to_accept); + DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n"; + + $new->perldoc_url_prefix( $Perldoc_URL_Prefix ); + $new->perldoc_url_postfix( $Perldoc_URL_Postfix ); + $new->man_url_prefix( $Man_URL_Prefix ); + $new->man_url_postfix( $Man_URL_Postfix ); + $new->title_prefix( $Title_Prefix ); + $new->title_postfix( $Title_Postfix ); + + $new->html_header_before_title( + qq[$Doctype_decl<html><head><title>] + ); + $new->html_header_after_title( join "\n" => + "</title>", + $Content_decl, + "</head>\n<body class='pod'>", + $new->version_tag_comment, + "<!-- start doc -->\n", + ); + $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] ); + + $new->{'Tagmap'} = {%Tagmap}; + + return $new; +} + +sub __adjust_html_h_levels { + my ($self) = @_; + my $Tagmap = $self->{'Tagmap'}; + + my $add = $self->html_h_level; + return unless defined $add; + return if ($self->{'Adjusted_html_h_levels'}||0) == $add; + + $add -= 1; + for (1 .. 4) { + $Tagmap->{"head$_"} =~ s/$_/$_ + $add/e; + $Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e; + } +} + +sub batch_mode_page_object_init { + my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; + DEBUG and print "Initting $self\n for $module\n", + " in $infile\n out $outfile\n depth $depth\n"; + $self->batch_mode(1); + $self->batch_mode_current_level($depth); + return $self; +} + +sub run { + my $self = $_[0]; + return $self->do_middle if $self->bare_output; + return + $self->do_beginning && $self->do_middle && $self->do_end; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub do_beginning { + my $self = $_[0]; + + my $title; + + if(defined $self->force_title) { + $title = $self->force_title; + DEBUG and print "Forcing title to be $title\n"; + } else { + # Actually try looking for the title in the document: + $title = $self->get_short_title(); + unless($self->content_seen) { + DEBUG and print "No content seen in search for title.\n"; + return; + } + $self->{'Title'} = $title; + + if(defined $title and $title =~ m/\S/) { + $title = $self->title_prefix . esc($title) . $self->title_postfix; + } else { + $title = $self->default_title; + $title = '' unless defined $title; + DEBUG and print "Title defaults to $title\n"; + } + } + + + my $after = $self->html_header_after_title || ''; + if($self->html_css) { + my $link = + $self->html_css =~ m/</ + ? $self->html_css # It's a big blob of markup, let's drop it in + : sprintf( # It's just a URL, so let's wrap it up + qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n], + $self->html_css, + ); + $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind + } + $self->_add_top_anchor(\$after); + + if($self->html_javascript) { + my $link = + $self->html_javascript =~ m/</ + ? $self->html_javascript # It's a big blob of markup, let's drop it in + : sprintf( # It's just a URL, so let's wrap it up + qq[<script type="text/javascript" src="%s"></script>\n], + $self->html_javascript, + ); + $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind + } + + print {$self->{'output_fh'}} + $self->html_header_before_title || '', + $title, # already escaped + $after, + ; + + DEBUG and print "Returning from do_beginning...\n"; + return 1; +} + +sub _add_top_anchor { + my($self, $text_r) = @_; + unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack + $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n"; + } + return; +} + +sub version_tag_comment { + my $self = shift; + return sprintf + "<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n", + esc( + ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(), + $], scalar(gmtime), + ), $self->_modnote(), + ; +} + +sub _modnote { + my $class = ref($_[0]) || $_[0]; + return join "\n " => grep m/\S/, split "\n", + +qq{ +If you want to change this HTML document, you probably shouldn't do that +by changing it directly. Instead, see about changing the calling options +to $class, and/or subclassing $class, +then reconverting this document from the Pod source. +When in doubt, email the author of $class for advice. +See 'perldoc $class' for more info. +}; + +} + +sub do_end { + my $self = $_[0]; + print {$self->{'output_fh'}} $self->html_footer || ''; + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# Normally this would just be a call to _do_middle_main_loop -- but we +# have to do some elaborate things to emit all the content and then +# summarize it and output it /before/ the content that it's a summary of. + +sub do_middle { + my $self = $_[0]; + return $self->_do_middle_main_loop unless $self->index; + + if( $self->output_string ) { + # An efficiency hack + my $out = $self->output_string; #it's a reference to it + my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n"; + $$out .= $sneakytag; + $self->_do_middle_main_loop; + $sneakytag = quotemeta($sneakytag); + my $index = $self->index_as_html(); + if( $$out =~ s/$sneakytag/$index/s ) { + # Expected case + DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n"; + } else { + DEBUG and print "Odd, couldn't find where to insert the index in the output!\n"; + # I don't think this should ever happen. + } + return 1; + } + + unless( $self->output_fh ) { + require Carp; + Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that."); + } + + # If we get here, we're outputting to a FH. So we need to do some magic. + # Namely, divert all content to a string, which we output after the index. + my $fh = $self->output_fh; + my $content = ''; + { + # Our horrible bait and switch: + $self->output_string( \$content ); + $self->_do_middle_main_loop; + $self->abandon_output_string(); + $self->output_fh($fh); + } + print $fh $self->index_as_html(); + print $fh $content; + + return 1; +} + +########################################################################### + +sub index_as_html { + my $self = $_[0]; + # This is meant to be called AFTER the input document has been parsed! + + my $points = $self->{'PSHTML_index_points'} || []; + + @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n]; + # There's no point in having a 0-item or 1-item index, I dare say. + + my(@out) = qq{\n<div class='indexgroup'>}; + my $level = 0; + + my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent); + foreach my $p (@$points, ['head0', '(end)']) { + ($tagname, $text) = @$p; + $anchorname = $self->section_escape($text); + if( $tagname =~ m{^head(\d+)$} ) { + $target_level = 0 + $1; + } else { # must be some kinda list item + if($previous_tagname =~ m{^head\d+$} ) { + $target_level = $level + 1; + } else { + $target_level = $level; # no change needed + } + } + + # Get to target_level by opening or closing ULs + while($level > $target_level) + { --$level; push @out, (" " x $level) . "</ul>"; } + while($level < $target_level) + { ++$level; push @out, (" " x ($level-1)) + . "<ul class='indexList indexList$level'>"; } + + $previous_tagname = $tagname; + next unless $level; + + $indent = ' ' x $level; + push @out, sprintf + "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>", + $indent, $level, esc($anchorname), esc($text) + ; + } + push @out, "</div>\n"; + return join "\n", @out; +} + +########################################################################### + +sub _do_middle_main_loop { + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + my $tagmap = $self->{'Tagmap'}; + + $self->__adjust_html_h_levels; + + my($token, $type, $tagname, $linkto, $linktype); + my @stack; + my $dont_wrap = 0; + + while($token = $self->get_token) { + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if( ($type = $token->type) eq 'start' ) { + if(($tagname = $token->tagname) eq 'L') { + $linktype = $token->attr('type') || 'insane'; + + $linkto = $self->do_link($token); + + if(defined $linkto and length $linkto) { + esc($linkto); + # (Yes, SGML-escaping applies on top of %-escaping! + # But it's rarely noticeable in practice.) + print $fh qq{<a href="$linkto" class="podlink$linktype"\n>}; + } else { + print $fh "<a>"; # Yes, an 'a' element with no attributes! + } + + } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) { + print $fh $tagmap->{$tagname} || next; + + my @to_unget; + while(1) { + push @to_unget, $self->get_token; + last if $to_unget[-1]->is_end + and $to_unget[-1]->tagname eq $tagname; + + # TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens) + } + + my $name = $self->linearize_tokens(@to_unget); + $name = $self->do_section($name, $token) if defined $name; + + print $fh "<a "; + print $fh "class='u' href='#___top' title='click to go to top of document'\n" + if $tagname =~ m/^head\d$/s; + + if(defined $name) { + my $esc = esc( $self->section_name_tidy( $name ) ); + print $fh qq[name="$esc"]; + DEBUG and print "Linearized ", scalar(@to_unget), + " tokens as \"$name\".\n"; + push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name] + if $ToIndex{ $tagname }; + # Obviously, this discards all formatting codes (saving + # just their content), but ahwell. + + } else { # ludicrously long, so nevermind + DEBUG and print "Linearized ", scalar(@to_unget), + " tokens, but it was too long, so nevermind.\n"; + } + print $fh "\n>"; + $self->unget_token(@to_unget); + + } elsif ($tagname eq 'Data') { + my $next = $self->get_token; + next unless defined $next; + unless( $next->type eq 'text' ) { + $self->unget_token($next); + next; + } + DEBUG and print " raw text ", $next->text, "\n"; + print $fh "\n" . $next->text . "\n"; + next; + + } else { + if( $tagname =~ m/^over-/s ) { + push @stack, ''; + } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) { + print $fh $stack[-1]; + $stack[-1] = ''; + } + print $fh $tagmap->{$tagname} || next; + ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted" + or $tagname eq 'X'; + } + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + } elsif( $type eq 'end' ) { + if( ($tagname = $token->tagname) =~ m/^over-/s ) { + if( my $end = pop @stack ) { + print $fh $end; + } + } elsif( $tagname =~ m/^item-/s and @stack) { + $stack[-1] = $tagmap->{"/$tagname"}; + if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) { + $self->unget_token($next); + if( $next->type eq 'start' ) { + print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"}; + $stack[-1] = $tagmap->{"/item-body"}; + } + } + next; + } + print $fh $tagmap->{"/$tagname"} || next; + --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X'; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + } elsif( $type eq 'text' ) { + esc($type = $token->text); # reuse $type, why not + $type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap; + print $fh $type; + } + + } + return 1; +} + +########################################################################### +# + +sub do_section { + my($self, $name, $token) = @_; + return $name; +} + +sub do_link { + my($self, $token) = @_; + my $type = $token->attr('type'); + if(!defined $type) { + $self->whine("Typeless L!?", $token->attr('start_line')); + } elsif( $type eq 'pod') { return $self->do_pod_link($token); + } elsif( $type eq 'url') { return $self->do_url_link($token); + } elsif( $type eq 'man') { return $self->do_man_link($token); + } else { + $self->whine("L of unknown type $type!?", $token->attr('start_line')); + } + return 'FNORG'; # should never get called +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub do_url_link { return $_[1]->attr('to') } + +sub do_man_link { + my ($self, $link) = @_; + my $to = $link->attr('to'); + my $frag = $link->attr('section'); + + return undef unless defined $to and length $to; # should never happen + + $frag = $self->section_escape($frag) + if defined $frag and length($frag .= ''); # (stringify) + + DEBUG and print "Resolving \"$to/$frag\"\n\n"; + + return $self->resolve_man_page_link($to, $frag); +} + + +sub do_pod_link { + # And now things get really messy... + my($self, $link) = @_; + my $to = $link->attr('to'); + my $section = $link->attr('section'); + return undef unless( # should never happen + (defined $to and length $to) or + (defined $section and length $section) + ); + + $section = $self->section_escape($section) + if defined $section and length($section .= ''); # (stringify) + + DEBUG and printf "Resolving \"%s\" \"%s\"...\n", + $to || "(nil)", $section || "(nil)"; + + { + # An early hack: + my $complete_url = $self->resolve_pod_link_by_table($to, $section); + if( $complete_url ) { + DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ", + $complete_url, "\n (Returning that.)\n"; + return $complete_url; + } else { + DEBUG > 4 and print " resolve_pod_link_by_table(T,S)", + " didn't return anything interesting.\n"; + } + } + + if(defined $to and length $to) { + # Give this routine first hack again + my $there = $self->resolve_pod_link_by_table($to); + if(defined $there and length $there) { + DEBUG > 1 + and print "resolve_pod_link_by_table(T) gives $there\n"; + } else { + $there = + $self->resolve_pod_page_link($to, $section); + # (I pass it the section value, but I don't see a + # particular reason it'd use it.) + DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n"; + unless( defined $there and length $there ) { + DEBUG and print "Can't resolve $to\n"; + return undef; + } + # resolve_pod_page_link returning undef is how it + # can signal that it gives up on making a link + } + $to = $there; + } + + #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n"; + + my $out = (defined $to and length $to) ? $to : ''; + $out .= "#" . $section if defined $section and length $section; + + unless(length $out) { # sanity check + DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n", + $to || "(nil)", $section || "(nil)"; + return undef; + } + + DEBUG and print "Resolved to $out\n"; + return $out; +} + + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub section_escape { + my($self, $section) = @_; + return $self->section_url_escape( + $self->section_name_tidy($section) + ); +} + +sub section_name_tidy { + my($self, $section) = @_; + $section =~ tr/ /_/; + $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters + $section = $self->unicode_escape_url($section); + $section = '_' unless length $section; + return $section; +} + +sub section_url_escape { shift->general_url_escape(@_) } +sub pagepath_url_escape { shift->general_url_escape(@_) } +sub manpage_url_escape { shift->general_url_escape(@_) } + +sub general_url_escape { + my($self, $string) = @_; + + $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg; + # express Unicode things as urlencode(utf(orig)). + + # A pretty conservative escaping, behoovey even for query components + # of a URL (see RFC 2396) + + $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg; + # Yes, stipulate the list without a range, so that this can work right on + # all charsets that this module happens to run under. + # Altho, hmm, what about that ord? Presumably that won't work right + # under non-ASCII charsets. Something should be done + # about that, I guess? + + return $string; +} + +#-------------------------------------------------------------------------- +# +# Oh look, a yawning portal to Hell! Let's play touch football right by it! +# + +sub resolve_pod_page_link { + # resolve_pod_page_link must return a properly escaped URL + my $self = shift; + return $self->batch_mode() + ? $self->resolve_pod_page_link_batch_mode(@_) + : $self->resolve_pod_page_link_singleton_mode(@_) + ; +} + +sub resolve_pod_page_link_singleton_mode { + my($self, $it) = @_; + return undef unless defined $it and length $it; + my $url = $self->pagepath_url_escape($it); + + $url =~ s{::$}{}s; # probably never comes up anyway + $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM? + + return undef unless length $url; + return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix; +} + +sub resolve_pod_page_link_batch_mode { + my($self, $to) = @_; + DEBUG > 1 and print " During batch mode, resolving $to ...\n"; + my @path = grep length($_), split m/::/s, $to, -1; + unless( @path ) { # sanity + DEBUG and print "Very odd! Splitting $to gives (nil)!\n"; + return undef; + } + $self->batch_mode_rectify_path(\@path); + my $out = join('/', map $self->pagepath_url_escape($_), @path) + . $HTML_EXTENSION; + DEBUG > 1 and print " => $out\n"; + return $out; +} + +sub batch_mode_rectify_path { + my($self, $pathbits) = @_; + my $level = $self->batch_mode_current_level; + $level--; # how many levels up to go to get to the root + if($level < 1) { + unshift @$pathbits, '.'; # just to be pretty + } else { + unshift @$pathbits, ('..') x $level; + } + return; +} + +sub resolve_man_page_link { + my ($self, $to, $frag) = @_; + my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/; + + return undef unless defined $page and length $page; + $section ||= 1; + + return $self->man_url_prefix . "$section/" + . $self->manpage_url_escape($page) + . $self->man_url_postfix; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub resolve_pod_link_by_table { + # A crazy hack to allow specifying custom L<foo> => URL mappings + + return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut + + my($self, $to, $section) = @_; + + # TODO: add a method that actually populates podhtml_LOT from a file? + + if(defined $section) { + $to = '' unless defined $to and length $to; + return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef! + } else { + return $self->{'podhtml_LOT'}{$to}; # quite possibly undef! + } + return; +} + +########################################################################### + +sub linearize_tokens { # self, tokens + my $self = shift; + my $out = ''; + + my $t; + while($t = shift @_) { + if(!ref $t or !UNIVERSAL::can($t, 'is_text')) { + $out .= $t; # a string, or some insane thing + } elsif($t->is_text) { + $out .= $t->text; + } elsif($t->is_start and $t->tag eq 'X') { + # Ignore until the end of this X<...> sequence: + my $x_open = 1; + while($x_open) { + next if( ($t = shift @_)->is_text ); + if( $t->is_start and $t->tag eq 'X') { ++$x_open } + elsif($t->is_end and $t->tag eq 'X') { --$x_open } + } + } + } + return undef if length $out > $Linearization_Limit; + return $out; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub unicode_escape_url { + my($self, $string) = @_; + $string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg; + # Turn char 1234 into "(1234)" + return $string; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub esc { # a function. + if(defined wantarray) { + if(wantarray) { + @_ = splice @_; # break aliasing + } else { + my $x = shift; + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + return $x; + } + } + foreach my $x (@_) { + # Escape things very cautiously: + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg + if defined $x; + # Leave out "- so that "--" won't make it thru in X-generated comments + # with text in them. + + # Yes, stipulate the list without a range, so that this can work right on + # all charsets that this module happens to run under. + # Altho, hmm, what about that ord? Presumably that won't work right + # under non-ASCII charsets. Something should be done about that. + } + return @_; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +1; +__END__ + +=head1 NAME + +Pod::Simple::HTML - convert Pod to HTML + +=head1 SYNOPSIS + + perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod + + +=head1 DESCRIPTION + +This class is for making an HTML rendering of a Pod document. + +This is a subclass of L<Pod::Simple::PullParser> and inherits all its +methods (and options). + +Note that if you want to do a batch conversion of a lot of Pod +documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>. + + + +=head1 CALLING FROM THE COMMAND LINE + +TODO + + perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html + + + +=head1 CALLING FROM PERL + +TODO make a new object, set any options, and use parse_from_file + + +=head1 METHODS + +TODO +all (most?) accessorized methods + + +=head1 SUBCLASSING + +TODO + + can just set any of: html_css html_javascript title_prefix + 'html_header_before_title', + 'html_header_after_title', + 'html_footer', + +maybe override do_pod_link + +maybe override do_beginning do_end + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::HTMLBatch> + +TODO: a corpus of sample Pod input and HTML output? Or common +idioms? + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002-2004 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 ACKNOWLEDGEMENTS + +Thanks to L<Hurricane Electrict|http://he.net/> for permission to use its +L<Linux man pages online|http://man.he.net/> site for man page links. + +Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the +site for Perl module links. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm new file mode 100644 index 00000000000..227c23b7f9f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm @@ -0,0 +1,1370 @@ + +require 5; +package Pod::Simple::HTMLBatch; +use strict; +use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION + $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA +); +$VERSION = '3.14'; +@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! + +# TODO: nocontents stylesheets. Strike some of the color variations? + +use Pod::Simple::HTML (); +BEGIN {*esc = \&Pod::Simple::HTML::esc } +use File::Spec (); + +use Pod::Simple::Search; +$SEARCH_CLASS ||= 'Pod::Simple::Search'; + +BEGIN { + if(defined &DEBUG) { } # no-op + elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } + else { *DEBUG = sub () {0}; } +} + +$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; +# flag to occasionally sleep for $SLEEPY - 1 seconds. + +$HTML_RENDER_CLASS ||= "Pod::Simple::HTML"; + +# +# Methods beginning with "_" are particularly internal and possibly ugly. +# + +Pod::Simple::_accessorize( __PACKAGE__, + 'verbose', # how verbose to be during batch conversion + 'html_render_class', # what class to use to render + 'search_class', # what to use to search for POD documents + 'contents_file', # If set, should be the name of a file (in current directory) + # to write the list of all modules to + 'index', # will set $htmlpage->index(...) to this (true or false) + 'progress', # progress object + 'contents_page_start', 'contents_page_end', + + 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad', + 'no_contents_links', # set to true to suppress automatic adding of << links. + '_contents', +); + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# Just so we can run from the command line more easily +sub go { + @ARGV == 2 or die sprintf( + "Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n", + __PACKAGE__, __PACKAGE__, + ); + + if(defined($ARGV[1]) and length($ARGV[1])) { + my $d = $ARGV[1]; + -e $d or die "I see no output directory named \"$d\"\nAborting"; + -d $d or die "But \"$d\" isn't a directory!\nAborting"; + -w $d or die "Directory \"$d\" isn't writeable!\nAborting"; + } + + __PACKAGE__->batch_convert(@ARGV); +} +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + +sub new { + my $new = bless {}, ref($_[0]) || $_[0]; + $new->html_render_class($HTML_RENDER_CLASS); + $new->search_class($SEARCH_CLASS); + $new->verbose(1 + DEBUG); + $new->_contents([]); + + $new->index(1); + + $new-> _css_wad([]); $new->css_flurry(1); + $new->_javascript_wad([]); $new->javascript_flurry(1); + + $new->contents_file( + 'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION) + ); + + $new->contents_page_start( join "\n", grep $_, + $Pod::Simple::HTML::Doctype_decl, + "<html><head>", + "<title>Perl Documentation</title>", + $Pod::Simple::HTML::Content_decl, + "</head>", + "\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n" + ); # override if you need a different title + + + $new->contents_page_end( sprintf( + "\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n", + esc( + ref($new), + eval {$new->VERSION} || $VERSION, + $], scalar(gmtime), scalar(localtime), + ))); + + return $new; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub muse { + my $self = shift; + if($self->verbose) { + print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n"; + } + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub batch_convert { + my($self, $dirs, $outdir) = @_; + $self ||= __PACKAGE__; # tolerate being called as an optionless function + $self = $self->new unless ref $self; # tolerate being used as a class method + + if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) { + $dirs = ''; + } elsif(ref $dirs) { + # OK, it's an explicit set of dirs to scan, specified as an arrayref. + } else { + # OK, it's an explicit set of dirs to scan, specified as a + # string like "/thing:/also:/whatever/perl" (":"-delim, as usual) + # or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!) + require Config; + my $ps = quotemeta( $Config::Config{'path_sep'} || ":" ); + $dirs = [ grep length($_), split qr/$ps/, $dirs ]; + } + + $outdir = $self->filespecsys->curdir + unless defined $outdir and length $outdir; + + $self->_batch_convert_main($dirs, $outdir); +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _batch_convert_main { + my($self, $dirs, $outdir) = @_; + # $dirs is either false, or an arrayref. + # $outdir is a pathspec. + + $self->{'_batch_start_time'} ||= time(); + + $self->muse( "= ", scalar(localtime) ); + $self->muse( "Starting batch conversion to \"$outdir\"" ); + + my $progress = $self->progress; + if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) { + require Pod::Simple::Progress; + $progress = Pod::Simple::Progress->new( + ($self->verbose < 2) ? () # Default omission-delay + : ($self->verbose == 2) ? 1 # Reduce the omission-delay + : 0 # Eliminate the omission-delay + ); + $self->progress($progress); + } + + if($dirs) { + $self->muse(scalar(@$dirs), " dirs to scan: @$dirs"); + } else { + $self->muse("Scanning \@INC. This could take a minute or two."); + } + my $mod2path = $self->find_all_pods($dirs ? $dirs : ()); + $self->muse("Done scanning."); + + my $total = keys %$mod2path; + unless($total) { + $self->muse("No pod found. Aborting batch conversion.\n"); + return $self; + } + + $progress and $progress->goal($total); + $self->muse("Now converting pod files to HTML.", + ($total > 25) ? " This will take a while more." : () + ); + + $self->_spray_css( $outdir ); + $self->_spray_javascript( $outdir ); + + $self->_do_all_batch_conversions($mod2path, $outdir); + + $progress and $progress->done(sprintf ( + "Done converting %d files.", $self->{"__batch_conv_page_count"} + )); + return $self->_batch_convert_finish($outdir); + return $self; +} + + +sub _do_all_batch_conversions { + my($self, $mod2path, $outdir) = @_; + $self->{"__batch_conv_page_count"} = 0; + + foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) { + $self->_do_one_batch_conversion($module, $mod2path, $outdir); + sleep($SLEEPY - 1) if $SLEEPY; + } + + return; +} + +sub _batch_convert_finish { + my($self, $outdir) = @_; + $self->write_contents_file($outdir); + $self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done."); + $self->muse( "= ", scalar(localtime) ); + $self->progress and $self->progress->done("All done!"); + return; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _do_one_batch_conversion { + my($self, $module, $mod2path, $outdir, $outfile) = @_; + + my $retval; + my $total = scalar keys %$mod2path; + my $infile = $mod2path->{$module}; + my @namelets = grep m/\S/, split "::", $module; + # this can stick around in the contents LoL + my $depth = scalar @namelets; + die "Contentless thingie?! $module $infile" unless @namelets; #sanity + + $outfile ||= do { + my @n = @namelets; + $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION; + $self->filespecsys->catfile( $outdir, @n ); + }; + + my $progress = $self->progress; + + my $page = $self->html_render_class->new; + if(DEBUG > 5) { + $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ", + ref($page), " render ($depth) $module => $outfile"); + } elsif(DEBUG > 2) { + $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile") + } + + # Give each class a chance to init the converter: + $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth) + if $page->can('batch_mode_page_object_init'); + # Init for the index (TOC), too. + $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth) + if $self->can('batch_mode_page_object_init'); + + # Now get busy... + $self->makepath($outdir => \@namelets); + + $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module"); + + if( $retval = $page->parse_from_file($infile, $outfile) ) { + ++ $self->{"__batch_conv_page_count"} ; + $self->note_for_contents_file( \@namelets, $infile, $outfile ); + } else { + $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false."); + } + + $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth) + if $page->can('batch_mode_page_object_kill'); + # The following isn't a typo. Note that it switches $self and $page. + $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth) + if $self->can('batch_mode_page_object_kill'); + + DEBUG > 4 and printf "%s %sb < $infile %s %sb\n", + $outfile, -s $outfile, $infile, -s $infile + ; + + undef($page); + return $retval; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' } + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub note_for_contents_file { + my($self, $namelets, $infile, $outfile) = @_; + + # I think the infile and outfile parts are never used. -- SMB + # But it's handy to have them around for debugging. + + if( $self->contents_file ) { + my $c = $self->_contents(); + push @$c, + [ join("::", @$namelets), $infile, $outfile, $namelets ] + # 0 1 2 3 + ; + DEBUG > 3 and print "Noting @$c[-1]\n"; + } + return; +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub write_contents_file { + my($self, $outdir) = @_; + my $outfile = $self->_contents_filespec($outdir) || return; + + $self->muse("Preparing list of modules for ToC"); + + my($toplevel, # maps toplevelbit => [all submodules] + $toplevel_form_freq, # ends up being 'foo' => 'Foo' + ) = $self->_prep_contents_breakdown; + + my $Contents = eval { $self->_wopen($outfile) }; + if( $Contents ) { + $self->muse( "Writing contents file $outfile" ); + } else { + warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all"; + return; + } + + $self->_write_contents_start( $Contents, $outfile, ); + $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq ); + $self->_write_contents_end( $Contents, $outfile, ); + return $outfile; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _write_contents_start { + my($self, $Contents, $outfile) = @_; + my $starter = $self->contents_page_start || ''; + + { + my $css_wad = $self->_css_wad_to_markup(1); + if( $css_wad ) { + $starter =~ s{(</head>)}{\n$css_wad\n$1}i; # otherwise nevermind + } + + my $javascript_wad = $self->_javascript_wad_to_markup(1); + if( $javascript_wad ) { + $starter =~ s{(</head>)}{\n$javascript_wad\n$1}i; # otherwise nevermind + } + } + + unless(print $Contents $starter, "<dl class='superindex'>\n" ) { + warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; + close($Contents); + return 0; + } + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _write_contents_middle { + my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_; + + foreach my $t (sort keys %$toplevel2submodules) { + my @downlines = sort {$a->[-1] cmp $b->[-1]} + @{ $toplevel2submodules->{$t} }; + + printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n], + esc( $t, $toplevel_form_freq->{$t} ) + ; + + my($path, $name); + foreach my $e (@downlines) { + $name = $e->[0]; + $path = join( "/", '.', esc( @{$e->[3]} ) ) + . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION); + print $Contents qq{ <a href="$path">}, esc($name), "</a> \n"; + } + print $Contents "</dd>\n\n"; + } + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _write_contents_end { + my($self, $Contents, $outfile) = @_; + unless( + print $Contents "</dl>\n", + $self->contents_page_end || '', + ) { + warn "Couldn't write to $outfile: $!"; + } + close($Contents) or warn "Couldn't close $outfile: $!"; + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _prep_contents_breakdown { + my($self) = @_; + my $contents = $self->_contents; + my %toplevel; # maps lctoplevelbit => [all submodules] + my %toplevel_form_freq; # ends up being 'foo' => 'Foo' + # (mapping anycase forms to most freq form) + + foreach my $entry (@$contents) { + my $toplevel = + $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs' + # group all the perlwhatever docs together + : $entry->[3][0] # normal case + ; + ++$toplevel_form_freq{ lc $toplevel }{ $toplevel }; + push @{ $toplevel{ lc $toplevel } }, $entry; + push @$entry, lc($entry->[0]); # add a sort-order key to the end + } + + foreach my $toplevel (sort keys %toplevel) { + my $fgroup = $toplevel_form_freq{$toplevel}; + $toplevel_form_freq{$toplevel} = + ( + sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b } + keys %$fgroup + # This hash is extremely unlikely to have more than 4 members, so this + # sort isn't so very wasteful + )[0]; + } + + return(\%toplevel, \%toplevel_form_freq) if wantarray; + return \%toplevel; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _contents_filespec { + my($self, $outdir) = @_; + my $outfile = $self->contents_file; + return unless $outfile; + return $self->filespecsys->catfile( $outdir, $outfile ); +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub makepath { + my($self, $outdir, $namelets) = @_; + return unless @$namelets > 1; + for my $i (0 .. ($#$namelets - 1)) { + my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] ); + if(-e $dir) { + die "$dir exists but not as a directory!?" unless -d $dir; + next; + } + DEBUG > 3 and print " Making $dir\n"; + mkdir $dir, 0777 + or die "Can't mkdir $dir: $!\nAborting" + ; + } + return; +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub batch_mode_page_object_init { + my $self = shift; + my($page, $module, $infile, $outfile, $depth) = @_; + + # TODO: any further options to percolate onto this new object here? + + $page->default_title($module); + $page->index( $self->index ); + + $page->html_css( $self-> _css_wad_to_markup($depth) ); + $page->html_javascript( $self->_javascript_wad_to_markup($depth) ); + + $self->add_header_backlink($page, $module, $infile, $outfile, $depth); + $self->add_footer_backlink($page, $module, $infile, $outfile, $depth); + + + return $self; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub add_header_backlink { + my $self = shift; + return if $self->no_contents_links; + my($page, $module, $infile, $outfile, $depth) = @_; + $page->html_header_after_title( join '', + $page->html_header_after_title || '', + + qq[<p class="backlinktop"><b><a name="___top" href="], + $self->url_up_to_contents($depth), + qq[" accesskey="1" title="All Documents"><<</a></b></p>\n], + ) + if $self->contents_file + ; + return; +} + +sub add_footer_backlink { + my $self = shift; + return if $self->no_contents_links; + my($page, $module, $infile, $outfile, $depth) = @_; + $page->html_footer( join '', + qq[<p class="backlinkbottom"><b><a name="___bottom" href="], + $self->url_up_to_contents($depth), + qq[" title="All Documents"><<</a></b></p>\n], + + $page->html_footer || '', + ) + if $self->contents_file + ; + return; +} + +sub url_up_to_contents { + my($self, $depth) = @_; + --$depth; + return join '/', ('..') x $depth, esc($self->contents_file); +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub find_all_pods { + my($self, $dirs) = @_; + # You can override find_all_pods in a subclass if you want to + # do extra filtering or whatnot. But for the moment, we just + # pass to modnames2paths: + return $self->modnames2paths($dirs); +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub modnames2paths { # return a hashref mapping modulenames => paths + my($self, $dirs) = @_; + + my $m2p; + { + my $search = $self->search_class->new; + DEBUG and print "Searching via $search\n"; + $search->verbose(1) if DEBUG > 10; + $search->progress( $self->progress->copy->goal(0) ) if $self->progress; + $search->shadows(0); # don't bother noting shadowed files + $search->inc( $dirs ? 0 : 1 ); + $search->survey( $dirs ? @$dirs : () ); + $m2p = $search->name2path; + die "What, no name2path?!" unless $m2p; + } + + $self->muse("That's odd... no modules found!") unless keys %$m2p; + if( DEBUG > 4 ) { + print "Modules found (name => path):\n"; + foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) { + print " $m $$m2p{$m}\n"; + } + print "(total ", scalar(keys %$m2p), ")\n\n"; + } elsif( DEBUG ) { + print "Found ", scalar(keys %$m2p), " modules.\n"; + } + $self->muse( "Found ", scalar(keys %$m2p), " modules." ); + + # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref + return $m2p; +} + +#=========================================================================== + +sub _wopen { + # this is abstracted out so that the daemon class can override it + my($self, $outpath) = @_; + require Symbol; + my $out_fh = Symbol::gensym(); + DEBUG > 5 and print "Write-opening to $outpath\n"; + return $out_fh if open($out_fh, "> $outpath"); + require Carp; + Carp::croak("Can't write-open $outpath: $!"); +} + +#========================================================================== + +sub add_css { + my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_; + return unless $url; + unless($name) { + # cook up a reasonable name based on the URL + $name = $url; + if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) { + $name = $1; + $name =~ s/\.css//i; + } + } + $media ||= 'all'; + $content_type ||= 'text/css'; + + my $bunch = [$url, $name, $content_type, $media, $_code]; + if($is_default) { unshift @{ $self->_css_wad }, $bunch } + else { push @{ $self->_css_wad }, $bunch } + return; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _spray_css { + my($self, $outdir) = @_; + + return unless $self->css_flurry(); + $self->_gen_css_wad(); + + my $lol = $self->_css_wad; + foreach my $chunk (@$lol) { + my $url = $chunk->[0]; + my $outfile; + if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) { + $outfile = $self->filespecsys->catfile( $outdir, "$1" ); + DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n"; + } else { + DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n"; + # Requires no further attention. + next; + } + + #$self->muse( "Writing autogenerated CSS file $outfile" ); + my $Cssout = $self->_wopen($outfile); + print $Cssout ${$chunk->[-1]} + or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; + close($Cssout); + DEBUG > 5 and print "Wrote $outfile\n"; + } + + return; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _css_wad_to_markup { + my($self, $depth) = @_; + + my @css = @{ $self->_css_wad || return '' }; + return '' unless @css; + + my $rel = 'stylesheet'; + my $out = ''; + + --$depth; + my $uplink = $depth ? ('../' x $depth) : ''; + + foreach my $chunk (@css) { + next unless $chunk and @$chunk; + + my( $url1, $url2, $title, $type, $media) = ( + $self->_maybe_uplink( $chunk->[0], $uplink ), + esc(grep !ref($_), @$chunk) + ); + + $out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n}; + + $rel = 'alternate stylesheet'; # alternates = all non-first iterations + } + return $out; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +sub _maybe_uplink { + # if the given URL looks relative, return the given uplink string -- + # otherwise return emptystring + my($self, $url, $uplink) = @_; + ($url =~ m{^\./} or $url !~ m{[/\:]} ) + ? $uplink + : '' + # qualify it, if/as needed +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +sub _gen_css_wad { + my $self = $_[0]; + my $css_template = $self->_css_template; + foreach my $variation ( + + # Commented out for sake of concision: + # + # 011n=black_with_red_on_white + # 001n=black_with_yellow_on_white + # 101n=black_with_green_on_white + # 110=white_with_yellow_on_black + # 010=white_with_green_on_black + # 011=white_with_blue_on_black + # 100=white_with_red_on_black + '110n=blkbluw', # black_with_blue_on_white + '010n=blkmagw', # black_with_magenta_on_white + '100n=blkcynw', # black_with_cyan_on_white + '101=whtprpk', # white_with_purple_on_black + '001=whtnavk', # white_with_navy_blue_on_black + '010a=grygrnk', # grey_with_green_on_black + '010b=whtgrng', # white_with_green_on_grey + '101an=blkgrng', # black_with_green_on_grey + '101bn=grygrnw', # grey_with_green_on_white + ) { + + my $outname = $variation; + my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3) + if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s; + @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op! + + my $this_css = + "/* This file is autogenerated. Do not edit. $variation */\n\n" + . $css_template; + + # Only look at three-digitty colors, for now at least. + if( $flipmode =~ m/n/ ) { + $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg; + $this_css =~ s/\bthin\b/medium/g; + } + $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b> + < join '', '#', ($1,$2,$3)[@swap] >eg if @swap; + + if( $flipmode =~ m/a/) + { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey + elsif($flipmode =~ m/b/) + { $this_css =~ s/#000\b/#666/gi } # white -> light grey + + my $name = $outname; + $name =~ tr/-_/ /; + $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); + } + + # Now a few indexless variations: + foreach my $variation ( + 'blkbluw', # black_with_blue_on_white + 'whtpurk', # white_with_purple_on_black + 'whtgrng', # white_with_green_on_grey + 'grygrnw', # grey_with_green_on_white + ) { + my $outname = "$variation\_"; + my $this_css = join "\n", + "/* This file is autogenerated. Do not edit. $outname */\n", + "\@import url(\"./_$variation.css\");", + ".indexgroup { display: none; }", + "\n", + ; + my $name = $outname; + $name =~ tr/-_/ /; + $self->add_css( "$outname.css", 0, $name, 0, 0, \$this_css); + } + + return; +} + +sub _color_negate { + my $x = lc $_[0]; + $x =~ tr[0123456789abcdef] + [fedcba9876543210]; + return $x; +} + +#=========================================================================== + +sub add_javascript { + my($self, $url, $content_type, $_code) = @_; + return unless $url; + push @{ $self->_javascript_wad }, [ + $url, $content_type || 'text/javascript', $_code + ]; + return; +} + +sub _spray_javascript { + my($self, $outdir) = @_; + return unless $self->javascript_flurry(); + $self->_gen_javascript_wad(); + + my $lol = $self->_javascript_wad; + foreach my $script (@$lol) { + my $url = $script->[0]; + my $outfile; + + if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) { + $outfile = $self->filespecsys->catfile( $outdir, "$1" ); + DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n"; + } else { + DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n"; + next; + } + + #$self->muse( "Writing JavaScript file $outfile" ); + my $Jsout = $self->_wopen($outfile); + + print $Jsout ${$script->[-1]} + or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; + close($Jsout); + DEBUG > 5 and print "Wrote $outfile\n"; + } + + return; +} + +sub _gen_javascript_wad { + my $self = $_[0]; + my $js_code = $self->_javascript || return; + $self->add_javascript( "_podly.js", 0, \$js_code); + return; +} + +sub _javascript_wad_to_markup { + my($self, $depth) = @_; + + my @scripts = @{ $self->_javascript_wad || return '' }; + return '' unless @scripts; + + my $out = ''; + + --$depth; + my $uplink = $depth ? ('../' x $depth) : ''; + + foreach my $s (@scripts) { + next unless $s and @$s; + + my( $url1, $url2, $type, $media) = ( + $self->_maybe_uplink( $s->[0], $uplink ), + esc(grep !ref($_), @$s) + ); + + $out .= qq{<script type="$type" src="$url1$url2"></script>\n}; + } + return $out; +} + +#=========================================================================== + +sub _css_template { return $CSS } +sub _javascript { return $JAVASCRIPT } + +$CSS = <<'EOCSS'; +/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */ + +@media all { .hide { display: none; } } + +@media print { + .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none } + + * { + border-color: black !important; + color: black !important; + background-color: transparent !important; + background-image: none !important; + } + + dl.superindex > dd { + word-spacing: .6em; + } +} + +@media aural, braille, embossed { + div.indexgroup { display: none; } /* Too noisy, don't you think? */ + dl.superindex > dt:before { content: "Group "; } + dl.superindex > dt:after { content: " contains:"; } + .backlinktop a:before { content: "Back to contents"; } + .backlinkbottom a:before { content: "Back to contents"; } +} + +@media aural { + dl.superindex > dt { pause-before: 600ms; } +} + +@media screen, tty, tv, projection { + .noscreen { display: none; } + + a:link { color: #7070ff; text-decoration: underline; } + a:visited { color: #e030ff; text-decoration: underline; } + a:active { color: #800000; text-decoration: underline; } + body.contentspage a { text-decoration: none; } + a.u { color: #fff !important; text-decoration: none; } + + body.pod { + margin: 0 5px; + color: #fff; + background-color: #000; + } + + body.pod h1, body.pod h2, body.pod h3, body.pod h4 { + font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; + font-weight: normal; + margin-top: 1.2em; + margin-bottom: .1em; + border-top: thin solid transparent; + /* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */ + } + + body.pod h1 { border-top-color: #0a0; } + body.pod h2 { border-top-color: #080; } + body.pod h3 { border-top-color: #040; } + body.pod h4 { border-top-color: #010; } + + p.backlinktop + h1 { border-top: none; margin-top: 0em; } + p.backlinktop + h2 { border-top: none; margin-top: 0em; } + p.backlinktop + h3 { border-top: none; margin-top: 0em; } + p.backlinktop + h4 { border-top: none; margin-top: 0em; } + + body.pod dt { + font-size: 105%; /* just a wee bit more than normal */ + } + + .indexgroup { font-size: 80%; } + + .backlinktop, .backlinkbottom { + margin-left: -5px; + margin-right: -5px; + background-color: #040; + border-top: thin solid #050; + border-bottom: thin solid #050; + } + + .backlinktop a, .backlinkbottom a { + text-decoration: none; + color: #080; + background-color: #000; + border: thin solid #0d0; + } + .backlinkbottom { margin-bottom: 0; padding-bottom: 0; } + .backlinktop { margin-top: 0; padding-top: 0; } + + body.contentspage { + color: #fff; + background-color: #000; + } + + body.contentspage h1 { + color: #0d0; + margin-left: 1em; + margin-right: 1em; + text-indent: -.9em; + font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; + font-weight: normal; + border-top: thin solid #fff; + border-bottom: thin solid #fff; + text-align: center; + } + + dl.superindex > dt { + font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; + font-weight: normal; + font-size: 90%; + margin-top: .45em; + /* margin-bottom: -.15em; */ + } + dl.superindex > dd { + word-spacing: .6em; /* most important rule here! */ + } + dl.superindex > a:link { + text-decoration: none; + color: #fff; + } + + .contentsfooty { + border-top: thin solid #999; + font-size: 90%; + } + +} + +/* The End */ + +EOCSS + +#========================================================================== + +$JAVASCRIPT = <<'EOJAVASCRIPT'; + +// From http://www.alistapart.com/articles/alternate/ + +function setActiveStyleSheet(title) { + var i, a, main; + for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { + if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) { + a.disabled = true; + if(a.getAttribute("title") == title) a.disabled = false; + } + } +} + +function getActiveStyleSheet() { + var i, a; + for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { + if( a.getAttribute("rel").indexOf("style") != -1 + && a.getAttribute("title") + && !a.disabled + ) return a.getAttribute("title"); + } + return null; +} + +function getPreferredStyleSheet() { + var i, a; + for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { + if( a.getAttribute("rel").indexOf("style") != -1 + && a.getAttribute("rel").indexOf("alt") == -1 + && a.getAttribute("title") + ) return a.getAttribute("title"); + } + return null; +} + +function createCookie(name,value,days) { + if (days) { + var date = new Date(); + date.setTime(date.getTime()+(days*24*60*60*1000)); + var expires = "; expires="+date.toGMTString(); + } + else expires = ""; + document.cookie = name+"="+value+expires+"; path=/"; +} + +function readCookie(name) { + var nameEQ = name + "="; + var ca = document.cookie.split(';'); + for(var i=0 ; i < ca.length ; i++) { + var c = ca[i]; + while (c.charAt(0)==' ') c = c.substring(1,c.length); + if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length); + } + return null; +} + +window.onload = function(e) { + var cookie = readCookie("style"); + var title = cookie ? cookie : getPreferredStyleSheet(); + setActiveStyleSheet(title); +} + +window.onunload = function(e) { + var title = getActiveStyleSheet(); + createCookie("style", title, 365); +} + +var cookie = readCookie("style"); +var title = cookie ? cookie : getPreferredStyleSheet(); +setActiveStyleSheet(title); + +// The End + +EOJAVASCRIPT + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +1; +__END__ + + +=head1 NAME + +Pod::Simple::HTMLBatch - convert several Pod files to several HTML files + +=head1 SYNOPSIS + + perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out + + +=head1 DESCRIPTION + +This module is used for running batch-conversions of a lot of HTML +documents + +This class is NOT a subclass of Pod::Simple::HTML +(nor of bad old Pod::Html) -- although it uses +Pod::Simple::HTML for doing the conversion of each document. + +The normal use of this class is like so: + + use Pod::Simple::HTMLBatch; + my $batchconv = Pod::Simple::HTMLBatch->new; + $batchconv->some_option( some_value ); + $batchconv->some_other_option( some_other_value ); + $batchconv->batch_convert( \@search_dirs, $output_dir ); + +=head2 FROM THE COMMAND LINE + +Note that this class also provides +(but does not export) the function Pod::Simple::HTMLBatch::go. +This is basically just a shortcut for C<< +Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>. +It's meant to be handy for calling from the command line. + +However, the shortcut requires that you specify exactly two command-line +arguments, C<indirs> and C<outdir>. + +Example: + + % mkdir out_html + % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html + (to convert the pod from Perl's @INC + files under the directory ../htmlversion) + +(Note that the command line there contains a literal atsign-I-N-C. This +is handled as a special case by batch_convert, in order to save you having +to enter the odd-looking "" as the first command-line parameter when you +mean "just use whatever's in @INC".) + +Example: + + % mkdir ../seekrut + % chmod og-rx ../seekrut + % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion + (to convert the pod under the current dir into HTML + files under the directory ../htmlversion) + +Example: + + % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs . + (to convert all pod from happydocs into the current directory) + + + +=head1 MAIN METHODS + +=over + +=item $batchconv = Pod::Simple::HTMLBatch->new; + +This TODO + + +=item $batchconv->batch_convert( I<indirs>, I<outdir> ); + +this TODO + +=item $batchconv->batch_convert( undef , ...); + +=item $batchconv->batch_convert( q{@INC}, ...); + +These two values for I<indirs> specify that the normal Perl @INC + +=item $batchconv->batch_convert( \@dirs , ...); + +This specifies that the input directories are the items in +the arrayref C<\@dirs>. + +=item $batchconv->batch_convert( "somedir" , ...); + +This specifies that the director "somedir" is the input. +(This can be an absolute or relative path, it doesn't matter.) + +A common value you might want would be just "." for the current +directory: + + $batchconv->batch_convert( "." , ...); + + +=item $batchconv->batch_convert( 'somedir:someother:also' , ...); + +This specifies that you want the dirs "somedir", "somother", and "also" +scanned, just as if you'd passed the arrayref +C<[qw( somedir someother also)]>. Note that a ":"-separator is normal +under Unix, but Under MSWin, you'll need C<'somedir;someother;also'> +instead, since the pathsep on MSWin is ";" instead of ":". (And +I<that> is because ":" often comes up in paths, like +C<"c:/perl/lib">.) + +(Exactly what separator character should be used, is gotten from +C<$Config::Config{'path_sep'}>, via the L<Config> module.) + +=item $batchconv->batch_convert( ... , undef ); + +This specifies that you want the HTML output to go into the current +directory. + +(Note that a missing or undefined value means a different thing in +the first slot than in the second. That's so that C<batch_convert()> +with no arguments (or undef arguments) means "go from @INC, into +the current directory.) + +=item $batchconv->batch_convert( ... , 'somedir' ); + +This specifies that you want the HTML output to go into the +directory 'somedir'. +(This can be an absolute or relative path, it doesn't matter.) + +=back + + +Note that you can also call C<batch_convert> as a class method, +like so: + + Pod::Simple::HTMLBatch->batch_convert( ... ); + +That is just short for this: + + Pod::Simple::HTMLBatch-> new-> batch_convert(...); + +That is, it runs a conversion with default options, for +whatever inputdirs and output dir you specify. + + +=head2 ACCESSOR METHODS + +The following are all accessor methods -- that is, they don't do anything +on their own, but just alter the contents of the conversion object, +which comprises the options for this particular batch conversion. + +We show the "put" form of the accessors below (i.e., the syntax you use +for setting the accessor to a specific value). But you can also +call each method with no parameters to get its current value. For +example, C<< $self->contents_file() >> returns the current value of +the contents_file attribute. + +=over + + +=item $batchconv->verbose( I<nonnegative_integer> ); + +This controls how verbose to be during batch conversion, as far as +notes to STDOUT (or whatever is C<select>'d) about how the conversion +is going. If 0, no progress information is printed. +If 1 (the default value), some progress information is printed. +Higher values print more information. + + +=item $batchconv->index( I<true-or-false> ); + +This controls whether or not each HTML page is liable to have a little +table of contents at the top (which we call an "index" for historical +reasons). This is true by default. + + +=item $batchconv->contents_file( I<filename> ); + +If set, should be the name of a file (in the output directory) +to write the HTML index to. The default value is "index.html". +If you set this to a false value, no contents file will be written. + +=item $batchconv->contents_page_start( I<HTML_string> ); + +This specifies what string should be put at the beginning of +the contents page. +The default is a string more or less like this: + + <html> + <head><title>Perl Documentation</title></head> + <body class='contentspage'> + <h1>Perl Documentation</h1> + +=item $batchconv->contents_page_end( I<HTML_string> ); + +This specifies what string should be put at the end of the contents page. +The default is a string more or less like this: + + <p class='contentsfooty'>Generated by + Pod::Simple::HTMLBatch v3.01 under Perl v5.008 + <br >At Fri May 14 22:26:42 2004 GMT, + which is Fri May 14 14:26:42 2004 local time.</p> + + + +=item $batchconv->add_css( $url ); + +TODO + +=item $batchconv->add_javascript( $url ); + +TODO + +=item $batchconv->css_flurry( I<true-or-false> ); + +If true (the default value), we autogenerate some CSS files in the +output directory, and set our HTML files to use those. +TODO: continue + +=item $batchconv->javascript_flurry( I<true-or-false> ); + +If true (the default value), we autogenerate a JavaScript in the +output directory, and set our HTML files to use it. Currently, +the JavaScript is used only to get the browser to remember what +stylesheet it prefers. +TODO: continue + +=item $batchconv->no_contents_links( I<true-or-false> ); + +TODO + +=item $batchconv->html_render_class( I<classname> ); + +This sets what class is used for rendering the files. +The default is "Pod::Simple::HTML". If you set it to something else, +it should probably be a subclass of Pod::Simple::HTML, and you should +C<require> or C<use> that class so that's it's loaded before +Pod::Simple::HTMLBatch tries loading it. + +=item $batchconv->search_class( I<classname> ); + +This sets what class is used for searching for the files. +The default is "Pod::Simple::Search". If you set it to something else, +it should probably be a subclass of Pod::Simple::Search, and you should +C<require> or C<use> that class so that's it's loaded before +Pod::Simple::HTMLBatch tries loading it. + +=back + + + + +=head1 NOTES ON CUSTOMIZATION + +TODO + + call add_css($someurl) to add stylesheet as alternate + call add_css($someurl,1) to add as primary stylesheet + + call add_javascript + + subclass Pod::Simple::HTML and set $batchconv->html_render_class to + that classname + and maybe override + $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth) + or maybe override + $batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth) + subclass Pod::Simple::Search and set $batchconv->search_class to + that classname + + + +=head1 ASK ME! + +If you want to do some kind of big pod-to-HTML version with some +particular kind of option that you don't see how to achieve using this +module, email me (C<sburke@cpan.org>) and I'll probably have a good idea +how to do it. For reasons of concision and energetic laziness, some +methods and options in this module (and the dozen modules it depends on) +are undocumented; but one of those undocumented bits might be just what +you're looking for. + + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm new file mode 100644 index 00000000000..f78de90144f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm @@ -0,0 +1,104 @@ + +require 5; +package Pod::Simple::HTMLLegacy; +use strict; + +use vars qw($VERSION); +use Getopt::Long; + +$VERSION = "5.01"; + +#-------------------------------------------------------------------------- +# +# This class is meant to thinly emulate bad old Pod::Html +# +# TODO: some basic docs + +sub pod2html { + my @args = (@_); + + my( $verbose, $infile, $outfile, $title ); + my $index = 1; + + { + my($help); + + my($netscape); # dummy + local @ARGV = @args; + GetOptions( + "help" => \$help, + "verbose!" => \$verbose, + "infile=s" => \$infile, + "outfile=s" => \$outfile, + "title=s" => \$title, + "index!" => \$index, + + "netscape!" => \$netscape, + ) or return bad_opts(@args); + bad_opts(@args) if @ARGV; # it should be all switches! + return help_message() if $help; + } + + for($infile, $outfile) { $_ = undef unless defined and length } + + if($verbose) { + warn sprintf "%s version %s\n", __PACKAGE__, $VERSION; + warn "OK, processed args [@args] ...\n"; + warn sprintf + " Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n", + map defined($_) ? $_ : "(nil)", + $verbose, $index, $infile, $outfile, $title, + ; + *Pod::Simple::HTML::DEBUG = sub(){1}; + } + require Pod::Simple::HTML; + Pod::Simple::HTML->VERSION(3); + + die "No such input file as $infile\n" + if defined $infile and ! -e $infile; + + + my $pod = Pod::Simple::HTML->new; + $pod->force_title($title) if defined $title; + $pod->index($index); + return $pod->parse_from_file($infile, $outfile); +} + +#-------------------------------------------------------------------------- + +sub bad_opts { die _help_message(); } +sub help_message { print STDOUT _help_message() } + +#-------------------------------------------------------------------------- + +sub _help_message { + + join '', + +"[", __PACKAGE__, " version ", $VERSION, qq~] +Usage: pod2html --help --infile=<name> --outfile=<name> + --verbose --index --noindex + +Options: + --help - prints this message. + --[no]index - generate an index at the top of the resulting html + (default behavior). + --infile - filename for the pod to convert (input taken from stdin + by default). + --outfile - filename for the resulting html file (output sent to + stdout by default). + --title - title that will appear in resulting html file. + --[no]verbose - self-explanatory (off by default). + +Note that pod2html is DEPRECATED, and this version implements only + some of the options known to older versions. +For more information, see 'perldoc pod2html'. +~; + +} + +1; +__END__ + +OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!! + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm new file mode 100644 index 00000000000..e426b2c547f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm @@ -0,0 +1,174 @@ + +require 5; +package Pod::Simple::LinkSection; + # Based somewhat dimly on Array::Autojoin +use vars qw($VERSION ); +$VERSION = '3.14'; + +use strict; +use Pod::Simple::BlackBox; +use vars qw($VERSION ); +$VERSION = '3.14'; + +use overload( # So it'll stringify nice + '""' => \&Pod::Simple::BlackBox::stringify_lol, + 'bool' => \&Pod::Simple::BlackBox::stringify_lol, + # '.=' => \&tack_on, # grudgingly support + + 'fallback' => 1, # turn on cleverness +); + +sub tack_on { + $_[0] = ['', {}, "$_[0]" ]; + return $_[0][2] .= $_[1]; +} + +sub as_string { + goto &Pod::Simple::BlackBox::stringify_lol; +} +sub stringify { + goto &Pod::Simple::BlackBox::stringify_lol; +} + +sub new { + my $class = shift; + $class = ref($class) || $class; + my $new; + if(@_ == 1) { + if (!ref($_[0] || '')) { # most common case: one bare string + return bless ['', {}, $_[0] ], $class; + } elsif( ref($_[0] || '') eq 'ARRAY') { + $new = [ @{ $_[0] } ]; + } else { + Carp::croak( "$class new() doesn't know to clone $new" ); + } + } else { # misc stuff + $new = [ '', {}, @_ ]; + } + + # By now it's a treelet: [ 'foo', {}, ... ] + foreach my $x (@$new) { + if(ref($x || '') eq 'ARRAY') { + $x = $class->new($x); # recurse + } elsif(ref($x || '') eq 'HASH') { + $x = { %$x }; + } + # otherwise leave it. + } + + return bless $new, $class; +} + +# Not much in this class is likely to be link-section specific -- +# but it just so happens that link-sections are about the only treelets +# that are exposed to the user. + +1; + +__END__ + +# TODO: let it be an option whether a given subclass even wants little treelets? + + +__END__ + +=head1 NAME + +Pod::Simple::LinkSection -- represent "section" attributes of L codes + +=head1 SYNOPSIS + + # a long story + +=head1 DESCRIPTION + +This class is not of interest to general users. + +Pod::Simple uses this class for representing the value of the +"section" attribute of "L" start-element events. Most applications +can just use the normal stringification of objects of this class; +they stringify to just the text content of the section, +such as "foo" for +C<< LZ<><Stuff/foo> >>, and "bar" for +C<< LZ<><Stuff/bIZ<><ar>> >>. + +However, anyone particularly interested in getting the full value of +the treelet, can just traverse the content of the treeleet +@$treelet_object. To wit: + + + % perl -MData::Dumper -e + "use base qw(Pod::Simple::Methody); + sub start_L { print Dumper($_[1]{'section'} ) } + __PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>') + " +Output: + $VAR1 = bless( [ + '', + {}, + 'b', + bless( [ + 'I', + {}, + 'ar' + ], 'Pod::Simple::LinkSection' ), + 'baz' + ], 'Pod::Simple::LinkSection' ); + +But stringify it and you get just the text content: + + % perl -MData::Dumper -e + "use base qw(Pod::Simple::Methody); + sub start_L { print Dumper( '' . $_[1]{'section'} ) } + __PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>') + " +Output: + $VAR1 = 'barbaz'; + + +=head1 SEE ALSO + +L<Pod::Simple> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2004 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm new file mode 100644 index 00000000000..bed3e8662b2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm @@ -0,0 +1,152 @@ + +require 5; +package Pod::Simple::Methody; +use strict; +use Pod::Simple (); +use vars qw(@ISA $VERSION); +$VERSION = '3.14'; +@ISA = ('Pod::Simple'); + +# Yes, we could use named variables, but I want this to be impose +# as little an additional performance hit as possible. + +sub _handle_element_start { + $_[1] =~ tr/-:./__/; + ( $_[0]->can( 'start_' . $_[1] ) + || return + )->( + $_[0], $_[2] + ); +} + +sub _handle_text { + ( $_[0]->can( 'handle_text' ) + || return + )->( + @_ + ); +} + +sub _handle_element_end { + $_[1] =~ tr/-:./__/; + ( $_[0]->can( 'end_' . $_[1] ) + || return + )->( + $_[0] + ); +} + +1; + + +__END__ + +=head1 NAME + +Pod::Simple::Methody -- turn Pod::Simple events into method calls + +=head1 SYNOPSIS + + require 5; + use strict; + package SomePodFormatter; + use base qw(Pod::Simple::Methody); + + sub handle_text { + my($self, $text) = @_; + ... + } + + sub start_head1 { + my($self, $attrs) = @_; + ... + } + sub end_head1 { + my($self) = @_; + ... + } + +...and start_/end_ methods for whatever other events you want to catch. + +=head1 DESCRIPTION + +This class is of +interest to people writing Pod formatters based on Pod::Simple. + +This class (which is very small -- read the source) overrides +Pod::Simple's _handle_element_start, _handle_text, and +_handle_element_end methods so that parser events are turned into method +calls. (Otherwise, this is a subclass of L<Pod::Simple> and inherits all +its methods.) + +You can use this class as the base class for a Pod formatter/processor. + +=head1 METHOD CALLING + +When Pod::Simple sees a "=head1 Hi there", for example, it basically does +this: + + $parser->_handle_element_start( "head1", \%attributes ); + $parser->_handle_text( "Hi there" ); + $parser->_handle_element_end( "head1" ); + +But if you subclass Pod::Simple::Methody, it will instead do this +when it sees a "=head1 Hi there": + + $parser->start_head1( \%attributes ) if $parser->can('start_head1'); + $parser->handle_text( "Hi there" ) if $parser->can('handle_text'); + $parser->end_head1() if $parser->can('end_head1'); + +If Pod::Simple sends an event where the element name has a dash, +period, or colon, the corresponding method name will have a underscore +in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz +and end_foo_bar_baz. + +See the source for Pod::Simple::Text for an example of using this class. + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Subclassing> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm new file mode 100644 index 00000000000..7de46d5696b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm @@ -0,0 +1,93 @@ + +require 5; +package Pod::Simple::Progress; +$VERSION = '3.14'; +use strict; + +# Objects of this class are used for noting progress of an +# operation every so often. Messages delivered more often than that +# are suppressed. +# +# There's actually nothing in here that's specific to Pod processing; +# but it's ad-hoc enough that I'm not willing to give it a name that +# implies that it's generally useful, like "IO::Progress" or something. +# +# -- sburke +# +#-------------------------------------------------------------------------- + +sub new { + my($class,$delay) = @_; + my $self = bless {'quiet_until' => 1}, ref($class) || $class; + $self->to(*STDOUT{IO}); + $self->delay(defined($delay) ? $delay : 5); + return $self; +} + +sub copy { + my $orig = shift; + bless {%$orig, 'quiet_until' => 1}, ref($orig); +} +#-------------------------------------------------------------------------- + +sub reach { + my($self, $point, $note) = @_; + if( (my $now = time) >= $self->{'quiet_until'}) { + my $goal; + my $to = $self->{'to'}; + print $to join('', + ($self->{'quiet_until'} == 1) ? () : '... ', + (defined $point) ? ( + '#', + ($goal = $self->{'goal'}) ? ( + ' ' x (length($goal) - length($point)), + $point, '/', $goal, + ) : $point, + $note ? ': ' : (), + ) : (), + $note || '', + "\n" + ); + $self->{'quiet_until'} = $now + $self->{'delay'}; + } + return $self; +} + +#-------------------------------------------------------------------------- + +sub done { + my($self, $note) = @_; + $self->{'quiet_until'} = 1; + return $self->reach( undef, $note ); +} + +#-------------------------------------------------------------------------- +# Simple accessors: + +sub delay { + return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] } +sub goal { + return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] } +sub to { + return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] } + +#-------------------------------------------------------------------------- + +unless(caller) { # Simple self-test: + my $p = __PACKAGE__->new->goal(5); + $p->reach(1, "Primus!"); + sleep 1; + $p->reach(2, "Secundus!"); + sleep 3; + $p->reach(3, "Tertius!"); + sleep 5; + $p->reach(4); + $p->reach(5, "Quintus!"); + sleep 1; + $p->done("All done"); +} + +#-------------------------------------------------------------------------- +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm new file mode 100644 index 00000000000..c27d0cbeb0e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm @@ -0,0 +1,843 @@ + +require 5; +package Pod::Simple::PullParser; +$VERSION = '3.14'; +use Pod::Simple (); +BEGIN {@ISA = ('Pod::Simple')} + +use strict; +use Carp (); + +use Pod::Simple::PullParserStartToken; +use Pod::Simple::PullParserEndToken; +use Pod::Simple::PullParserTextToken; + +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +__PACKAGE__->_accessorize( + 'source_fh', # the filehandle we're reading from + 'source_scalar_ref', # the scalarref we're reading from + 'source_arrayref', # the arrayref we're reading from +); + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And here is how we implement a pull-parser on top of a push-parser... + +sub filter { + my($self, $source) = @_; + $self = $self->new unless ref $self; + + $source = *STDIN{IO} unless defined $source; + $self->set_source($source); + $self->output_fh(*STDOUT{IO}); + + $self->run; # define run() in a subclass if you want to use filter()! + return $self; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub parse_string_document { + my $this = shift; + $this->set_source(\ $_[0]); + $this->run; +} + +sub parse_file { + my($this, $filename) = @_; + $this->set_source($filename); + $this->run; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# In case anyone tries to use them: + +sub run { + use Carp (); + if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed! + Carp::croak "You can call run() only on subclasses of " + . __PACKAGE__; + } else { + Carp::croak join '', + "You can't call run() because ", + ref($_[0]) || $_[0], " didn't define a run() method"; + } +} + +sub parse_lines { + use Carp (); + Carp::croak "Use set_source with ", __PACKAGE__, + " and subclasses, not parse_lines"; +} + +sub parse_line { + use Carp (); + Carp::croak "Use set_source with ", __PACKAGE__, + " and subclasses, not parse_line"; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + die "Couldn't construct for $class" unless $self; + + $self->{'token_buffer'} ||= []; + $self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken'; + $self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken'; + $self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken'; + + DEBUG > 1 and print "New pullparser object: $self\n"; + + return $self; +} + +# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +sub get_token { + my $self = shift; + DEBUG > 1 and print "\nget_token starting up on $self.\n"; + DEBUG > 2 and print " Items in token-buffer (", + scalar( @{ $self->{'token_buffer'} } ) , + ") :\n", map( + " " . $_->dump . "\n", @{ $self->{'token_buffer'} } + ), + @{ $self->{'token_buffer'} } ? '' : ' (no tokens)', + "\n" + ; + + until( @{ $self->{'token_buffer'} } ) { + DEBUG > 3 and print "I need to get something into my empty token buffer...\n"; + if($self->{'source_dead'}) { + DEBUG and print "$self 's source is dead.\n"; + push @{ $self->{'token_buffer'} }, undef; + } elsif(exists $self->{'source_fh'}) { + my @lines; + my $fh = $self->{'source_fh'} + || Carp::croak('You have to call set_source before you can call get_token'); + + DEBUG and print "$self 's source is filehandle $fh.\n"; + # Read those many lines at a time + for(my $i = Pod::Simple::MANY_LINES; $i--;) { + DEBUG > 3 and print " Fetching a line from source filehandle $fh...\n"; + local $/ = $Pod::Simple::NL; + push @lines, scalar(<$fh>); # readline + DEBUG > 3 and print " Line is: ", + defined($lines[-1]) ? $lines[-1] : "<undef>\n"; + unless( defined $lines[-1] ) { + DEBUG and print "That's it for that source fh! Killing.\n"; + delete $self->{'source_fh'}; # so it can be GC'd + last; + } + # but pass thru the undef, which will set source_dead to true + + # TODO: look to see if $lines[-1] is =encoding, and if so, + # do horribly magic things + + } + + if(DEBUG > 8) { + print "* I've gotten ", scalar(@lines), " lines:\n"; + foreach my $l (@lines) { + if(defined $l) { + print " line {$l}\n"; + } else { + print " line undef\n"; + } + } + print "* end of ", scalar(@lines), " lines\n"; + } + + $self->SUPER::parse_lines(@lines); + + } elsif(exists $self->{'source_arrayref'}) { + DEBUG and print "$self 's source is arrayref $self->{'source_arrayref'}, with ", + scalar(@{$self->{'source_arrayref'}}), " items left in it.\n"; + + DEBUG > 3 and print " Fetching ", Pod::Simple::MANY_LINES, " lines.\n"; + $self->SUPER::parse_lines( + splice @{ $self->{'source_arrayref'} }, + 0, + Pod::Simple::MANY_LINES + ); + unless( @{ $self->{'source_arrayref'} } ) { + DEBUG and print "That's it for that source arrayref! Killing.\n"; + $self->SUPER::parse_lines(undef); + delete $self->{'source_arrayref'}; # so it can be GC'd + } + # to make sure that an undef is always sent to signal end-of-stream + + } elsif(exists $self->{'source_scalar_ref'}) { + + DEBUG and print "$self 's source is scalarref $self->{'source_scalar_ref'}, with ", + length(${ $self->{'source_scalar_ref'} }) - + (pos(${ $self->{'source_scalar_ref'} }) || 0), + " characters left to parse.\n"; + + DEBUG > 3 and print " Fetching a line from source-string...\n"; + if( ${ $self->{'source_scalar_ref'} } =~ + m/([^\n\r]*)((?:\r?\n)?)/g + ) { + #print(">> $1\n"), + $self->SUPER::parse_lines($1) + if length($1) or length($2) + or pos( ${ $self->{'source_scalar_ref'} }) + != length( ${ $self->{'source_scalar_ref'} }); + # I.e., unless it's a zero-length "empty line" at the very + # end of "foo\nbar\n" (i.e., between the \n and the EOS). + } else { # that's the end. Byebye + $self->SUPER::parse_lines(undef); + delete $self->{'source_scalar_ref'}; + DEBUG and print "That's it for that source scalarref! Killing.\n"; + } + + + } else { + die "What source??"; + } + } + DEBUG and print "get_token about to return ", + Pod::Simple::pretty( @{$self->{'token_buffer'}} + ? $self->{'token_buffer'}[-1] : undef + ), "\n"; + return shift @{$self->{'token_buffer'}}; # that's an undef if empty +} + +sub unget_token { + my $self = shift; + DEBUG and print "Ungetting ", scalar(@_), " tokens: ", + @_ ? "@_\n" : "().\n"; + foreach my $t (@_) { + Carp::croak "Can't unget that, because it's not a token -- it's undef!" + unless defined $t; + Carp::croak "Can't unget $t, because it's not a token -- it's a string!" + unless ref $t; + Carp::croak "Can't unget $t, because it's not a token object!" + unless UNIVERSAL::can($t, 'type'); + } + + unshift @{$self->{'token_buffer'}}, @_; + DEBUG > 1 and print "Token buffer now has ", + scalar(@{$self->{'token_buffer'}}), " items in it.\n"; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +# $self->{'source_filename'} = $source; + +sub set_source { + my $self = shift @_; + return $self->{'source_fh'} unless @_; + my $handle; + if(!defined $_[0]) { + Carp::croak("Can't use empty-string as a source for set_source"); + } elsif(ref(\( $_[0] )) eq 'GLOB') { + $self->{'source_filename'} = '' . ($handle = $_[0]); + DEBUG and print "$self 's source is glob $_[0]\n"; + # and fall thru + } elsif(ref( $_[0] ) eq 'SCALAR') { + $self->{'source_scalar_ref'} = $_[0]; + DEBUG and print "$self 's source is scalar ref $_[0]\n"; + return; + } elsif(ref( $_[0] ) eq 'ARRAY') { + $self->{'source_arrayref'} = $_[0]; + DEBUG and print "$self 's source is array ref $_[0]\n"; + return; + } elsif(ref $_[0]) { + $self->{'source_filename'} = '' . ($handle = $_[0]); + DEBUG and print "$self 's source is fh-obj $_[0]\n"; + } elsif(!length $_[0]) { + Carp::croak("Can't use empty-string as a source for set_source"); + } else { # It's a filename! + DEBUG and print "$self 's source is filename $_[0]\n"; + { + local *PODSOURCE; + open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!"; + $handle = *PODSOURCE{IO}; + } + $self->{'source_filename'} = $_[0]; + DEBUG and print " Its name is $_[0].\n"; + + # TODO: file-discipline things here! + } + + $self->{'source_fh'} = $handle; + DEBUG and print " Its handle is $handle\n"; + return 1; +} + +# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +sub get_title_short { shift->get_short_title(@_) } # alias + +sub get_short_title { + my $title = shift->get_title(@_); + $title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s; + # turn "Foo::Bar -- bars for your foo" into "Foo::Bar" + return $title; +} + +sub get_title { shift->_get_titled_section( + 'NAME', max_token => 50, desperate => 1, @_) +} +sub get_version { shift->_get_titled_section( + 'VERSION', + max_token => 400, + accept_verbatim => 1, + max_content_length => 3_000, + @_, + ); +} +sub get_description { shift->_get_titled_section( + 'DESCRIPTION', + max_token => 400, + max_content_length => 3_000, + @_, +) } + +sub get_authors { shift->get_author(@_) } # a harmless alias + +sub get_author { + my $this = shift; + # Max_token is so high because these are + # typically at the end of the document: + $this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) || + $this->_get_titled_section('AUTHORS', max_token => 10_000, @_); +} + +#-------------------------------------------------------------------------- + +sub _get_titled_section { + # Based on a get_title originally contributed by Graham Barr + my($self, $titlename, %options) = (@_); + + my $max_token = delete $options{'max_token'}; + my $desperate_for_title = delete $options{'desperate'}; + my $accept_verbatim = delete $options{'accept_verbatim'}; + my $max_content_length = delete $options{'max_content_length'}; + my $nocase = delete $options{'nocase'}; + $max_content_length = 120 unless defined $max_content_length; + + Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ") + . join " ", map "[$_]", sort keys %options + ) + if keys %options; + + my %content_containers; + $content_containers{'Para'} = 1; + if($accept_verbatim) { + $content_containers{'Verbatim'} = 1; + $content_containers{'VerbatimFormatted'} = 1; + } + + my $token_count = 0; + my $title; + my @to_unget; + my $state = 0; + my $depth = 0; + + Carp::croak "What kind of titlename is \"$titlename\"?!" unless + defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity + my $titlename_re = quotemeta($titlename); + + my $head1_text_content; + my $para_text_content; + + while( + ++$token_count <= ($max_token || 1_000_000) + and defined(my $token = $self->get_token) + ) { + push @to_unget, $token; + + if ($state == 0) { # seeking =head1 + if( $token->is_start and $token->tagname eq 'head1' ) { + DEBUG and print " Found head1. Seeking content...\n"; + ++$state; + $head1_text_content = ''; + } + } + + elsif($state == 1) { # accumulating text until end of head1 + if( $token->is_text ) { + DEBUG and print " Adding \"", $token->text, "\" to head1-content.\n"; + $head1_text_content .= $token->text; + } elsif( $token->is_end and $token->tagname eq 'head1' ) { + DEBUG and print " Found end of head1. Considering content...\n"; + $head1_text_content = uc $head1_text_content if $nocase; + if($head1_text_content eq $titlename + or $head1_text_content =~ m/\($titlename_re\)/s + # We accept "=head1 Nomen Modularis (NAME)" for sake of i18n + ) { + DEBUG and print " Yup, it was $titlename. Seeking next para-content...\n"; + ++$state; + } elsif( + $desperate_for_title + # if we're so desperate we'll take the first + # =head1's content as a title + and $head1_text_content =~ m/\S/ + and $head1_text_content !~ m/^[ A-Z]+$/s + and $head1_text_content !~ + m/\((?: + NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS + | COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS? + | CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT + )\)/sx + # avoid accepting things like =head1 Thingy Thongy (DESCRIPTION) + and ($max_content_length + ? (length($head1_text_content) <= $max_content_length) # sanity + : 1) + ) { + DEBUG and print " It looks titular: \"$head1_text_content\".\n", + "\n Using that.\n"; + $title = $head1_text_content; + last; + } else { + --$state; + DEBUG and print " Didn't look titular ($head1_text_content).\n", + "\n Dropping back to seeking-head1-content mode...\n"; + } + } + } + + elsif($state == 2) { + # seeking start of para (which must immediately follow) + if($token->is_start and $content_containers{ $token->tagname }) { + DEBUG and print " Found start of Para. Accumulating content...\n"; + $para_text_content = ''; + ++$state; + } else { + DEBUG and print + " Didn't see an immediately subsequent start-Para. Reseeking H1\n"; + $state = 0; + } + } + + elsif($state == 3) { + # accumulating text until end of Para + if( $token->is_text ) { + DEBUG and print " Adding \"", $token->text, "\" to para-content.\n"; + $para_text_content .= $token->text; + # and keep looking + + } elsif( $token->is_end and $content_containers{ $token->tagname } ) { + DEBUG and print " Found end of Para. Considering content: ", + $para_text_content, "\n"; + + if( $para_text_content =~ m/\S/ + and ($max_content_length + ? (length($para_text_content) <= $max_content_length) + : 1) + ) { + # Some minimal sanity constraints, I think. + DEBUG and print " It looks contentworthy, I guess. Using it.\n"; + $title = $para_text_content; + last; + } else { + DEBUG and print " Doesn't look at all contentworthy!\n Giving up.\n"; + undef $title; + last; + } + } + } + + else { + die "IMPOSSIBLE STATE $state!\n"; # should never happen + } + + } + + # Put it all back! + $self->unget_token(@to_unget); + + if(DEBUG) { + if(defined $title) { print " Returing title <$title>\n" } + else { print "Returning title <>\n" } + } + + return '' unless defined $title; + $title =~ s/^\s+//; + return $title; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# Methods that actually do work at parse-time: + +sub _handle_element_start { + my $self = shift; # leaving ($element_name, $attr_hash_r) + DEBUG > 2 and print "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n"; + + push @{ $self->{'token_buffer'} }, + $self->{'start_token_class'}->new(@_); + return; +} + +sub _handle_text { + my $self = shift; # leaving ($text) + DEBUG > 2 and print "== $_[0]\n"; + push @{ $self->{'token_buffer'} }, + $self->{'text_token_class'}->new(@_); + return; +} + +sub _handle_element_end { + my $self = shift; # leaving ($element_name); + DEBUG > 2 and print "-- $_[0]\n"; + push @{ $self->{'token_buffer'} }, + $self->{'end_token_class'}->new(@_); + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +1; + + +__END__ + +=head1 NAME + +Pod::Simple::PullParser -- a pull-parser interface to parsing Pod + +=head1 SYNOPSIS + + my $parser = SomePodProcessor->new; + $parser->set_source( "whatever.pod" ); + $parser->run; + +Or: + + my $parser = SomePodProcessor->new; + $parser->set_source( $some_filehandle_object ); + $parser->run; + +Or: + + my $parser = SomePodProcessor->new; + $parser->set_source( \$document_source ); + $parser->run; + +Or: + + my $parser = SomePodProcessor->new; + $parser->set_source( \@document_lines ); + $parser->run; + +And elsewhere: + + require 5; + package SomePodProcessor; + use strict; + use base qw(Pod::Simple::PullParser); + + sub run { + my $self = shift; + Token: + while(my $token = $self->get_token) { + ...process each token... + } + } + +=head1 DESCRIPTION + +This class is for using Pod::Simple to build a Pod processor -- but +one that uses an interface based on a stream of token objects, +instead of based on events. + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +A subclass of Pod::Simple::PullParser should define a C<run> method +that calls C<< $token = $parser->get_token >> to pull tokens. + +See the source for Pod::Simple::RTF for an example of a formatter +that uses Pod::Simple::PullParser. + +=head1 METHODS + +=over + +=item my $token = $parser->get_token + +This returns the next token object (which will be of a subclass of +L<Pod::Simple::PullParserToken>), or undef if the parser-stream has hit +the end of the document. + +=item $parser->unget_token( $token ) + +=item $parser->unget_token( $token1, $token2, ... ) + +This restores the token object(s) to the front of the parser stream. + +=back + +The source has to be set before you can parse anything. The lowest-level +way is to call C<set_source>: + +=over + +=item $parser->set_source( $filename ) + +=item $parser->set_source( $filehandle_object ) + +=item $parser->set_source( \$document_source ) + +=item $parser->set_source( \@document_lines ) + +=back + +Or you can call these methods, which Pod::Simple::PullParser has defined +to work just like Pod::Simple's same-named methods: + +=over + +=item $parser->parse_file(...) + +=item $parser->parse_string_document(...) + +=item $parser->filter(...) + +=item $parser->parse_from_file(...) + +=back + +For those to work, the Pod-processing subclass of +Pod::Simple::PullParser has to have defined a $parser->run method -- +so it is advised that all Pod::Simple::PullParser subclasses do so. +See the Synopsis above, or the source for Pod::Simple::RTF. + +Authors of formatter subclasses might find these methods useful to +call on a parser object that you haven't started pulling tokens +from yet: + +=over + +=item my $title_string = $parser->get_title + +This tries to get the title string out of $parser, by getting some tokens, +and scanning them for the title, and then ungetting them so that you can +process the token-stream from the beginning. + +For example, suppose you have a document that starts out: + + =head1 NAME + + Hoo::Boy::Wowza -- Stuff B<wow> yeah! + +$parser->get_title on that document will return "Hoo::Boy::Wowza -- +Stuff wow yeah!". If the document starts with: + + =head1 Name + + Hoo::Boy::W00t -- Stuff B<w00t> yeah! + +Then you'll need to pass the C<nocase> option in order to recognize "Name": + + $parser->get_title(nocase => 1); + +In cases where get_title can't find the title, it will return empty-string +(""). + +=item my $title_string = $parser->get_short_title + +This is just like get_title, except that it returns just the modulename, if +the title seems to be of the form "SomeModuleName -- description". + +For example, suppose you have a document that starts out: + + =head1 NAME + + Hoo::Boy::Wowza -- Stuff B<wow> yeah! + +then $parser->get_short_title on that document will return +"Hoo::Boy::Wowza". + +But if the document starts out: + + =head1 NAME + + Hooboy, stuff B<wow> yeah! + +then $parser->get_short_title on that document will return "Hooboy, +stuff wow yeah!". If the document starts with: + + =head1 Name + + Hoo::Boy::W00t -- Stuff B<w00t> yeah! + +Then you'll need to pass the C<nocase> option in order to recognize "Name": + + $parser->get_short_title(nocase => 1); + +If the title can't be found, then get_short_title returns empty-string +(""). + +=item $author_name = $parser->get_author + +This works like get_title except that it returns the contents of the +"=head1 AUTHOR\n\nParagraph...\n" section, assuming that that section +isn't terribly long. To recognize a "=head1 Author\n\nParagraph\n" +section, pass the C<nocase> otpion: + + $parser->get_author(nocase => 1); + +(This method tolerates "AUTHORS" instead of "AUTHOR" too.) + +=item $description_name = $parser->get_description + +This works like get_title except that it returns the contents of the +"=head1 DESCRIPTION\n\nParagraph...\n" section, assuming that that section +isn't terribly long. To recognize a "=head1 Description\n\nParagraph\n" +section, pass the C<nocase> otpion: + + $parser->get_description(nocase => 1); + +=item $version_block = $parser->get_version + +This works like get_title except that it returns the contents of +the "=head1 VERSION\n\n[BIG BLOCK]\n" block. Note that this does NOT +return the module's C<$VERSION>!! To recognize a +"=head1 Version\n\n[BIG BLOCK]\n" section, pass the C<nocase> otpion: + + $parser->get_version(nocase => 1); + +=back + +=head1 NOTE + +You don't actually I<have> to define a C<run> method. If you're +writing a Pod-formatter class, you should define a C<run> just so +that users can call C<parse_file> etc, but you don't I<have> to. + +And if you're not writing a formatter class, but are instead just +writing a program that does something simple with a Pod::PullParser +object (and not an object of a subclass), then there's no reason to +bother subclassing to add a C<run> method. + +=head1 SEE ALSO + +L<Pod::Simple> + +L<Pod::Simple::PullParserToken> -- and its subclasses +L<Pod::Simple::PullParserStartToken>, +L<Pod::Simple::PullParserTextToken>, and +L<Pod::Simple::PullParserEndToken>. + +L<HTML::TokeParser>, which inspired this. + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut +JUNK: + +sub _old_get_title { # some witchery in here + my $self = $_[0]; + my $title; + my @to_unget; + + while(1) { + push @to_unget, $self->get_token; + unless(defined $to_unget[-1]) { # whoops, short doc! + pop @to_unget; + last; + } + + DEBUG and print "-Got token ", $to_unget[-1]->dump, "\n"; + + (DEBUG and print "Too much in the buffer.\n"), + last if @to_unget > 25; # sanity + + my $pattern = ''; + if( #$to_unget[-1]->type eq 'end' + #and $to_unget[-1]->tagname eq 'Para' + #and + ($pattern = join('', + map {; + ($_->type eq 'start') ? ("<" . $_->tagname .">") + : ($_->type eq 'end' ) ? ("</". $_->tagname .">") + : ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X') + : "BLORP" + } @to_unget + )) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s + ) { + # Whee, it fits the pattern + DEBUG and print "Seems to match =head1 NAME pattern.\n"; + $title = ''; + foreach my $t (reverse @to_unget) { + last if $t->type eq 'start' and $t->tagname eq 'Para'; + $title = $t->text . $title if $t->type eq 'text'; + } + undef $title if $title =~ m<^\s*$>; # make sure it's contentful! + last; + + } elsif ($pattern =~ m{<head(\d)>(.+)</head\d>$} + and !( $1 eq '1' and $2 eq 'NAME' ) + ) { + # Well, it fits a fallback pattern + DEBUG and print "Seems to match NAMEless pattern.\n"; + $title = ''; + foreach my $t (reverse @to_unget) { + last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s; + $title = $t->text . $title if $t->type eq 'text'; + } + undef $title if $title =~ m<^\s*$>; # make sure it's contentful! + last; + + } else { + DEBUG and $pattern and print "Leading pattern: $pattern\n"; + } + } + + # Put it all back: + $self->unget_token(@to_unget); + + if(DEBUG) { + if(defined $title) { print " Returing title <$title>\n" } + else { print "Returning title <>\n" } + } + + return '' unless defined $title; + return $title; +} + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm new file mode 100644 index 00000000000..67a625d8877 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm @@ -0,0 +1,120 @@ + +require 5; +package Pod::Simple::PullParserEndToken; +use Pod::Simple::PullParserToken (); +use strict; +use vars qw(@ISA $VERSION); +@ISA = ('Pod::Simple::PullParserToken'); +$VERSION = '3.14'; + +sub new { # Class->new(tagname); + my $class = shift; + return bless ['end', @_], ref($class) || $class; +} + +# Purely accessors: + +sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } +sub tag { shift->tagname(@_) } + +# shortcut: +sub is_tagname { $_[0][1] eq $_[1] } +sub is_tag { shift->is_tagname(@_) } + +1; + + +__END__ + +=head1 NAME + +Pod::Simple::PullParserEndToken -- end-tokens from Pod::Simple::PullParser + +=head1 SYNOPSIS + +(See L<Pod::Simple::PullParser>) + +=head1 DESCRIPTION + +When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might +get an object of this class. + +This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods, +and adds these methods: + +=over + +=item $token->tagname + +This returns the tagname for this end-token object. +For example, parsing a "=head1 ..." line will give you +a start-token with the tagname of "head1", token(s) for its +content, and then an end-token with the tagname of "head1". + +=item $token->tagname(I<somestring>) + +This changes the tagname for this end-token object. +You probably won't need to do this. + +=item $token->tag(...) + +A shortcut for $token->tagname(...) + +=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>) + +These are shortcuts for C<< $token->tag() eq I<somestring> >> + +=back + +You're unlikely to ever need to construct an object of this class for +yourself, but if you want to, call +C<< +Pod::Simple::PullParserEndToken->new( I<tagname> ) +>> + +=head1 SEE ALSO + +L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm new file mode 100644 index 00000000000..37d68ef6196 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm @@ -0,0 +1,161 @@ + +require 5; +package Pod::Simple::PullParserStartToken; +use Pod::Simple::PullParserToken (); +use strict; +use vars qw(@ISA $VERSION); +@ISA = ('Pod::Simple::PullParserToken'); +$VERSION = '3.14'; + +sub new { # Class->new(tagname, optional_attrhash); + my $class = shift; + return bless ['start', @_], ref($class) || $class; +} + +# Purely accessors: + +sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } +sub tag { shift->tagname(@_) } + +sub is_tagname { $_[0][1] eq $_[1] } +sub is_tag { shift->is_tagname(@_) } + + +sub attr_hash { $_[0][2] ||= {} } + +sub attr { + if(@_ == 2) { # Reading: $token->attr('attrname') + ${$_[0][2] || return undef}{ $_[1] }; + } elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval') + ${$_[0][2] ||= {}}{ $_[1] } = $_[2]; + } else { + require Carp; + Carp::croak( + 'usage: $object->attr("val") or $object->attr("key", "newval")'); + return undef; + } +} + +1; + + +__END__ + +=head1 NAME + +Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser + +=head1 SYNOPSIS + +(See L<Pod::Simple::PullParser>) + +=head1 DESCRIPTION + +When you do $parser->get_token on a L<Pod::Simple::PullParser> object, you might +get an object of this class. + +This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods, +and adds these methods: + +=over + +=item $token->tagname + +This returns the tagname for this start-token object. +For example, parsing a "=head1 ..." line will give you +a start-token with the tagname of "head1", token(s) for its +content, and then an end-token with the tagname of "head1". + +=item $token->tagname(I<somestring>) + +This changes the tagname for this start-token object. +You probably won't need +to do this. + +=item $token->tag(...) + +A shortcut for $token->tagname(...) + +=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>) + +These are shortcuts for C<< $token->tag() eq I<somestring> >> + +=item $token->attr(I<attrname>) + +This returns the value of the I<attrname> attribute for this start-token +object, or undef. + +For example, parsing a LZ<><Foo/"Bar"> link will produce a start-token +with a "to" attribute with the value "Foo", a "type" attribute with the +value "pod", and a "section" attribute with the value "Bar". + +=item $token->attr(I<attrname>, I<newvalue>) + +This sets the I<attrname> attribute for this start-token object to +I<newvalue>. You probably won't need to do this. + +=item $token->attr_hash + +This returns the hashref that is the attribute set for this start-token. +This is useful if (for example) you want to ask what all the attributes +are -- you can just do C<< keys %{$token->attr_hash} >> + +=back + + +You're unlikely to ever need to construct an object of this class for +yourself, but if you want to, call +C<< +Pod::Simple::PullParserStartToken->new( I<tagname>, I<attrhash> ) +>> + +=head1 SEE ALSO + +L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing> + +=head1 SEE ALSO + +L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm new file mode 100644 index 00000000000..ed6340d598a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm @@ -0,0 +1,128 @@ + +require 5; +package Pod::Simple::PullParserTextToken; +use Pod::Simple::PullParserToken (); +use strict; +use vars qw(@ISA $VERSION); +@ISA = ('Pod::Simple::PullParserToken'); +$VERSION = '3.14'; + +sub new { # Class->new(text); + my $class = shift; + return bless ['text', @_], ref($class) || $class; +} + +# Purely accessors: + +sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } + +sub text_r { \ $_[0][1] } + +1; + +__END__ + +=head1 NAME + +Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser + +=head1 SYNOPSIS + +(See L<Pod::Simple::PullParser>) + +=head1 DESCRIPTION + +When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might +get an object of this class. + +This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods, +and adds these methods: + +=over + +=item $token->text + +This returns the text that this token holds. For example, parsing +CZ<><foo> will return a C start-token, a text-token, and a C end-token. And +if you want to get the "foo" out of the text-token, call C<< $token->text >> + +=item $token->text(I<somestring>) + +This changes the string that this token holds. You probably won't need +to do this. + +=item $token->text_r() + +This returns a scalar reference to the string that this token holds. +This can be useful if you don't want to memory-copy the potentially +large text value (well, as large as a paragraph or a verbatim block) +as calling $token->text would do. + +Or, if you want to alter the value, you can even do things like this: + + for ( ${ $token->text_r } ) { # Aliases it with $_ !! + + s/ The / the /g; # just for example + + if( 'A' eq chr(65) ) { # (if in an ASCII world) + tr/\xA0/ /; + tr/\xAD//d; + } + + ...or however you want to alter the value... + } + +=back + +You're unlikely to ever need to construct an object of this class for +yourself, but if you want to, call +C<< +Pod::Simple::PullParserTextToken->new( I<text> ) +>> + +=head1 SEE ALSO + +L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm new file mode 100644 index 00000000000..2234ccf7ade --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm @@ -0,0 +1,163 @@ + +require 5; +package Pod::Simple::PullParserToken; + # Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token +@ISA = (); +$VERSION = '3.14'; +use strict; + +sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway + my $class = shift; + return bless [@_], ref($class) || $class; +} + +sub type { $_[0][0] } # Can't change the type of an object +sub dump { Pod::Simple::pretty( [ @{ $_[0] } ] ) } + +sub is_start { $_[0][0] eq 'start' } +sub is_end { $_[0][0] eq 'end' } +sub is_text { $_[0][0] eq 'text' } + +1; +__END__ + +sub dump { '[' . _esc( @{ $_[0] } ) . ']' } + +# JUNK: + +sub _esc { + return '' unless @_; + my @out; + foreach my $in (@_) { + push @out, '"' . $in . '"'; + $out[-1] =~ s/([^- \:\:\.\,\'\>\<\"\/\=\?\+\|\[\]\{\}\_a-zA-Z0-9_\`\~\!\#\%\^\&\*\(\)])/ + sprintf( (ord($1) < 256) ? "\\x%02X" : "\\x{%X}", ord($1)) + /eg; + } + return join ', ', @out; +} + + +__END__ + +=head1 NAME + +Pod::Simple::PullParserToken -- tokens from Pod::Simple::PullParser + +=head1 SYNOPSIS + +Given a $parser that's an object of class Pod::Simple::PullParser +(or a subclass)... + + while(my $token = $parser->get_token) { + $DEBUG and print "Token: ", $token->dump, "\n"; + if($token->is_start) { + ...access $token->tagname, $token->attr, etc... + + } elsif($token->is_text) { + ...access $token->text, $token->text_r, etc... + + } elsif($token->is_end) { + ...access $token->tagname... + + } + } + +(Also see L<Pod::Simple::PullParser>) + +=head1 DESCRIPTION + +When you do $parser->get_token on a L<Pod::Simple::PullParser>, you should +get an object of a subclass of Pod::Simple::PullParserToken. + +Subclasses will add methods, and will also inherit these methods: + +=over + +=item $token->type + +This returns the type of the token. This will be either the string +"start", the string "text", or the string "end". + +Once you know what the type of an object is, you then know what +subclass it belongs to, and therefore what methods it supports. + +Yes, you could probably do the same thing with code like +$token->isa('Pod::Simple::PullParserEndToken'), but that's not so +pretty as using just $token->type, or even the following shortcuts: + +=item $token->is_start + +This is a shortcut for C<< $token->type() eq "start" >> + +=item $token->is_text + +This is a shortcut for C<< $token->type() eq "text" >> + +=item $token->is_end + +This is a shortcut for C<< $token->type() eq "end" >> + +=item $token->dump + +This returns a handy stringified value of this object. This +is useful for debugging, as in: + + while(my $token = $parser->get_token) { + $DEBUG and print "Token: ", $token->dump, "\n"; + ... + } + +=back + +=head1 SEE ALSO + +My subclasses: +L<Pod::Simple::PullParserStartToken>, +L<Pod::Simple::PullParserTextToken>, and +L<Pod::Simple::PullParserEndToken>. + +L<Pod::Simple::PullParser> and L<Pod::Simple> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm new file mode 100644 index 00000000000..f476d37b249 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm @@ -0,0 +1,699 @@ + +require 5; +package Pod::Simple::RTF; + +#sub DEBUG () {4}; +#sub Pod::Simple::DEBUG () {4}; +#sub Pod::Simple::PullParser::DEBUG () {4}; + +use strict; +use vars qw($VERSION @ISA %Escape $WRAP %Tagmap); +$VERSION = '3.14'; +use Pod::Simple::PullParser (); +BEGIN {@ISA = ('Pod::Simple::PullParser')} + +use Carp (); +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +$WRAP = 1 unless defined $WRAP; + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub _openclose { + return map {; + m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?"; + ( $1, "{\\$2\n", "/$1", "}" ); + } @_; +} + +my @_to_accept; + +%Tagmap = ( + # 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}') + _openclose( + 'B=cs18\b', + 'I=cs16\i', + 'C=cs19\f1\lang1024\noproof', + 'F=cs17\i\lang1024\noproof', + + 'VerbatimI=cs26\i', + 'VerbatimB=cs27\b', + 'VerbatimBI=cs28\b\i', + + map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ } + qw[ + underline=ul smallcaps=scaps shadow=shad + superscript=super subscript=sub strikethrough=strike + outline=outl emboss=embo engrave=impr + dotted-underline=uld dash-underline=uldash + dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd + double-underline=uldb thick-underline=ulth + word-underline=ulw wave-underline=ulwave + ] + # But no double-strikethrough, because MSWord can't agree with the + # RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!) + ), + + # Bit of a hack here: + 'L=pod' => '{\cs22\i'."\n", + 'L=url' => '{\cs23\i'."\n", + 'L=man' => '{\cs24\i'."\n", + '/L' => '}', + + 'Data' => "\n", + '/Data' => "\n", + + 'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n", + '/Verbatim' => "\n\\par}\n", + 'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n", + '/VerbatimFormatted' => "\n\\par}\n", + 'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n", + '/Para' => "\n\\par}\n", + 'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n", + '/head1' => "\n}\\par}\n", + 'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n", + '/head2' => "\n}\\par}\n", + 'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n", + '/head3' => "\n}\\par}\n", + 'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n", + '/head4' => "\n}\\par}\n", + # wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2 + + 'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n", + '/item-bullet' => "\n\\par}\n", + 'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n", + '/item-number' => "\n\\par}\n", + 'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n", + '/item-text' => "\n\\par}\n", + + # we don't need any styles for over-* and /over-* +); + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub new { + my $new = shift->SUPER::new(@_); + $new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->accept_targets( 'rtf', 'RTF' ); + + $new->{'Tagmap'} = {%Tagmap}; + + $new->accept_codes(@_to_accept); + $new->accept_codes('VerbatimFormatted'); + DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n"; + $new->doc_lang( + ( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1 + : ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1) + # yes, tolerate hex! + : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1) + # yes, tolerate even more hex! + : '1033' + ); + + $new->head1_halfpoint_size(32); + $new->head2_halfpoint_size(28); + $new->head3_halfpoint_size(25); + $new->head4_halfpoint_size(22); + $new->codeblock_halfpoint_size(18); + $new->header_halfpoint_size(17); + $new->normal_halfpoint_size(25); + + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +__PACKAGE__->_accessorize( + 'doc_lang', + 'head1_halfpoint_size', + 'head2_halfpoint_size', + 'head3_halfpoint_size', + 'head4_halfpoint_size', + 'codeblock_halfpoint_size', + 'header_halfpoint_size', + 'normal_halfpoint_size', + 'no_proofing_exemptions', +); + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub run { + my $self = $_[0]; + return $self->do_middle if $self->bare_output; + return + $self->do_beginning && $self->do_middle && $self->do_end; +} + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub do_middle { # the main work + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + + my($token, $type, $tagname, $scratch); + my @stack; + my @indent_stack; + $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'}; + + while($token = $self->get_token) { + + if( ($type = $token->type) eq 'text' ) { + if( $self->{'rtfverbatim'} ) { + DEBUG > 1 and print " $type " , $token->text, " in verbatim!\n"; + rtf_esc_codely($scratch = $token->text); + print $fh $scratch; + next; + } + + DEBUG > 1 and print " $type " , $token->text, "\n"; + + $scratch = $token->text; + $scratch =~ tr/\t\cb\cc/ /d; + + $self->{'no_proofing_exemptions'} or $scratch =~ + s/(?: + ^ + | + (?<=[\cm\cj\t "\[\<\(]) + ) # start on whitespace, sequence-start, or quote + ( # something looking like a Perl token: + (?: + [\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc. + ) + | + # or starting alpha, but containing anything strange: + (?: + [a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+ + ) + ) + /\cb$1\cc/xsg + ; + + rtf_esc($scratch); + $scratch =~ + s/( + [^\cm\cj\n]{65} # Snare 65 characters from a line + [^\cm\cj\n\x20]{0,50} # and finish any current word + ) + (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end + /$1$2\n/gx # and put a NL before those spaces + if $WRAP; + # This may wrap at well past the 65th column, but not past the 120th. + + print $fh $scratch; + + } elsif( $type eq 'start' ) { + DEBUG > 1 and print " +$type ",$token->tagname, + " (", map("<$_> ", %{$token->attr_hash}), ")\n"; + + if( ($tagname = $token->tagname) eq 'Verbatim' + or $tagname eq 'VerbatimFormatted' + ) { + ++$self->{'rtfverbatim'}; + my $next = $self->get_token; + next unless defined $next; + my $line_count = 1; + if($next->type eq 'text') { + my $t = $next->text_r; + while( $$t =~ m/$/mg ) { + last if ++$line_count > 15; # no point in counting further + } + DEBUG > 3 and print " verbatim line count: $line_count\n"; + } + $self->unget_token($next); + $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ; + + } elsif( $tagname =~ m/^item-/s ) { + my @to_unget; + my $text_count_here = 0; + $self->{'rtfitemkeepn'} = ''; + # Some heuristics to stop item-*'s functioning as subheadings + # from getting split from the things they're subheadings for. + # + # It's not terribly pretty, but it really does make things pretty. + # + while(1) { + push @to_unget, $self->get_token; + pop(@to_unget), last unless defined $to_unget[-1]; + # Erroneously used to be "unshift" instead of pop! Adds instead + # of removes, and operates on the beginning instead of the end! + + if($to_unget[-1]->type eq 'text') { + if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){ + DEBUG > 1 and print " item-* is too long to be keepn'd.\n"; + last; + } + } elsif (@to_unget > 1 and + $to_unget[-2]->type eq 'end' and + $to_unget[-2]->tagname =~ m/^item-/s + ) { + # Bail out here, after setting rtfitemkeepn yea or nay. + $self->{'rtfitemkeepn'} = '\keepn' if + $to_unget[-1]->type eq 'start' and + $to_unget[-1]->tagname eq 'Para'; + + DEBUG > 1 and printf " item-* before %s(%s) %s keepn'd.\n", + $to_unget[-1]->type, + $to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '', + $self->{'rtfitemkeepn'} ? "gets" : "doesn't get"; + last; + } elsif (@to_unget > 40) { + DEBUG > 1 and print " item-* now has too many tokens (", + scalar(@to_unget), + (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (), + ") to be keepn'd.\n"; + last; # give up + } + # else keep while'ing along + } + # Now put it aaaaall back... + $self->unget_token(@to_unget); + + } elsif( $tagname =~ m/^over-/s ) { + push @stack, $1; + push @indent_stack, + int($token->attr('indent') * 4 * $self->normal_halfpoint_size); + DEBUG and print "Indenting over $indent_stack[-1] twips.\n"; + $self->{'rtfindent'} += $indent_stack[-1]; + + } elsif ($tagname eq 'L') { + $tagname .= '=' . ($token->attr('type') || 'pod'); + + } elsif ($tagname eq 'Data') { + my $next = $self->get_token; + next unless defined $next; + unless( $next->type eq 'text' ) { + $self->unget_token($next); + next; + } + DEBUG and print " raw text ", $next->text, "\n"; + printf $fh "\n" . $next->text . "\n"; + next; + } + + defined($scratch = $self->{'Tagmap'}{$tagname}) or next; + $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate + print $fh $scratch; + + if ($tagname eq 'item-number') { + print $fh $token->attr('number'), ". \n"; + } elsif ($tagname eq 'item-bullet') { + print $fh "\\'95 \n"; + #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}"); + } + + } elsif( $type eq 'end' ) { + DEBUG > 1 and print " -$type ",$token->tagname,"\n"; + if( ($tagname = $token->tagname) =~ m/^over-/s ) { + DEBUG and print "Indenting back $indent_stack[-1] twips.\n"; + $self->{'rtfindent'} -= pop @indent_stack; + pop @stack; + } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') { + --$self->{'rtfverbatim'}; + } + defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next; + $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate + print $fh $scratch; + } + } + return 1; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub do_beginning { + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + return print $fh join '', + $self->doc_init, + $self->font_table, + $self->stylesheet, + $self->color_table, + $self->doc_info, + $self->doc_start, + "\n" + ; +} + +sub do_end { + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + return print $fh '}'; # that should do it +} + +########################################################################### + +sub stylesheet { + return sprintf <<'END', +{\stylesheet +{\snext0 Normal;} +{\*\cs10 \additive Default Paragraph Font;} +{\*\cs16 \additive \i \sbasedon10 pod-I;} +{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;} +{\*\cs18 \additive \b \sbasedon10 pod-B;} +{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;} +{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;} +{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;} +{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;} +{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;} +{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;} + +{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;} +{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;} +{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;} +{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;} + +{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;} +{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;} +{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;} +{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;} +} + +END + + $_[0]->codeblock_halfpoint_size(), + $_[0]->head1_halfpoint_size(), + $_[0]->head2_halfpoint_size(), + $_[0]->head3_halfpoint_size(), + $_[0]->head4_halfpoint_size(), + ; +} + +########################################################################### +# Override these as necessary for further customization + +sub font_table { + return <<'END'; # text font, code font, heading font +{\fonttbl +{\f0\froman Times New Roman;} +{\f1\fmodern Courier New;} +{\f2\fswiss Arial;} +} + +END +} + +sub doc_init { + return <<'END'; +{\rtf1\ansi\deff0 + +END +} + +sub color_table { + return <<'END'; +{\colortbl;\red255\green0\blue0;\red0\green0\blue255;} +END +} + + +sub doc_info { + my $self = $_[0]; + + my $class = ref($self) || $self; + + my $tag = __PACKAGE__ . ' ' . $VERSION; + + unless($class eq __PACKAGE__) { + $tag = " ($tag)"; + $tag = " v" . $self->VERSION . $tag if defined $self->VERSION; + $tag = $class . $tag; + } + + return sprintf <<'END', +{\info{\doccomm +%s + using %s v%s + under Perl v%s at %s GMT} +{\author [see doc]}{\company [see doc]}{\operator [see doc]} +} + +END + + # None of the following things should need escaping, I dare say! + $tag, + $ISA[0], $ISA[0]->VERSION(), + $], scalar(gmtime), + ; +} + +sub doc_start { + my $self = $_[0]; + my $title = $self->get_short_title(); + DEBUG and print "Short Title: <$title>\n"; + $title .= ' ' if length $title; + + $title =~ s/ *$/ /s; + $title =~ s/^ //s; + $title =~ s/ $/, /s; + # make sure it ends in a comma and a space, unless it's 0-length + + my $is_obviously_module_name; + $is_obviously_module_name = 1 + if $title =~ m/^\S+$/s and $title =~ m/::/s; + # catches the most common case, at least + + DEBUG and print "Title0: <$title>\n"; + $title = rtf_esc($title); + DEBUG and print "Title1: <$title>\n"; + $title = '\lang1024\noproof ' . $title + if $is_obviously_module_name; + + return sprintf <<'END', +\deflang%s\plain\lang%s\widowctrl +{\header\pard\qr\plain\f2\fs%s +%s +p.\chpgn\par} +\fs%s + +END + ($self->doc_lang) x 2, + $self->header_halfpoint_size, + $title, + $self->normal_halfpoint_size, + ; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#------------------------------------------------------------------------- + +use integer; +sub rtf_esc { + my $x; # scratch + if(!defined wantarray) { # void context: alter in-place! + for(@_) { + s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + } + return; + } elsif(wantarray) { # return an array + return map {; ($x = $_) =~ + s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + $x; + } @_; + } else { # return a single scalar + ($x = ((@_ == 1) ? $_[0] : join '', @_) + ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + # Escape \, {, }, -, control chars, and 7f-ff. + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + return $x; + } +} + +sub rtf_esc_codely { + # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts. + # We don't want to change the "-" to hard-hyphen, because we want to + # be able to paste this into a file and run it without there being + # dire screaming about the mysterious hard-hyphen character (which + # looks just like a normal dash character). + + my $x; # scratch + if(!defined wantarray) { # void context: alter in-place! + for(@_) { + s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + } + return; + } elsif(wantarray) { # return an array + return map {; ($x = $_) =~ + s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + $x; + } @_; + } else { # return a single scalar + ($x = ((@_ == 1) ? $_[0] : join '', @_) + ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + # Escape \, {, }, -, control chars, and 7f-ff. + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + return $x; + } +} + +%Escape = ( + map( (chr($_),chr($_)), # things not apparently needing escaping + 0x20 .. 0x7E ), + map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things + 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46), + + # We get to escape out 'F' so that we can send RTF files thru the mail + # without the slightest worry that paragraphs beginning with "From" + # will get munged. + + # And some refinements: + "\cm" => "\n", + "\cj" => "\n", + "\n" => "\n\\line ", + + "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay) + "\f" => "\n\\page\n", # Formfeed + "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen + "\xA0" => "\\~", # Latin-1 non-breaking space + "\xAD" => "\\-", # Latin-1 soft (optional) hyphen + + # CRAZY HACKS: + "\n" => "\\line\n", + "\r" => "\n", + "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1 + "\cc" => "}", +); +1; + +__END__ + +=head1 NAME + +Pod::Simple::RTF -- format Pod as RTF + +=head1 SYNOPSIS + + perl -MPod::Simple::RTF -e \ + "exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \ + thingy.pod > thingy.rtf + +=head1 DESCRIPTION + +This class is a formatter that takes Pod and renders it as RTF, good for +viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc. + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +=head1 FORMAT CONTROL ATTRIBUTES + +You can set these attributes on the parser object before you +call C<parse_file> (or a similar method) on it: + +=over + +=item $parser->head1_halfpoint_size( I<halfpoint_integer> ); + +=item $parser->head2_halfpoint_size( I<halfpoint_integer> ); + +=item $parser->head3_halfpoint_size( I<halfpoint_integer> ); + +=item $parser->head4_halfpoint_size( I<halfpoint_integer> ); + +These methods set the size (in half-points, like 52 for 26-point) +that these heading levels will appear as. + +=item $parser->codeblock_halfpoint_size( I<halfpoint_integer> ); + +This method sets the size (in half-points, like 21 for 10.5-point) +that codeblocks ("verbatim sections") will appear as. + +=item $parser->header_halfpoint_size( I<halfpoint_integer> ); + +This method sets the size (in half-points, like 15 for 7.5-point) +that the header on each page will appear in. The header +is usually just "I<modulename> p. I<pagenumber>". + +=item $parser->normal_halfpoint_size( I<halfpoint_integer> ); + +This method sets the size (in half-points, like 26 for 13-point) +that normal paragraphic text will appear in. + +=item $parser->no_proofing_exemptions( I<true_or_false> ); + +Set this value to true if you don't want the formatter to try +putting a hidden code on all Perl symbols (as best as it can +notice them) that labels them as being not in English, and +so not worth spellchecking. + +=item $parser->doc_lang( I<microsoft_decimal_language_code> ) + +This sets the language code to tag this document as being in. By +default, it is currently the value of the environment variable +C<RTFDEFLANG>, or if that's not set, then the value +1033 (for US English). + +Setting this appropriately is useful if you want to use the RTF +to spellcheck, and/or if you want it to hyphenate right. + +Here are some notable values: + + 1033 US English + 2057 UK English + 3081 Australia English + 4105 Canada English + 1034 Spain Spanish + 2058 Mexico Spanish + 1031 Germany German + 1036 France French + 3084 Canada French + 1035 Finnish + 1044 Norwegian (Bokmal) + 2068 Norwegian (Nynorsk) + +=back + +If you are particularly interested in customizing this module's output +even more, see the source and/or write to me. + +=head1 SEE ALSO + +L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>, +L<RTF::Generator> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm new file mode 100644 index 00000000000..762701aa9cc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm @@ -0,0 +1,1043 @@ + +require 5.005; +package Pod::Simple::Search; +use strict; + +use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); +$VERSION = '3.14'; ## Current version of this package + +BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level +use Carp (); + +$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; + # flag to occasionally sleep for $SLEEPY - 1 seconds. + +$MAX_VERSION_WITHIN ||= 60; + +############################################################################# + +#use diagnostics; +use File::Spec (); +use File::Basename qw( basename ); +use Config (); +use Cwd qw( cwd ); + +#========================================================================== +__PACKAGE__->_accessorize( # Make my dumb accessor methods + 'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob', + 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', +); +#========================================================================== + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + $self->init; + return $self; +} + +sub init { + my $self = shift; + $self->inc(1); + $self->verbose(DEBUG); + return $self; +} + +#-------------------------------------------------------------------------- + +sub survey { + my($self, @search_dirs) = @_; + $self = $self->new unless ref $self; # tolerate being a class method + + $self->_expand_inc( \@search_dirs ); + + + $self->{'_scan_count'} = 0; + $self->{'_dirs_visited'} = {}; + $self->path2name( {} ); + $self->name2path( {} ); + $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'}; + my $cwd = cwd(); + my $verbose = $self->verbose; + local $_; # don't clobber the caller's $_ ! + + foreach my $try (@search_dirs) { + unless( File::Spec->file_name_is_absolute($try) ) { + # make path absolute + $try = File::Spec->catfile( $cwd ,$try); + } + # simplify path + $try = File::Spec->canonpath($try); + + my $start_in; + my $modname_prefix; + if($self->{'dir_prefix'}) { + $start_in = File::Spec->catdir( + $try, + grep length($_), split '[\\/:]+', $self->{'dir_prefix'} + ); + $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}]; + $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ", + "giving $start_in (= @$modname_prefix)\n"; + } else { + $start_in = $try; + } + + if( $self->{'_dirs_visited'}{$start_in} ) { + $verbose and print "Directory '$start_in' already seen, skipping.\n"; + next; + } else { + $self->{'_dirs_visited'}{$start_in} = 1; + } + + unless(-e $start_in) { + $verbose and print "Skipping non-existent $start_in\n"; + next; + } + + my $closure = $self->_make_search_callback; + + if(-d $start_in) { + # Normal case: + $verbose and print "Beginning excursion under $start_in\n"; + $self->_recurse_dir( $start_in, $closure, $modname_prefix ); + $verbose and print "Back from excursion under $start_in\n\n"; + + } elsif(-f _) { + # A excursion consisting of just one file! + $_ = basename($start_in); + $verbose and print "Pondering $start_in ($_)\n"; + $closure->($start_in, $_, 0, []); + + } else { + $verbose and print "Skipping mysterious $start_in\n"; + } + } + $self->progress and $self->progress->done( + "Noted $$self{'_scan_count'} Pod files total"); + + return unless defined wantarray; # void + return $self->name2path unless wantarray; # scalar + return $self->name2path, $self->path2name; # list +} + + +#========================================================================== +sub _make_search_callback { + my $self = $_[0]; + + # Put the options in variables, for easy access + my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,$path2name,$name2path) = + map scalar($self->$_()), + qw(laborious verbose shadows limit_re callback progress path2name name2path); + + my($file, $shortname, $isdir, $modname_bits); + return sub { + ($file, $shortname, $isdir, $modname_bits) = @_; + + if($isdir) { # this never gets called on the startdir itself, just subdirs + + if( $self->{'_dirs_visited'}{$file} ) { + $verbose and print "Directory '$file' already seen, skipping.\n"; + return 'PRUNE'; + } + + print "Looking in dir $file\n" if $verbose; + + unless ($laborious) { # $laborious overrides pruning + if( m/^(\d+\.[\d_]{3,})\z/s + and do { my $x = $1; $x =~ tr/_//d; $x != $] } + ) { + $verbose and print "Perl $] version mismatch on $_, skipping.\n"; + return 'PRUNE'; + } + + if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) { + $verbose and print "$_ is a well-named module subdir. Looking....\n"; + } else { + $verbose and print "$_ is a fishy directory name. Skipping.\n"; + return 'PRUNE'; + } + } # end unless $laborious + + $self->{'_dirs_visited'}{$file} = 1; + return; # (not pruning); + } + + + # Make sure it's a file even worth even considering + if($laborious) { + unless( + m/\.(pod|pm|plx?)\z/i || -x _ and -T _ + # Note that the cheapest operation (the RE) is run first. + ) { + $verbose > 1 and print " Brushing off uninteresting $file\n"; + return; + } + } else { + unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) { + $verbose > 1 and print " Brushing off oddly-named $file\n"; + return; + } + } + + $verbose and print "Considering item $file\n"; + my $name = $self->_path2modname( $file, $shortname, $modname_bits ); + $verbose > 0.01 and print " Nominating $file as $name\n"; + + if($limit_re and $name !~ m/$limit_re/i) { + $verbose and print "Shunning $name as not matching $limit_re\n"; + return; + } + + if( !$shadows and $name2path->{$name} ) { + $verbose and print "Not worth considering $file ", + "-- already saw $name as ", + join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n"; + return; + } + + # Put off until as late as possible the expense of + # actually reading the file: + if( m/\.pod\z/is ) { + # just assume it has pod, okay? + } else { + $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file"); + return unless $self->contains_pod( $file ); + } + ++ $self->{'_scan_count'}; + + # Or finally take note of it: + if( $name2path->{$name} ) { + $verbose and print + "Duplicate POD found (shadowing?): $name ($file)\n", + " Already seen in ", + join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n"; + } else { + $name2path->{$name} = $file; # Noting just the first occurrence + } + $verbose and print " Noting $name = $file\n"; + if( $callback ) { + local $_ = $_; # insulate from changes, just in case + $callback->($file, $name); + } + $path2name->{$file} = $name; + return; + } +} + +#========================================================================== + +sub _path2modname { + my($self, $file, $shortname, $modname_bits) = @_; + + # 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 perl*.pod (e.g. in pod/perlfunc.pod) + # * dig into the file for case-preserved name if not already mixed case + + my @m = @$modname_bits; + my $x; + my $verbose = $self->verbose; + + # Shaving off leading naughty-bits + while(@m + and defined($x = lc( $m[0] )) + and( $x eq 'site_perl' + or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) + or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum + or $x eq lc( $Config::Config{'archname'} ) + )) { shift @m } + + my $name = join '::', @m, $shortname; + $self->_simplify_base($name); + + # On VMS, case-preserved document names can't be constructed from + # filenames, so try to extract them from the "=head1 NAME" tag in the + # file instead. + if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) { + open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!"; + my $in_pod = 0; + my $in_name = 0; + my $line; + while ($line = <PODFILE>) { + chomp $line; + $in_pod = 1 if ($line =~ m/^=\w/); + $in_pod = 0 if ($line =~ m/^=cut/); + next unless $in_pod; # skip non-pod text + next if ($line =~ m/^\s*\z/); # and blank lines + next if ($in_pod && ($line =~ m/^X</)); # and commands + if ($in_name) { + if ($line =~ m/(\w+::)?(\w+)/) { + # substitute case-preserved version of name + my $podname = $2; + my $prefix = $1 || ''; + $verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n"; + unless ($name =~ s/$prefix$podname/$prefix$podname/i) { + $verbose and print "Attempting case restore of '$name' from '$podname'\n"; + $name =~ s/$podname/$podname/i; + } + last; + } + } + $in_name = 1 if ($line =~ m/^=head1 NAME/); + } + close PODFILE; + } + + return $name; +} + +#========================================================================== + +sub _recurse_dir { + my($self, $startdir, $callback, $modname_bits) = @_; + + my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10; + my $verbose = $self->verbose; + + my $here_string = File::Spec->curdir; + my $up_string = File::Spec->updir; + $modname_bits ||= []; + + my $recursor; + $recursor = sub { + my($dir_long, $dir_bare) = @_; + if( @$modname_bits >= 10 ) { + $verbose and print "Too deep! [@$modname_bits]\n"; + return; + } + + unless(-d $dir_long) { + $verbose > 2 and print "But it's not a dir! $dir_long\n"; + return; + } + unless( opendir(INDIR, $dir_long) ) { + $verbose > 2 and print "Can't opendir $dir_long : $!\n"; + closedir(INDIR); + return + } + my @items = sort readdir(INDIR); + closedir(INDIR); + + push @$modname_bits, $dir_bare unless $dir_bare eq ''; + + my $i_full; + foreach my $i (@items) { + next if $i eq $here_string or $i eq $up_string or $i eq ''; + $i_full = File::Spec->catfile( $dir_long, $i ); + + if(!-r $i_full) { + $verbose and print "Skipping unreadable $i_full\n"; + + } elsif(-f $i_full) { + $_ = $i; + $callback->( $i_full, $i, 0, $modname_bits ); + + } elsif(-d _) { + $i =~ s/\.DIR\z//i if $^O eq 'VMS'; + $_ = $i; + my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || ''; + + if($rv eq 'PRUNE') { + $verbose > 1 and print "OK, pruning"; + } else { + # Otherwise, recurse into it + $recursor->( File::Spec->catdir($dir_long, $i) , $i); + } + } else { + $verbose > 1 and print "Skipping oddity $i_full\n"; + } + } + pop @$modname_bits; + return; + };; + + local $_; + $recursor->($startdir, ''); + + undef $recursor; # allow it to be GC'd + + return; +} + + +#========================================================================== + +sub run { + # A function, useful in one-liners + + my $self = __PACKAGE__->new; + $self->limit_glob($ARGV[0]) if @ARGV; + $self->callback( sub { + my($file, $name) = @_; + my $version = ''; + + # Yes, I know we won't catch the version in like a File/Thing.pm + # if we see File/Thing.pod first. That's just the way the + # cookie crumbles. -- SMB + + if($file =~ m/\.pod$/i) { + # Don't bother looking for $VERSION in .pod files + DEBUG and print "Not looking for \$VERSION in .pod $file\n"; + } elsif( !open(INPOD, $file) ) { + DEBUG and print "Couldn't open $file: $!\n"; + close(INPOD); + } else { + # Sane case: file is readable + my $lines = 0; + while(<INPOD>) { + last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity + if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) { + DEBUG and print "Found version line (#$lines): $_"; + s/\s*\#.*//s; + s/\;\s*$//s; + s/\s+$//s; + s/\t+/ /s; # nix tabs + # Optimize the most common cases: + $_ = "v$1" + if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s + # like in $VERSION = "3.14159"; + or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s + # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/); + ; + + # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/) + $_ = sprintf("v%d.%s", + map {s/_//g; $_} + $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part + if m{\$Name:\s*([^\$]+)\$}s + ; + $version = $_; + DEBUG and print "Noting $version as version\n"; + last; + } + } + close(INPOD); + } + print "$name\t$version\t$file\n"; + return; + # End of callback! + }); + + $self->survey; +} + +#========================================================================== + +sub simplify_name { + my($self, $str) = @_; + + # Remove all path components + # XXX Why not just use basename()? -- SMB + + if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s } + else { $str =~ s{^.*/+}{}s } + + $self->_simplify_base($str); + return $str; +} + +#========================================================================== + +sub _simplify_base { # Internal method only + + # strip Perl's own extensions + $_[1] =~ s/\.(pod|pm|plx?)\z//i; + + # strip meaningless extensions on Win32 and OS/2 + $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i; + + # strip meaningless extensions on VMS + $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS'; + + return; +} + +#========================================================================== + +sub _expand_inc { + my($self, $search_dirs) = @_; + + return unless $self->{'inc'}; + + if ($^O eq 'MacOS') { + push @$search_dirs, + grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC); + # Any other OSs need custom handling here? + } else { + push @$search_dirs, grep $_ ne File::Spec->curdir, @INC; + } + + $self->{'laborious'} = 0; # Since inc said to use INC + return; +} + +#========================================================================== + +sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @them; + (undef,@them) = @_; + for $_ (@them) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { + $_ = ':'. $_; + } else { + $_ =~ s|^\./|:|; + } + } + return @them; +} + +#========================================================================== + +sub _limit_glob_to_limit_re { + my $self = $_[0]; + my $limit_glob = $self->{'limit_glob'} || return; + + my $limit_re = '^' . quotemeta($limit_glob) . '$'; + $limit_re =~ s/\\\?/./g; # glob "?" => "." + $limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?" + $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => "" + + $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n"; + + # A common optimization: + if(!exists($self->{'dir_prefix'}) + and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*" + # Optimize for sane and common cases (but not things like "*::File") + ) { + $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg; + $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n"; + } + + return $limit_re; +} + +#========================================================================== + +# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu> + +sub find { + my($self, $pod, @search_dirs) = @_; + $self = $self->new unless ref $self; # tolerate being a class method + + # Check usage + Carp::carp 'Usage: \$self->find($podname, ...)' + unless defined $pod and length $pod; + + my $verbose = $self->verbose; + + # Split on :: and then join the name together using File::Spec + my @parts = split /::/, $pod; + $verbose and print "Chomping {$pod} => {@parts}\n"; + + #@search_dirs = File::Spec->curdir unless @search_dirs; + + if( $self->inc ) { + if( $^O eq 'MacOS' ) { + push @search_dirs, $self->_mac_whammy(@INC); + } else { + 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'}; + # and if that's undef or q{} or nonexistent, we just ignore it later + } + + my %seen_dir; + Dir: + foreach my $dir ( @search_dirs ) { + next unless defined $dir and length $dir; + next if $seen_dir{$dir}; + $seen_dir{$dir} = 1; + unless(-d $dir) { + print "Directory $dir does not exist\n" if $verbose; + next Dir; + } + + print "Looking in directory $dir\n" if $verbose; + my $fullname = File::Spec->catfile( $dir, @parts ); + print "Filename is now $fullname\n" if $verbose; + + foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions + my $fullext = $fullname . $ext; + if( -f $fullext and $self->contains_pod( $fullext ) ){ + print "FOUND: $fullext\n" if $verbose; + return $fullext; + } + } + my $subdir = File::Spec->catdir($dir,'pod'); + if(-d $subdir) { # slip in the ./pod dir too + $verbose and print "Noticing $subdir and stopping there...\n"; + $dir = $subdir; + redo Dir; + } + } + + return undef; +} + +#========================================================================== + +sub contains_pod { + my($self, $file) = @_; + my $verbose = $self->{'verbose'}; + + # check for one line of POD + $verbose > 1 and print " Scanning $file for pod...\n"; + unless( open(MAYBEPOD,"<$file") ) { + print "Error: $file is unreadable: $!\n"; + return undef; + } + + sleep($SLEEPY - 1) if $SLEEPY; + # avoid totally hogging the processor on OSs with poor process control + + local $_; + while( <MAYBEPOD> ) { + if(m/^=(head\d|pod|over|item)\b/s) { + close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting"; + chomp; + $verbose > 1 and print " Found some pod ($_) in $file\n"; + return 1; + } + } + close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting"; + $verbose > 1 and print " No POD in $file, skipping.\n"; + return 0; +} + +#========================================================================== + +sub _accessorize { # A simple-minded method-maker + shift; + no strict 'refs'; + foreach my $attrname (@_) { + *{caller() . '::' . $attrname} = sub { + use strict; + $Carp::CarpLevel = 1, Carp::croak( + "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" + ) unless (@_ == 1 or @_ == 2) and ref $_[0]; + + # Read access: + return $_[0]->{$attrname} if @_ == 1; + + # Write access: + $_[0]->{$attrname} = $_[1]; + return $_[0]; # RETURNS MYSELF! + }; + } + # Ya know, they say accessories make the ensemble! + return; +} + +#========================================================================== +sub _state_as_string { + my $self = $_[0]; + return '' unless ref $self; + my @out = "{\n # State of $self ...\n"; + foreach my $k (sort keys %$self) { + push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n"; + } + push @out, "}\n"; + my $x = join '', @out; + $x =~ s/^/#/mg; + return $x; +} + +sub _esc { + my $in = $_[0]; + return 'undef' unless defined $in; + $in =~ + s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> + <'\\x'.(unpack("H2",$1))>eg; + return qq{"$in"}; +} + +#========================================================================== + +run() unless caller; # run if "perl whatever/Search.pm" + +1; + +#========================================================================== + +__END__ + + +=head1 NAME + +Pod::Simple::Search - find POD documents in directory trees + +=head1 SYNOPSIS + + use Pod::Simple::Search; + my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey; + print "Looky see what I found: ", + join(' ', sort keys %$name2path), "\n"; + + print "LWPUA docs = ", + Pod::Simple::Search->new->find('LWP::UserAgent') || "?", + "\n"; + +=head1 DESCRIPTION + +B<Pod::Simple::Search> is a class that you use for running searches +for Pod files. An object of this class has several attributes +(mostly options for controlling search options), and some methods +for searching based on those attributes. + +The way to use this class is to make a new object of this class, +set any options, and then call one of the search options +(probably C<survey> or C<find>). The sections below discuss the +syntaxes for doing all that. + + +=head1 CONSTRUCTOR + +This class provides the one constructor, called C<new>. +It takes no parameters: + + use Pod::Simple::Search; + my $search = Pod::Simple::Search->new; + +=head1 ACCESSORS + +This class defines several methods for setting (and, occasionally, +reading) the contents of an object. With two exceptions (discussed at +the end of this section), these attributes are just for controlling the +way searches are carried out. + +Note that each of these return C<$self> when you call them as +C<< $self->I<whatever(value)> >>. That's so that you can chain +together set-attribute calls like this: + + my $name2path = + Pod::Simple::Search->new + -> inc(0) -> verbose(1) -> callback(\&blab) + ->survey(@there); + +...which works exactly as if you'd done this: + + my $search = Pod::Simple::Search->new; + $search->inc(0); + $search->verbose(1); + $search->callback(\&blab); + my $name2path = $search->survey(@there); + +=over + +=item $search->inc( I<true-or-false> ); + +This attribute, if set to a true value, means that searches should +implicitly add perl's I<@INC> paths. This +automatically considers paths specified in the C<PERL5LIB> environment +as this is prepended to I<@INC> by the Perl interpreter itself. +This attribute's default value is B<TRUE>. If you want to search +only specific directories, set $self->inc(0) before calling +$inc->survey or $inc->find. + + +=item $search->verbose( I<nonnegative-number> ); + +This attribute, if set to a nonzero positive value, will make searches output +(via C<warn>) notes about what they're doing as they do it. +This option may be useful for debugging a pod-related module. +This attribute's default value is zero, meaning that no C<warn> messages +are produced. (Setting verbose to 1 turns on some messages, and setting +it to 2 turns on even more messages, i.e., makes the following search(es) +even more verbose than 1 would make them.) + + +=item $search->limit_glob( I<some-glob-string> ); + +This option means that you want to limit the results just to items whose +podnames match the given glob/wildcard expression. For example, you +might limit your search to just "LWP::*", to search only for modules +starting with "LWP::*" (but not including the module "LWP" itself); or +you might limit your search to "LW*" to see only modules whose (full) +names begin with "LW"; or you might search for "*Find*" to search for +all modules with "Find" somewhere in their full name. (You can also use +"?" in a glob expression; so "DB?" will match "DBI" and "DBD".) + + +=item $search->callback( I<\&some_routine> ); + +This attribute means that every time this search sees a matching +Pod file, it should call this callback routine. The routine is called +with two parameters: the current file's filespec, and its pod name. +(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would +be in C<@_>.) + +The callback routine's return value is not used for anything. + +This attribute's default value is false, meaning that no callback +is called. + +=item $search->laborious( I<true-or-false> ); + +Unless you set this attribute to a true value, Pod::Search will +apply Perl-specific heuristics to find the correct module PODs quickly. +This attribute's default value is false. You won't normally need +to set this to true. + +Specifically: Turning on this option will disable the heuristics for +seeing only files with Perl-like extensions, omitting subdirectories +that are numeric but do I<not> match the current Perl interpreter's +version ID, suppressing F<site_perl> as a module hierarchy name, etc. + + +=item $search->shadows( I<true-or-false> ); + +Unless you set this attribute to a true value, Pod::Simple::Search will +consider only the first file of a given modulename as it looks thru the +specified directories; that is, with this option off, if +Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this +search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm> +later on in that search, because that file is merely a "shadow". But if +you turn on C<< $self->shadows(1) >>, then these "shadow" files are +inspected too, and are noted in the pathname2podname return hash. + +This attribute's default value is false; and normally you won't +need to turn it on. + + +=item $search->limit_re( I<some-regxp> ); + +Setting this attribute (to a value that's a regexp) means that you want +to limit the results just to items whose podnames match the given +regexp. Normally this option is not needed, and the more efficient +C<limit_glob> attribute is used instead. + + +=item $search->dir_prefix( I<some-string-value> ); + +Setting this attribute to a string value means that the searches should +begin in the specified subdirectory name (like "Pod" or "File::Find", +also expressable as "File/Find"). For example, the search option +C<< $search->limit_glob("File::Find::R*") >> +is the same as the combination of the search options +C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>. + +Normally you don't need to know about the C<dir_prefix> option, but I +include it in case it might prove useful for someone somewhere. + +(Implementationally, searching with limit_glob ends up setting limit_re +and usually dir_prefix.) + + +=item $search->progress( I<some-progress-object> ); + +If you set a value for this attribute, the value is expected +to be an object (probably of a class that you define) that has a +C<reach> method and a C<done> method. This is meant for reporting +progress during the search, if you don't want to use a simple +callback. + +Normally you don't need to know about the C<progress> option, but I +include it in case it might prove useful for someone somewhere. + +While a search is in progress, the progress object's C<reach> and +C<done> methods are called like this: + + # Every time a file is being scanned for pod: + $progress->reach($count, "Scanning $file"); ++$count; + + # And then at the end of the search: + $progress->done("Noted $count Pod files total"); + +Internally, we often set this to an object of class +Pod::Simple::Progress. That class is probably undocumented, +but you may wish to look at its source. + + +=item $name2path = $self->name2path; + +This attribute is not a search parameter, but is used to report the +result of C<survey> method, as discussed in the next section. + +=item $path2name = $self->path2name; + +This attribute is not a search parameter, but is used to report the +result of C<survey> method, as discussed in the next section. + +=back + +=head1 MAIN SEARCH METHODS + +Once you've actually set any options you want (if any), you can go +ahead and use the following methods to search for Pod files +in particular ways. + + +=head2 C<< $search->survey( @directories ) >> + +The method C<survey> searches for POD documents in a given set of +files and/or directories. This runs the search according to the various +options set by the accessors above. (For example, if the C<inc> attribute +is on, as it is by default, then the perl @INC directories are implicitly +added to the list of directories (if any) that you specify.) + +The return value of C<survey> is two hashes: + +=over + +=item C<name2path> + +A hash that maps from each pod-name to the filespec (like +"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm") + +=item C<path2name> + +A hash that maps from each Pod filespec to its pod-name (like +"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing") + +=back + +Besides saving these hashes as the hashref attributes +C<name2path> and C<path2name>, calling this function also returns +these hashrefs. In list context, the return value of +C<< $search->survey >> is the list C<(\%name2path, \%path2name)>. +In scalar context, the return value is C<\%name2path>. +Or you can just call this in void context. + +Regardless of calling context, calling C<survey> saves +its results in its C<name2path> and C<path2name> attributes. + +E.g., when searching in F<$HOME/perl5lib>, the file +F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, +whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be +I<Myclass::Subclass>. The name information can be used for POD +translators. + +Only text files containing at least one valid POD command are found. + +In verbose mode, a warning is printed if shadows are found (i.e., more +than one POD file with the same POD name is found, e.g. F<CPAN.pm> in +different directories). This usually indicates duplicate occurrences of +modules in the I<@INC> search path, which is occasionally inadvertent +(but is often simply a case of a user's path dir having a more recent +version than the system's general path dirs in general.) + +The options to this argument is a list of either directories that are +searched recursively, or files. (Usually you wouldn't specify files, +but just dirs.) Or you can just specify an empty-list, as in +$name2path; with the +C<inc> option on, as it is by default, teh + +The POD names of files are the plain basenames with any Perl-like +extension (.pm, .pl, .pod) stripped, and path separators replaced by +C<::>'s. + +Calling Pod::Simple::Search->search(...) is short for +Pod::Simple::Search->new->search(...). That is, a throwaway object +with default attribute values is used. + + +=head2 C<< $search->simplify_name( $str ) >> + +The method B<simplify_name> is equivalent to B<basename>, 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. + + +=head2 C<< $search->find( $pod ) >> + +=head2 C<< $search->find( $pod, @search_dirs ) >> + +Returns the location of a Pod file, given a Pod/module/script name +(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of +what files/directories to look in. +It searches according to the various options set by the accessors above. +(For example, if the C<inc> attribute is on, as it is by default, then +the perl @INC directories are implicitly added to the list of +directories (if any) that you specify.) + +This 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. Additionally, '.pm', '.pl' and '.pod' +are automatically appended to the search as required. +(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm", +"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.) + +If no such Pod file is found, this method returns undef. + +If any of the given search directories contains a F<pod/> subdirectory, +then it is searched. (That's how we manage to find F<perlfunc>, +for example, which is usually in F<pod/perlfunc> in most Perl dists.) + +The C<verbose> and C<inc> attributes influence the behavior of this +search; notably, C<inc>, if true, adds @INC I<and also +$Config::Config{'scriptdir'}> to the list of directories to search. + +It is common to simply say C<< $filename = Pod::Simple::Search-> new +->find("perlvar") >> so that just the @INC (well, and scriptdir) +directories are searched. (This happens because the C<inc> +attribute is true by default.) + +Calling Pod::Simple::Search->find(...) is short for +Pod::Simple::Search->new->find(...). That is, a throwaway object +with default attribute values is used. + + +=head2 C<< $self->contains_pod( $file ) >> + +Returns true if the supplied filename (not POD module) contains some Pod +documentation. +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org> with code borrowed +from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from +Nick Ing-Simmons' C<PodToHtml>. + +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm new file mode 100644 index 00000000000..32db4b6a51d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm @@ -0,0 +1,180 @@ + + +require 5; +package Pod::Simple::SimpleTree; +use strict; +use Carp (); +use Pod::Simple (); +use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); +$VERSION = '3.14'; +BEGIN { + @ISA = ('Pod::Simple'); + *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; +} + +__PACKAGE__->_accessorize( + 'root', # root of the tree +); + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub _handle_element_start { # self, tagname, attrhash + DEBUG > 2 and print "Handling $_[1] start-event\n"; + my $x = [$_[1], $_[2]]; + if($_[0]{'_currpos'}) { + push @{ $_[0]{'_currpos'}[0] }, $x; # insert in parent's child-list + unshift @{ $_[0]{'_currpos'} }, $x; # prefix to stack + } else { + DEBUG and print " And oo, it gets to be root!\n"; + $_[0]{'_currpos'} = [ $_[0]{'root'} = $x ]; + # first event! set to stack, and set as root. + } + DEBUG > 3 and print "Stack is now: ", + join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n"; + return; +} + +sub _handle_element_end { # self, tagname + DEBUG > 2 and print "Handling $_[1] end-event\n"; + shift @{$_[0]{'_currpos'}}; + DEBUG > 3 and print "Stack is now: ", + join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n"; + return; +} + +sub _handle_text { # self, text + DEBUG > 2 and print "Handling $_[1] text-event\n"; + push @{ $_[0]{'_currpos'}[0] }, $_[1]; + return; +} + + +# A bit of evil from the black box... please avert your eyes, kind souls. +sub _traverse_treelet_bit { + DEBUG > 2 and print "Handling $_[1] paragraph event\n"; + my $self = shift; + push @{ $self->{'_currpos'}[0] }, [@_]; + return; +} +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1; +__END__ + +=head1 NAME + +Pod::Simple::SimpleTree -- parse Pod into a simple parse tree + +=head1 SYNOPSIS + + % cat ptest.pod + + =head1 PIE + + I like B<pie>! + + % perl -MPod::Simple::SimpleTree -MData::Dumper -e \ + "print Dumper(Pod::Simple::SimpleTree->new->parse_file(shift)->root)" \ + ptest.pod + + $VAR1 = [ + 'Document', + { 'start_line' => 1 }, + [ + 'head1', + { 'start_line' => 1 }, + 'PIE' + ], + [ + 'Para', + { 'start_line' => 3 }, + 'I like ', + [ + 'B', + {}, + 'pie' + ], + '!' + ] + ]; + +=head1 DESCRIPTION + +This class is of interest to people writing a Pod processor/formatter. + +This class takes Pod and parses it, returning a parse tree made just +of arrayrefs, and hashrefs, and strings. + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +This class is inspired by XML::Parser's "Tree" parsing-style, although +it doesn't use exactly the same LoL format. + +=head1 METHODS + +At the end of the parse, call C<< $parser->root >> to get the +tree's top node. + +=head1 Tree Contents + +Every element node in the parse tree is represented by an arrayref of +the form: C<[ I<elementname>, \%attributes, I<...subnodes...> ]>. +See the example tree dump in the Synopsis, above. + +Every text node in the tree is represented by a simple (non-ref) +string scalar. So you can test C<ref($node)> to see whather you have +an element node or just a text node. + +The top node in the tree is C<[ 'Document', \%attributes, +I<...subnodes...> ]> + + +=head1 SEE ALSO + +L<Pod::Simple> + +L<perllol> + +L<The "Tree" subsubsection in XML::Parser|XML::Parser/"Tree"> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod new file mode 100644 index 00000000000..f2011d5a5ce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod @@ -0,0 +1,946 @@ + +=head1 NAME + +Pod::Simple::Subclassing -- write a formatter as a Pod::Simple subclass + +=head1 SYNOPSIS + + package Pod::SomeFormatter; + use Pod::Simple; + @ISA = qw(Pod::Simple); + $VERSION = '1.01'; + use strict; + + sub _handle_element_start { + my($parser, $element_name, $attr_hash_r) = @_; + ... + } + + sub _handle_element_end { + my($parser, $element_name) = @_; + ... + } + + sub _handle_text { + my($parser, $text) = @_; + ... + } + 1; + +=head1 DESCRIPTION + +This document is about using Pod::Simple to write a Pod processor, +generally a Pod formatter. If you just want to know about using an +existing Pod formatter, instead see its documentation and see also the +docs in L<Pod::Simple>. + +The zeroeth step in writing a Pod formatter is to make sure that there +isn't already a decent one in CPAN. See L<http://search.cpan.org/>, and +run a search on the name of the format you want to render to. Also +consider joining the Pod People list +L<http://lists.perl.org/showlist.cgi?name=pod-people> and asking whether +anyone has a formatter for that format -- maybe someone cobbled one +together but just hasn't released it. + +The first step in writing a Pod processor is to read L<perlpodspec>, +which contains notes information on writing a Pod parser (which has been +largely taken care of by Pod::Simple), but also a lot of requirements +and recommendations for writing a formatter. + +The second step is to actually learn the format you're planning to +format to -- or at least as much as you need to know to represent Pod, +which probably isn't much. + +The third step is to pick which of Pod::Simple's interfaces you want to +use -- the basic interface via Pod::Simple or L<Pod::Simple::Methody> is +event-based, sort of like L<HTML::Parser>'s interface, or sort of like +L<XML::Parser>'s "Handlers" interface), but L<Pod::Simple::PullParser> +provides a token-stream interface, sort of like L<HTML::TokeParser>'s +interface; L<Pod::Simple::SimpleTree> provides a simple tree interface, +rather like XML::Parser's "Tree" interface. Users familiar with +XML-handling will find one of these styles relatively familiar; but if +you would be even more at home with XML, there are classes that produce +an XML representation of the Pod stream, notably +L<Pod::Simple::XMLOutStream>; you can feed the output of such a class to +whatever XML parsing system you are most at home with. + +The last step is to write your code based on how the events (or tokens, +or tree-nodes, or the XML, or however you're parsing) will map to +constructs in the output format. Also sure to consider how to escape +text nodes containing arbitrary text, and also what to do with text +nodes that represent preformatted text (from verbatim sections). + + + +=head1 Events + +TODO intro... mention that events are supplied for implicits, like for +missing >'s + + +In the following section, we use XML to represent the event structure +associated with a particular construct. That is, TODO + +=over + +=item C<< $parser->_handle_element_start( I<element_name>, I<attr_hashref> ) >> + +=item C<< $parser->_handle_element_end( I<element_name> ) >> + +=item C<< $parser->_handle_text( I<text_string> ) >> + +=back + +TODO describe + + +=over + +=item events with an element_name of Document + +Parsing a document produces this event structure: + + <Document start_line="543"> + ...all events... + </Document> + +The value of the I<start_line> attribute will be the line number of the first +Pod directive in the document. + +If there is no Pod in the given document, then the +event structure will be this: + + <Document contentless="1" start_line="543"> + </Document> + +In that case, the value of the I<start_line> attribute will not be meaningful; +under current implementations, it will probably be the line number of the +last line in the file. + +=item events with an element_name of Para + +Parsing a plain (non-verbatim, non-directive, non-data) paragraph in +a Pod document produces this event structure: + + <Para start_line="543"> + ...all events in this paragraph... + </Para> + +The value of the I<start_line> attribute will be the line number of the start +of the paragraph. + +For example, parsing this paragraph of Pod: + + The value of the I<start_line> attribute will be the + line number of the start of the paragraph. + +produces this event structure: + + <Para start_line="129"> + The value of the + <I> + start_line + </I> + attribute will be the line number of the first Pod directive + in the document. + </Para> + +=item events with an element_name of B, C, F, or I. + +Parsing a BE<lt>...E<gt> formatting code (or of course any of its +semantically identical syntactic variants +S<BE<lt>E<lt> ... E<gt>E<gt>>, +or S<BE<lt>E<lt>E<lt>E<lt> ... E<gt>E<gt>E<gt>E<gt>>, etc.) +produces this event structure: + + <B> + ...stuff... + </B> + +Currently, there are no attributes conveyed. + +Parsing C, F, or I codes produce the same structure, with only a +different element name. + +If your parser object has been set to accept other formatting codes, +then they will be presented like these B/C/F/I codes -- i.e., without +any attributes. + +=item events with an element_name of S + +Normally, parsing an SE<lt>...E<gt> sequence produces this event +structure, just as if it were a B/C/F/I code: + + <S> + ...stuff... + </S> + +However, Pod::Simple (and presumably all derived parsers) offers the +C<nbsp_for_S> option which, if enabled, will suppress all S events, and +instead change all spaces in the content to non-breaking spaces. This is +intended for formatters that output to a format that has no code that +means the same as SE<lt>...E<gt>, but which has a code/character that +means non-breaking space. + +=item events with an element_name of X + +Normally, parsing an XE<lt>...E<gt> sequence produces this event +structure, just as if it were a B/C/F/I code: + + <X> + ...stuff... + </X> + +However, Pod::Simple (and presumably all derived parsers) offers the +C<nix_X_codes> option which, if enabled, will suppress all X events +and ignore their content. For formatters/processors that don't use +X events, this is presumably quite useful. + + +=item events with an element_name of L + +Because the LE<lt>...E<gt> is the most complex construct in the +language, it should not surprise you that the events it generates are +the most complex in the language. Most of complexity is hidden away in +the attribute values, so for those of you writing a Pod formatter that +produces a non-hypertextual format, you can just ignore the attributes +and treat an L event structure like a formatting element that +(presumably) doesn't actually produce a change in formatting. That is, +the content of the L event structure (as opposed to its +attributes) is always what text should be displayed. + +There are, at first glance, three kinds of L links: URL, man, and pod. + +When a LE<lt>I<some_url>E<gt> code is parsed, it produces this event +structure: + + <L content-implicit="yes" to="that_url" type="url"> + that_url + </L> + +The C<type="url"> attribute is always specified for this type of +L code. + +For example, this Pod source: + + L<http://www.perl.com/CPAN/authors/> + +produces this event structure: + + <L content-implicit="yes" to="http://www.perl.com/CPAN/authors/" type="url"> + http://www.perl.com/CPAN/authors/ + </L> + +When a LE<lt>I<manpage(section)>E<gt> code is parsed (and these are +fairly rare and not terribly useful), it produces this event structure: + + <L content-implicit="yes" to="manpage(section)" type="man"> + manpage(section) + </L> + +The C<type="man"> attribute is always specified for this type of +L code. + +For example, this Pod source: + + L<crontab(5)> + +produces this event structure: + + <L content-implicit="yes" to="crontab(5)" type="man"> + crontab(5) + </L> + +In the rare cases where a man page link has a specified, that text appears +in a I<section> attribute. For example, this Pod source: + + L<crontab(5)/"ENVIRONMENT"> + +will produce this event structure: + + <L content-implicit="yes" section="ENVIRONMENT" to="crontab(5)" type="man"> + "ENVIRONMENT" in crontab(5) + </L> + +In the rare case where the Pod document has code like +LE<lt>I<sometext>|I<manpage(section)>E<gt>, then the I<sometext> will appear +as the content of the element, the I<manpage(section)> text will appear +only as the value of the I<to> attribute, and there will be no +C<content-implicit="yes"> attribute (whose presence means that the Pod parser +had to infer what text should appear as the link text -- as opposed to +cases where that attribute is absent, which means that the Pod parser did +I<not> have to infer the link text, because that L code explicitly specified +some link text.) + +For example, this Pod source: + + L<hell itself!|crontab(5)> + +will produce this event structure: + + <L to="crontab(5)" type="man"> + hell itself! + </L> + +The last type of L structure is for links to/within Pod documents. It is +the most complex because it can have a I<to> attribute, I<or> a +I<section> attribute, or both. The C<type="pod"> attribute is always +specified for this type of L code. + +In the most common case, the simple case of a LE<lt>podpageE<gt> code +produces this event structure: + + <L content-implicit="yes" to="Net::Ping" type="pod"> + podpage + </L> + +For example, this Pod source: + + L<Net::Ping> + +produces this event structure: + + <L content-implicit="yes" to="Net::Ping" type="pod"> + Net::Ping + </L> + +In cases where there is link-text explicitly specified, it +is to be found in the content of the element (and not the +attributes), just as with the LE<lt>I<sometext>|I<manpage(section)>E<gt> +case discussed above. For example, this Pod source: + + L<Perl Error Messages|perldiag> + +produces this event structure: + + <L to="perldiag" type="pod"> + Perl Error Messages + </L> + +In cases of links to a section in the current Pod document, +there is a I<section> attribute instead of a I<to> attribute. +For example, this Pod source: + + L</"Member Data"> + +produces this event structure: + + <L content-implicit="yes" section="Member Data" type="pod"> + "Member Data" + </L> + +As another example, this Pod source: + + L<the various attributes|/"Member Data"> + +produces this event structure: + + <L section="Member Data" type="pod"> + the various attributes + </L> + +In cases of links to a section in a different Pod document, +there are both a I<section> attribute and a L<to> attribute. +For example, this Pod source: + + L<perlsyn/"Basic BLOCKs and Switch Statements"> + +produces this event structure: + + <L content-implicit="yes" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod"> + "Basic BLOCKs and Switch Statements" in perlsyn + </L> + +As another example, this Pod source: + + L<SWITCH statements|perlsyn/"Basic BLOCKs and Switch Statements"> + +produces this event structure: + + <L section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod"> + SWITCH statements + </L> + +Incidentally, note that we do not distinguish between these syntaxes: + + L</"Member Data"> + L<"Member Data"> + L</Member Data> + L<Member Data> [deprecated syntax] + +That is, they all produce the same event structure, namely: + + <L content-implicit="yes" section="Member Data" type="pod"> + "Member Data" + </L> + +=item events with an element_name of E or Z + +While there are Pod codes EE<lt>...E<gt> and ZE<lt>E<gt>, these +I<do not> produce any E or Z events -- that is, there are no such +events as E or Z. + +=item events with an element_name of Verbatim + +When a Pod verbatim paragraph (AKA "codeblock") is parsed, it +produces this event structure: + + <Verbatim start_line="543" xml:space="preserve"> + ...text... + </Verbatim> + +The value of the I<start_line> attribute will be the line number of the +first line of this verbatim block. The I<xml:space> attribute is always +present, and always has the value "preserve". + +The text content will have tabs already expanded. + + +=item events with an element_name of head1 .. head4 + +When a "=head1 ..." directive is parsed, it produces this event +structure: + + <head1> + ...stuff... + </head1> + +For example, a directive consisting of this: + + =head1 Options to C<new> et al. + +will produce this event structure: + + <head1 start_line="543"> + Options to + <C> + new + </C> + et al. + </head1> + +"=head2" thru "=head4" directives are the same, except for the element +names in the event structure. + +=item events with an element_name of over-bullet + +When an "=over ... Z<>=back" block is parsed where the items are +a bulletted list, it will produce this event structure: + + <over-bullet indent="4" start_line="543"> + <item-bullet start_line="545"> + ...Stuff... + </item-bullet> + ...more item-bullets... + </over-bullet> + +The value of the I<indent> attribute is whatever value is after the +"=over" directive, as in "=over 8". If no such value is specified +in the directive, then the I<indent> attribute has the value "4". + +For example, this Pod source: + + =over + + =item * + + Stuff + + =item * + + Bar I<baz>! + + =back + +produces this event structure: + + <over-bullet indent="4" start_line="10"> + <item-bullet start_line="12"> + Stuff + </item-bullet> + <item-bullet start_line="14"> + Bar <I>baz</I>! + </item-bullet> + </over-bullet> + +=item events with an element_name of over-number + +When an "=over ... Z<>=back" block is parsed where the items are +a numbered list, it will produce this event structure: + + <over-number indent="4" start_line="543"> + <item-number number="1" start_line="545"> + ...Stuff... + </item-number> + ...more item-number... + </over-bullet> + +This is like the "over-bullet" event structure; but note that the contents +are "item-number" instead of "item-bullet", and note that they will have +a "number" attribute, which some formatters/processors may ignore +(since, for example, there's no need for it in HTML when producing +an "<UL><LI>...</LI>...</UL>" structure), but which any processor may use. + +Note that the values for the I<number> attributes of "item-number" +elements in a given "over-number" area I<will> start at 1 and go up by +one each time. If the Pod source doesn't follow that order (even though +it really should should!), whatever numbers it has will be ignored (with +the correct values being put in the I<number> attributes), and an error +message might be issued to the user. + +=item events with an element_name of over-text + +These events are are somewhat unlike the other over-* +structures, as far as what their contents are. When +an "=over ... Z<>=back" block is parsed where the items are +a list of text "subheadings", it will produce this event structure: + + <over-text indent="4" start_line="543"> + <item-text> + ...stuff... + </item-text> + ...stuff (generally Para or Verbatim elements)... + <item-text> + ...more item-text and/or stuff... + </over-text> + +The I<indent> attribute is as with the other over-* events. + +For example, this Pod source: + + =over + + =item Foo + + Stuff + + =item Bar I<baz>! + + Quux + + =back + +produces this event structure: + + <over-text indent="4" start_line="20"> + <item-text start_line="22"> + Foo + </item-text> + <Para start_line="24"> + Stuff + </Para> + <item-text start_line="26"> + Bar + <I> + baz + </I> + ! + </item-text> + <Para start_line="28"> + Quux + </Para> + </over-text> + + + +=item events with an element_name of over-block + +These events are are somewhat unlike the other over-* +structures, as far as what their contents are. When +an "=over ... Z<>=back" block is parsed where there are no items, +it will produce this event structure: + + <over-block indent="4" start_line="543"> + ...stuff (generally Para or Verbatim elements)... + </over-block> + +The I<indent> attribute is as with the other over-* events. + +For example, this Pod source: + + =over + + For cutting off our trade with all parts of the world + + For transporting us beyond seas to be tried for pretended offenses + + He is at this time transporting large armies of foreign mercenaries to + complete the works of death, desolation and tyranny, already begun with + circumstances of cruelty and perfidy scarcely paralleled in the most + barbarous ages, and totally unworthy the head of a civilized nation. + + =cut + +will produce this event structure: + + <over-block indent="4" start_line="2"> + <Para start_line="4"> + For cutting off our trade with all parts of the world + </Para> + <Para start_line="6"> + For transporting us beyond seas to be tried for pretended offenses + </Para> + <Para start_line="8"> + He is at this time transporting large armies of [...more text...] + </Para> + </over-block> + +=item events with an element_name of item-bullet + +See L</"events with an element_name of over-bullet">, above. + +=item events with an element_name of item-number + +See L</"events with an element_name of over-number">, above. + +=item events with an element_name of item-text + +See L</"events with an element_name of over-text">, above. + +=item events with an element_name of for + +TODO... + +=item events with an element_name of Data + +TODO... + +=back + + + +=head1 More Pod::Simple Methods + +Pod::Simple provides a lot of methods that aren't generally interesting +to the end user of an existing Pod formatter, but some of which you +might find useful in writing a Pod formatter. They are listed below. The +first several methods (the accept_* methods) are for declaring the +capabilites of your parser, notably what C<=for I<targetname>> sections +it's interested in, what extra NE<lt>...E<gt> codes it accepts beyond +the ones described in the I<perlpod>. + +=over + +=item C<< $parser->accept_targets( I<SOMEVALUE> ) >> + +As the parser sees sections like: + + =for html <img src="fig1.jpg"> + +or + + =begin html + + <img src="fig1.jpg"> + + =end html + +...the parser will ignore these sections unless your subclass has +specified that it wants to see sections targetted to "html" (or whatever +the formatter name is). + +If you want to process all sections, even if they're not targetted for you, +call this before you start parsing: + + $parser->accept_targets('*'); + +=item C<< $parser->accept_targets_as_text( I<SOMEVALUE> ) >> + +This is like accept_targets, except that it specifies also that the +content of sections for this target should be treated as Pod text even +if the target name in "=for I<targetname>" doesn't start with a ":". + +At time of writing, I don't think you'll need to use this. + + +=item C<< $parser->accept_codes( I<Codename>, I<Codename>... ) >> + +This tells the parser that you accept additional formatting codes, +beyond just the standard ones (I B C L F S X, plus the two weird ones +you don't actually see in the parse tree, Z and E). For example, to also +accept codes "N", "R", and "W": + + $parser->accept_codes( qw( N R W ) ); + +B<TODO: document how this interacts with =extend, and long element names> + + +=item C<< $parser->accept_directive_as_data( I<directive_name> ) >> + +=item C<< $parser->accept_directive_as_verbatim( I<directive_name> ) >> + +=item C<< $parser->accept_directive_as_processed( I<directive_name> ) >> + +In the unlikely situation that you need to tell the parser that you will +accept additional directives ("=foo" things), you need to first set the +parset to treat its content as data (i.e., not really processed at +all), or as verbatim (mostly just expanding tabs), or as processed text +(parsing formatting codes like BE<lt>...E<gt>). + +For example, to accept a new directive "=method", you'd presumably +use: + + $parser->accept_directive_as_processed("method"); + +so that you could have Pod lines like: + + =method I<$whatever> thing B<um> + +Making up your own directives breaks compatibility with other Pod +formatters, in a way that using "=for I<target> ..." lines doesn't; +however, you may find this useful if you're making a Pod superset +format where you don't need to worry about compatibility. + + +=item C<< $parser->nbsp_for_S( I<BOOLEAN> ); >> + +Setting this attribute to a true value (and by default it is false) will +turn "SE<lt>...E<gt>" sequences into sequences of words separated by +C<\xA0> (non-breaking space) characters. For example, it will take this: + + I like S<Dutch apple pie>, don't you? + +and treat it as if it were: + + I like DutchE<nbsp>appleE<nbsp>pie, don't you? + +This is handy for output formats that don't have anything quite like an +"SE<lt>...E<gt>" code, but which do have a code for non-breaking space. + +There is currently no method for going the other way; but I can +probably provide one upon request. + + +=item C<< $parser->version_report() >> + +This returns a string reporting the $VERSION value from your module (and +its classname) as well as the $VERSION value of Pod::Simple. Note that +L<perlpodspec> requires output formats (wherever possible) to note +this detail in a comment in the output format. For example, for +some kind of SGML output format: + + print OUT "<!-- \n", $parser->version_report, "\n -->"; + + +=item C<< $parser->pod_para_count() >> + +This returns the count of Pod paragraphs seen so far. + + +=item C<< $parser->line_count() >> + +This is the current line number being parsed. But you might find the +"line_number" event attribute more accurate, when it is present. + + +=item C<< $parser->nix_X_codes( I<SOMEVALUE> ) >> + +This attribute, when set to a true value (and it is false by default) +ignores any "XE<lt>...E<gt>" sequences in the document being parsed. +Many formats don't actually use the content of these codes, so have +no reason to process them. + + +=item C<< $parser->merge_text( I<SOMEVALUE> ) >> + +This attribute, when set to a true value (and it is false by default) +makes sure that only one event (or token, or node) will be created +for any single contiguous sequence of text. For example, consider +this somewhat contrived example: + + I just LOVE Z<>hotE<32>apple pie! + +When that is parsed and events are about to be called on it, it may +actually seem to be four different text events, one right after another: +one event for "I just LOVE ", one for "hot", one for " ", and one for +"apple pie!". But if you have merge_text on, then you're guaranteed +that it will be fired as one text event: "I just LOVE hot apple pie!". + + +=item C<< $parser->code_handler( I<CODE_REF> ) >> + +This specifies code that should be called when a code line is seen +(i.e., a line outside of the Pod). Normally this is undef, meaning +that no code should be called. If you provide a routine, it should +start out like this: + + sub get_code_line { # or whatever you'll call it + my($line, $line_number, $parser) = @_; + ... + } + +Note, however, that sometimes the Pod events aren't processed in exactly +the same order as the code lines are -- i.e., if you have a file with +Pod, then code, then more Pod, sometimes the code will be processed (via +whatever you have code_handler call) before the all of the preceding Pod +has been processed. + + +=item C<< $parser->cut_handler( I<CODE_REF> ) >> + +This is just like the code_handler attribute, except that it's for +"=cut" lines, not code lines. The same caveats apply. "=cut" lines are +unlikely to be interesting, but this is included for completeness. + + +=item C<< $parser->whine( I<linenumber>, I<complaint string> ) >> + +This notes a problem in the Pod, which will be reported to in the "Pod +Errors" section of the document and/or send to STDERR, depending on the +values of the attributes C<no_whining>, C<no_errata_section>, and +C<complain_stderr>. + +=item C<< $parser->scream( I<linenumber>, I<complaint string> ) >> + +This notes an error like C<whine> does, except that it is not +suppressable with C<no_whining>. This should be used only for very +serious errors. + + +=item C<< $parser->source_dead(1) >> + +This aborts parsing of the current document, by switching on the flag +that indicates that EOF has been seen. In particularly drastic cases, +you might want to do this. It's rather nicer than just calling +C<die>! + +=item C<< $parser->hide_line_numbers( I<SOMEVALUE> ) >> + +Some subclasses that indescriminately dump event attributes (well, +except for ones beginning with "~") can use this object attribute for +refraining to dump the "start_line" attribute. + +=item C<< $parser->no_whining( I<SOMEVALUE> ) >> + +This attribute, if set to true, will suppress reports of non-fatal +error messages. The default value is false, meaning that complaints +I<are> reported. How they get reported depends on the values of +the attributes C<no_errata_section> and C<complain_stderr>. + +=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >> + +This attribute, if set to true, will suppress generation of an errata +section. The default value is false -- i.e., an errata section will be +generated. + +=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >> + +This attribute, if set to true will send complaints to STDERR. The +default value is false -- i.e., complaints do not go to STDERR. + +=item C<< $parser->bare_output( I<SOMEVALUE> ) >> + +Some formatter subclasses use this as a flag for whether output should +have prologue and epilogue code omitted. For example, setting this to +true for an HTML formatter class should omit the +"<html><head><title>...</title><body>..." prologue and the +"</body></html>" epilogue. + +If you want to set this to true, you should probably also set +C<no_whining> or at least C<no_errata_section> to true. + +=item C<< $parser->preserve_whitespace( I<SOMEVALUE> ) >> + +If you set this attribute to a true value, the parser will try to +preserve whitespace in the output. This means that such formatting +conventions as two spaces after periods will be preserved by the parser. +This is primarily useful for output formats that treat whitespace as +significant (such as text or *roff, but not HTML). + +=back + + +=head1 SEE ALSO + +L<Pod::Simple> -- event-based Pod-parsing framework + +L<Pod::Simple::Methody> -- like Pod::Simple, but each sort of event +calls its own method (like C<start_head3>) + +L<Pod::Simple::PullParser> -- a Pod-parsing framework like Pod::Simple, +but with a token-stream interface + +L<Pod::Simple::SimpleTree> -- a Pod-parsing framework like Pod::Simple, +but with a tree interface + +L<Pod::Simple::Checker> -- a simple Pod::Simple subclass that reads +documents, and then makes a plaintext report of any errors found in the +document + +L<Pod::Simple::DumpAsXML> -- for dumping Pod documents as tidily +indented XML, showing each event on its own line + +L<Pod::Simple::XMLOutStream> -- dumps a Pod document as XML (without +introducing extra whitespace as Pod::Simple::DumpAsXML does). + +L<Pod::Simple::DumpAsText> -- for dumping Pod documents as tidily +indented text, showing each event on its own line + +L<Pod::Simple::LinkSection> -- class for objects representing the values +of the TODO and TODO attributes of LE<lt>...E<gt> elements + +L<Pod::Escapes> -- the module the Pod::Simple uses for evaluating +EE<lt>...E<gt> content + +L<Pod::Simple::Text> -- a simple plaintext formatter for Pod + +L<Pod::Simple::TextContent> -- like Pod::Simple::Text, but +makes no effort for indent or wrap the text being formatted + +L<perlpod|perlpod> + +L<perlpodspec|perlpodspec> + +L<perldoc> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=for notes +Hm, my old podchecker version (1.2) says: + *** WARNING: node 'http://search.cpan.org/' contains non-escaped | or / at line 38 in file Subclassing.pod + *** WARNING: node 'http://lists.perl.org/showlist.cgi?name=pod-people' contains non-escaped | or / at line 41 in file Subclassing.pod +Yes, L<...> is hard. + + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm new file mode 100644 index 00000000000..81fde4e7a70 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm @@ -0,0 +1,185 @@ + +require 5; +package Pod::Simple::Text; +use strict; +use Carp (); +use Pod::Simple::Methody (); +use Pod::Simple (); +use vars qw( @ISA $VERSION $FREAKYMODE); +$VERSION = '3.14'; +@ISA = ('Pod::Simple::Methody'); +BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) + ? \&Pod::Simple::DEBUG + : sub() {0} + } + +use Text::Wrap 98.112902 (); +$Text::Wrap::wrap = 'overflow'; +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->accept_target_as_text(qw( text plaintext plain )); + $new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->{'Thispara'} = ''; + $new->{'Indent'} = 0; + $new->{'Indentstring'} = ' '; + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub handle_text { $_[0]{'Thispara'} .= $_[1] } + +sub start_Para { $_[0]{'Thispara'} = '' } +sub start_head1 { $_[0]{'Thispara'} = '' } +sub start_head2 { $_[0]{'Thispara'} = '' } +sub start_head3 { $_[0]{'Thispara'} = '' } +sub start_head4 { $_[0]{'Thispara'} = '' } + +sub start_Verbatim { $_[0]{'Thispara'} = '' } +sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' } +sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " } +sub start_item_text { $_[0]{'Thispara'} = '' } + +sub start_over_bullet { ++$_[0]{'Indent'} } +sub start_over_number { ++$_[0]{'Indent'} } +sub start_over_text { ++$_[0]{'Indent'} } +sub start_over_block { ++$_[0]{'Indent'} } + +sub end_over_bullet { --$_[0]{'Indent'} } +sub end_over_number { --$_[0]{'Indent'} } +sub end_over_text { --$_[0]{'Indent'} } +sub end_over_block { --$_[0]{'Indent'} } + + +# . . . . . Now the actual formatters: + +sub end_head1 { $_[0]->emit_par(-4) } +sub end_head2 { $_[0]->emit_par(-3) } +sub end_head3 { $_[0]->emit_par(-2) } +sub end_head4 { $_[0]->emit_par(-1) } +sub end_Para { $_[0]->emit_par( 0) } +sub end_item_bullet { $_[0]->emit_par( 0) } +sub end_item_number { $_[0]->emit_par( 0) } +sub end_item_text { $_[0]->emit_par(-2) } +sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' } +sub end_L { + if (my $link = delete $_[0]{'Link'}) { + # Append the URL to the output unless it's already present. + $_[0]{'Thispara'} .= " <$link->{to}>" + unless $_[0]{'Thispara'} =~ /\b\E$link->{to}/; + } +} + +sub emit_par { + my($self, $tweak_indent) = splice(@_,0,2); + my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) ); + # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0 + + $self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII; + my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); + $out =~ tr{\xA0}{ } if Pod::Simple::ASCII; + print {$self->{'output_fh'}} $out, "\n"; + $self->{'Thispara'} = ''; + + return; +} + +# . . . . . . . . . . And then off by its lonesome: + +sub end_Verbatim { + my $self = shift; + if(Pod::Simple::ASCII) { + $self->{'Thispara'} =~ tr{\xA0}{ }; + $self->{'Thispara'} =~ tr{\xAD}{}d; + } + + my $i = ' ' x ( 2 * $self->{'Indent'} + 4); + #my $i = ' ' x (4 + $self->{'Indent'}); + + $self->{'Thispara'} =~ s/^/$i/mg; + + print { $self->{'output_fh'} } '', + $self->{'Thispara'}, + "\n\n" + ; + $self->{'Thispara'} = ''; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +__END__ + +=head1 NAME + +Pod::Simple::Text -- format Pod as plaintext + +=head1 SYNOPSIS + + perl -MPod::Simple::Text -e \ + "exit Pod::Simple::Text->filter(shift)->any_errata_seen" \ + thingy.pod + +=head1 DESCRIPTION + +This class is a formatter that takes Pod and renders it as +wrapped plaintext. + +Its wrapping is done by L<Text::Wrap>, so you can change +C<$Text::Wrap::columns> as you like. + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::TextContent>, L<Pod::Text> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm new file mode 100644 index 00000000000..914c7fd166c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm @@ -0,0 +1,112 @@ + + +require 5; +package Pod::Simple::TextContent; +use strict; +use Carp (); +use Pod::Simple (); +use vars qw( @ISA $VERSION ); +$VERSION = '3.14'; +@ISA = ('Pod::Simple'); + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->nix_X_codes(1); + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub _handle_element_start { + print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s; + return; +} + +sub _handle_text { + if( chr(65) eq 'A' ) { # in ASCIIworld + $_[1] =~ tr/\xAD//d; + $_[1] =~ tr/\xA0/ /; + } + print {$_[0]{'output_fh'}} $_[1]; + return; +} + +sub _handle_element_end { + print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +__END__ + +=head1 NAME + +Pod::Simple::TextContent -- get the text content of Pod + +=head1 SYNOPSIS + + TODO + + perl -MPod::Simple::TextContent -e \ + "exit Pod::Simple::TextContent->filter(shift)->any_errata_seen" \ + thingy.pod + +=head1 DESCRIPTION + +This class is that parses Pod and dumps just the text content. It is +mainly meant for use by the Pod::Simple test suite, but you may find +some other use for it. + +This is a subclass of L<Pod::Simple> and inherits all its methods. + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm new file mode 100644 index 00000000000..c5d4483b283 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm @@ -0,0 +1,105 @@ + +use strict; +package Pod::Simple::TiedOutFH; +use Symbol ('gensym'); +use Carp (); +use vars qw($VERSION ); +$VERSION = '3.14'; + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub handle_on { # some horrible frightening things are encapsulated in here + my $class = shift; + $class = ref($class) || $class; + + Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_; + + my $x = (defined($_[0]) and ref($_[0])) + ? $_[0] + : ( \( $_[0] ) )[0] + ; + $$x = '' unless defined $$x; + + #Pod::Simple::DEBUG and print "New $class handle on $x = \"$$x\"\n"; + + my $new = gensym(); + tie *$new, $class, $x; + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub TIEHANDLE { # Ties to just a scalar ref + my($class, $scalar_ref) = @_; + $$scalar_ref = '' unless defined $$scalar_ref; + return bless \$scalar_ref, ref($class) || $class; +} + +sub PRINT { + my $it = shift; + foreach my $x (@_) { $$$it .= $x } + + #Pod::Simple::DEBUG > 10 and print " appended to $$it = \"$$$it\"\n"; + + return 1; +} + +sub FETCH { + return ${$_[0]}; +} + +sub PRINTF { + my $it = shift; + my $format = shift; + $$$it .= sprintf $format, @_; + return 1; +} + +sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number + +sub CLOSE { 1 } + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1; +__END__ + +Chole + + * 1 large red onion + * 2 tomatillos + * 4 or 5 roma tomatoes (optionally with the pulp discarded) + * 1 tablespoons chopped ginger root (or more, to taste) + * 2 tablespoons canola oil (or vegetable oil) + + * 1 tablespoon garam masala + * 1/2 teaspoon red chili powder, or to taste + * Salt, to taste (probably quite a bit) + * 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed + * juice of one smallish lime + * a dash of balsamic vinegar (to taste) + * cooked rice, preferably long-grain white rice (whether plain, + basmati rice, jasmine rice, or even a mild pilaf) + +In a blender or food processor, puree the onions, tomatoes, tomatillos, +and ginger root. You can even do it with a Braun hand "mixer", if you +chop things finer to start with, and work at it. + +In a saucepan set over moderate heat, warm the oil until hot. + +Add the puree and the balsamic vinegar, and cook, stirring occasionally, +for 20 to 40 minutes. (Cooking it longer will make it sweeter.) + +Add the Garam Masala, chili powder, and cook, stirring occasionally, for +5 minutes. + +Add the salt and chick peas and cook, stirring, until heated through. + +Stir in the lime juice, and optionally one or two teaspoons of tahini. +You can let it simmer longer, depending on how much softer you want the +garbanzos to get. + +Serve over rice, like a curry. + +Yields 5 to 7 servings. + + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm new file mode 100644 index 00000000000..258d0d76760 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm @@ -0,0 +1,35 @@ + +require 5; +package Pod::Simple::Transcode; +use vars qw($VERSION ); +$VERSION = '3.14'; + +BEGIN { + if(defined &DEBUG) {;} # Okay + elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG; } + else { *DEBUG = sub () {0}; } +} + +foreach my $class ( + 'Pod::Simple::TranscodeSmart', + 'Pod::Simple::TranscodeDumb', + '', +) { + $class or die "Couldn't load any encoding classes"; + DEBUG and print "About to try loading $class...\n"; + eval "require $class;"; + if($@) { + DEBUG and print "Couldn't load $class: $@\n"; + } else { + DEBUG and print "OK, loaded $class.\n"; + @ISA = ($class); + last; + } +} + +sub _blorp { return; } # just to avoid any "empty class" warning + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm new file mode 100644 index 00000000000..d1c320d5d1a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm @@ -0,0 +1,63 @@ + +require 5; +## This module is to be use()'d only by Pod::Simple::Transcode + +package Pod::Simple::TranscodeDumb; +use strict; +use vars qw($VERSION %Supported); +$VERSION = '3.14'; +# This module basically pretends it knows how to transcode, except +# only for null-transcodings! We use this when Encode isn't +# available. + +%Supported = ( + 'ascii' => 1, + 'ascii-ctrl' => 1, + 'iso-8859-1' => 1, + 'null' => 1, + 'latin1' => 1, + 'latin-1' => 1, + %Supported, +); + +sub is_dumb {1} +sub is_smart {0} + +sub all_encodings { + return sort keys %Supported; +} + +sub encoding_is_available { + return exists $Supported{lc $_[1]}; +} + +sub encmodver { + return __PACKAGE__ . " v" .($VERSION || '?'); +} + +sub make_transcoder { + my($e) = $_[1]; + die "WHAT ENCODING!?!?" unless $e; + my $x; + return sub {; + #foreach $x (@_) { + # if(Pod::Simple::ASCII and !Pod::Simple::UNICODE and $] > 5.005) { + # # We're in horrible gimp territory, so we need to knock out + # # all the highbit things + # $x = + # pack 'C*', + # map {; ($_ < 128) ? $_ : 0x7e } + # unpack "C*", + # $x + # ; + # } + #} + # + #return; + }; +} + + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm new file mode 100644 index 00000000000..bab59fc8972 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm @@ -0,0 +1,44 @@ + +require 5; +use 5.008; +## Anything before 5.8.0 is GIMPY! +## This module is to be use()'d only by Pod::Simple::Transcode + +package Pod::Simple::TranscodeSmart; +use strict; +use Pod::Simple; +require Encode; +use vars qw($VERSION ); +$VERSION = '3.14'; + +sub is_dumb {0} +sub is_smart {1} + +sub all_encodings { + return Encode::->encodings(':all'); +} + +sub encoding_is_available { + return Encode::resolve_alias($_[1]); +} + +sub encmodver { + return "Encode.pm v" .($Encode::VERSION || '?'); +} + +sub make_transcoder { + my($e) = $_[1]; + die "WHAT ENCODING!?!?" unless $e; + my $x; + return sub { + foreach $x (@_) { + $x = Encode::decode($e, $x); + } + return; + }; +} + + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm new file mode 100644 index 00000000000..6a8fb7e97e4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm @@ -0,0 +1,717 @@ +=pod + +=head1 NAME + +Pod::Simple::XHTML -- format Pod as validating XHTML + +=head1 SYNOPSIS + + use Pod::Simple::XHTML; + + my $parser = Pod::Simple::XHTML->new(); + + ... + + $parser->parse_file('path/to/file.pod'); + +=head1 DESCRIPTION + +This class is a formatter that takes Pod and renders it as XHTML +validating HTML. + +This is a subclass of L<Pod::Simple::Methody> and inherits all its +methods. The implementation is entirely different than +L<Pod::Simple::HTML>, but it largely preserves the same interface. + +=cut + +package Pod::Simple::XHTML; +use strict; +use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); +$VERSION = '3.14'; +use Carp (); +use Pod::Simple::Methody (); +@ISA = ('Pod::Simple::Methody'); + +BEGIN { + $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1"; +} + +my %entities = ( + q{>} => 'gt', + q{<} => 'lt', + q{'} => '#39', + q{"} => 'quot', + q{&} => 'amp', +); + +sub encode_entities { + return HTML::Entities::encode_entities( $_[0] ) if $HAS_HTML_ENTITIES; + my $str = $_[0]; + my $ents = join '', keys %entities; + $str =~ s/([$ents])/'&' . $entities{$1} . ';'/ge; + return $str; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +=head1 METHODS + +Pod::Simple::XHTML offers a number of methods that modify the format of +the HTML output. Call these after creating the parser object, but before +the call to C<parse_file>: + + my $parser = Pod::PseudoPod::HTML->new(); + $parser->set_optional_param("value"); + $parser->parse_file($file); + +=head2 perldoc_url_prefix + +In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what +to put before the "Foo%3a%3aBar". The default value is +"http://search.cpan.org/perldoc?". + +=head2 perldoc_url_postfix + +What to put after "Foo%3a%3aBar" in the URL. This option is not set by +default. + +=head2 man_url_prefix + +In turning C<< L<crontab(5)> >> into http://whatever/man/1/crontab, what +to put before the "1/crontab". The default value is +"http://man.he.net/man". + +=head2 man_url_postfix + +What to put after "1/crontab" in the URL. This option is not set by default. + +=head2 title_prefix, title_postfix + +What to put before and after the title in the head. The values should +already be &-escaped. + +=head2 html_css + + $parser->html_css('path/to/style.css'); + +The URL or relative path of a CSS file to include. This option is not +set by default. + +=head2 html_javascript + +The URL or relative path of a JavaScript file to pull in. This option is +not set by default. + +=head2 html_doctype + +A document type tag for the file. This option is not set by default. + +=head2 html_header_tags + +Additional arbitrary HTML tags for the header of the document. The +default value is just a content type header tag: + + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> + +Add additional meta tags here, or blocks of inline CSS or JavaScript +(wrapped in the appropriate tags). + +=head2 html_h_level + +This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For +example, if C<html_h_level> is set to 2, a head1 will produce an H2, a head2 +will produce an H3, and so on. + +=head2 default_title + +Set a default title for the page if no title can be determined from the +content. The value of this string should already be &-escaped. + +=head2 force_title + +Force a title for the page (don't try to determine it from the content). +The value of this string should already be &-escaped. + +=head2 html_header, html_footer + +Set the HTML output at the beginning and end of each file. The default +header includes a title, a doctype tag (if C<html_doctype> is set), a +content tag (customized by C<html_header_tags>), a tag for a CSS file +(if C<html_css> is set), and a tag for a Javascript file (if +C<html_javascript> is set). The default footer simply closes the C<html> +and C<body> tags. + +The options listed above customize parts of the default header, but +setting C<html_header> or C<html_footer> completely overrides the +built-in header or footer. These may be useful if you want to use +template tags instead of literal HTML headers and footers or are +integrating converted POD pages in a larger website. + +If you want no headers or footers output in the HTML, set these options +to the empty string. + +=head2 index + +Whether to add a table-of-contents at the top of each page (called an +index for the sake of tradition). + + +=cut + +__PACKAGE__->_accessorize( + 'perldoc_url_prefix', + 'perldoc_url_postfix', + 'man_url_prefix', + 'man_url_postfix', + 'title_prefix', 'title_postfix', + 'html_css', + 'html_javascript', + 'html_doctype', + 'html_header_tags', + 'html_h_level', + 'title', # Used internally for the title extracted from the content + 'default_title', + 'force_title', + 'html_header', + 'html_footer', + 'index', + 'batch_mode', # whether we're in batch mode + 'batch_mode_current_level', + # When in batch mode, how deep the current module is: 1 for "LWP", + # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc +); + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +=head1 SUBCLASSING + +If the standard options aren't enough, you may want to subclass +Pod::Simple::XHMTL. These are the most likely candidates for methods +you'll want to override when subclassing. + +=cut + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->perldoc_url_prefix('http://search.cpan.org/perldoc?'); + $new->man_url_prefix('http://man.he.net/man'); + $new->html_header_tags('<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />'); + $new->nix_X_codes(1); + $new->codes_in_verbatim(1); + $new->{'scratch'} = ''; + $new->{'to_index'} = []; + $new->{'output'} = []; + $new->{'saved'} = []; + $new->{'ids'} = {}; + + $new->{'__region_targets'} = []; + $new->{'__literal_targets'} = {}; + $new->accept_targets_as_html( 'html', 'HTML' ); + + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +=head2 handle_text + +This method handles the body of text within any element: it's the body +of a paragraph, or everything between a "=begin" tag and the +corresponding "=end" tag, or the text within an L entity, etc. You would +want to override this if you are adding a custom element type that does +more than just display formatted text. Perhaps adding a way to generate +HTML tables from an extended version of POD. + +So, let's say you want add a custom element called 'foo'. In your +subclass's C<new> method, after calling C<SUPER::new> you'd call: + + $new->accept_targets_as_text( 'foo' ); + +Then override the C<start_for> method in the subclass to check for when +"$flags->{'target'}" is equal to 'foo' and set a flag that marks that +you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the +C<handle_text> method to check for the flag, and pass $text to your +custom subroutine to construct the HTML output for 'foo' elements, +something like: + + sub handle_text { + my ($self, $text) = @_; + if ($self->{'in_foo'}) { + $self->{'scratch'} .= build_foo_html($text); + } else { + $self->{'scratch'} .= $text; + } + } + +=head2 accept_targets_as_html + +This method behaves like C<accept_targets_as_text>, but also marks the region +as one whose content should be emitted literally, without HTML entity escaping +or wrapping in a C<div> element. + +=cut + +sub __in_literal_xhtml_region { + return unless @{ $_[0]{__region_targets} }; + my $target = $_[0]{__region_targets}[-1]; + return $_[0]{__literal_targets}{ $target }; +} + +sub accept_targets_as_html { + my ($self, @targets) = @_; + $self->accept_targets(@targets); + $self->{__literal_targets}{$_} = 1 for @targets; +} + +sub handle_text { + # escape special characters in HTML (<, >, &, etc) + $_[0]{'scratch'} .= $_[0]->__in_literal_xhtml_region + ? $_[1] + : encode_entities( $_[1] ); +} + +sub start_Para { $_[0]{'scratch'} = '<p>' } +sub start_Verbatim { $_[0]{'scratch'} = '<pre><code>' } + +sub start_head1 { $_[0]{'in_head'} = 1 } +sub start_head2 { $_[0]{'in_head'} = 2 } +sub start_head3 { $_[0]{'in_head'} = 3 } +sub start_head4 { $_[0]{'in_head'} = 4 } + +sub start_item_number { + $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'}; + $_[0]{'scratch'} .= '<li><p>'; + $_[0]{'in_li'} = 1 +} + +sub start_item_bullet { + $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'}; + $_[0]{'scratch'} .= '<li><p>'; + $_[0]{'in_li'} = 1 +} + +sub start_item_text { + if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) { + $_[0]{'scratch'} = "</dd>\n"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0; + } + $_[0]{'scratch'} .= '<dt>'; +} + +sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } +sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } +sub start_over_number { $_[0]{'scratch'} = '<ol>'; $_[0]->emit } +sub start_over_text { + $_[0]{'scratch'} = '<dl>'; + $_[0]{'dl_level'}++; + $_[0]{'in_dd'} ||= []; + $_[0]->emit +} + +sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit } + +sub end_over_number { + $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'}; + $_[0]{'scratch'} .= '</ol>'; + $_[0]->emit; +} + +sub end_over_bullet { + $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'}; + $_[0]{'scratch'} .= '</ul>'; + $_[0]->emit; +} + +sub end_over_text { + if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) { + $_[0]{'scratch'} = "</dd>\n"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0; + } + $_[0]{'scratch'} .= '</dl>'; + $_[0]{'dl_level'}--; + $_[0]->emit; +} + +# . . . . . Now the actual formatters: + +sub end_Para { $_[0]{'scratch'} .= '</p>'; $_[0]->emit } +sub end_Verbatim { + $_[0]{'scratch'} .= '</code></pre>'; + $_[0]->emit; +} + +sub _end_head { + my $h = delete $_[0]{in_head}; + + my $add = $_[0]->html_h_level; + $add = 1 unless defined $add; + $h += $add - 1; + + my $id = $_[0]->idify($_[0]{scratch}); + my $text = $_[0]{scratch}; + $_[0]{'scratch'} = qq{<h$h id="$id">$text</h$h>}; + $_[0]->emit; + push @{ $_[0]{'to_index'} }, [$h, $id, $text]; +} + +sub end_head1 { shift->_end_head(@_); } +sub end_head2 { shift->_end_head(@_); } +sub end_head3 { shift->_end_head(@_); } +sub end_head4 { shift->_end_head(@_); } + +sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit } +sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit } + +sub end_item_text { + $_[0]{'scratch'} .= "</dt>\n<dd>"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1; + $_[0]->emit; +} + +# This handles =begin and =for blocks of all kinds. +sub start_for { + my ($self, $flags) = @_; + + push @{ $self->{__region_targets} }, $flags->{target_matching}; + + unless ($self->__in_literal_xhtml_region) { + $self->{scratch} .= '<div'; + $self->{scratch} .= qq( class="$flags->{target}") if $flags->{target}; + $self->{scratch} .= '>'; + } + + $self->emit; + +} +sub end_for { + my ($self) = @_; + + $self->{'scratch'} .= '</div>' unless $self->__in_literal_xhtml_region; + + pop @{ $self->{__region_targets} }; + $self->emit; +} + +sub start_Document { + my ($self) = @_; + if (defined $self->html_header) { + $self->{'scratch'} .= $self->html_header; + $self->emit unless $self->html_header eq ""; + } else { + my ($doctype, $title, $metatags); + $doctype = $self->html_doctype || ''; + $title = $self->force_title || $self->title || $self->default_title || ''; + $metatags = $self->html_header_tags || ''; + if ($self->html_css) { + $metatags .= "\n<link rel='stylesheet' href='" . + $self->html_css . "' type='text/css'>"; + } + if ($self->html_javascript) { + $metatags .= "\n<script type='text/javascript' src='" . + $self->html_javascript . "'></script>"; + } + $self->{'scratch'} .= <<"HTML"; +$doctype +<html> +<head> +<title>$title</title> +$metatags +</head> +<body> +HTML + $self->emit; + } +} + +sub end_Document { + my ($self) = @_; + my $to_index = $self->{'to_index'}; + if ($self->index && @{ $to_index } ) { + my @out; + my $level = 0; + my $indent = -1; + my $space = ''; + my $id = ' id="index"'; + + for my $h (@{ $to_index }, [0]) { + my $target_level = $h->[0]; + # Get to target_level by opening or closing ULs + if ($level == $target_level) { + $out[-1] .= '</li>'; + } elsif ($level > $target_level) { + $out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/; + while ($level > $target_level) { + --$level; + push @out, (' ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul}; + push @out, (' ' x --$indent) . '</ul>'; + } + push @out, (' ' x --$indent) . '</li>' if $level; + } else { + while ($level < $target_level) { + ++$level; + push @out, (' ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/; + push @out, (' ' x ++$indent) . "<ul$id>"; + $id = ''; + } + ++$indent; + } + + next unless $level; + $space = ' ' x $indent; + push @out, sprintf '%s<li><a href="#%s">%s</a>', + $space, $h->[1], $h->[2]; + } + # Splice the index in between the HTML headers and the first element. + my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1; + splice @{ $self->{'output'} }, $offset, 0, join "\n", @out; + } + + if (defined $self->html_footer) { + $self->{'scratch'} .= $self->html_footer; + $self->emit unless $self->html_footer eq ""; + } else { + $self->{'scratch'} .= "</body>\n</html>"; + $self->emit; + } + + if ($self->index) { + print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n"; + @{$self->{'output'}} = (); + } + +} + +# Handling code tags +sub start_B { $_[0]{'scratch'} .= '<b>' } +sub end_B { $_[0]{'scratch'} .= '</b>' } + +sub start_C { $_[0]{'scratch'} .= '<code>' } +sub end_C { $_[0]{'scratch'} .= '</code>' } + +sub start_F { $_[0]{'scratch'} .= '<i>' } +sub end_F { $_[0]{'scratch'} .= '</i>' } + +sub start_I { $_[0]{'scratch'} .= '<i>' } +sub end_I { $_[0]{'scratch'} .= '</i>' } + +sub start_L { + my ($self, $flags) = @_; + my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'}; + my $url = $type eq 'url' ? $to + : $type eq 'pod' ? $self->resolve_pod_page_link($to, $section) + : $type eq 'man' ? $self->resolve_man_page_link($to, $section) + : undef; + + # If it's an unknown type, use an attribute-less <a> like HTML.pm. + $self->{'scratch'} .= '<a' . ($url ? ' href="'. $url . '">' : '>'); +} + +sub end_L { $_[0]{'scratch'} .= '</a>' } + +sub start_S { $_[0]{'scratch'} .= '<nobr>' } +sub end_S { $_[0]{'scratch'} .= '</nobr>' } + +sub emit { + my($self) = @_; + if ($self->index) { + push @{ $self->{'output'} }, $self->{'scratch'}; + } else { + print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n"; + } + $self->{'scratch'} = ''; + return; +} + +=head2 resolve_pod_page_link + + my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL'); + my $url = $pod->resolve_pod_page_link('perlpodspec'); + my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS'); + +Resolves a POD link target (typically a module or POD file name) and section +name to a URL. The resulting link will be returned for the above examples as: + + http://search.cpan.org/perldoc?Net::Ping#INSTALL + http://search.cpan.org/perldoc?perlpodspec + #SYNOPSIS + +Note that when there is only a section argument the URL will simply be a link +to a section in the current document. + +=cut + +sub resolve_pod_page_link { + my ($self, $to, $section) = @_; + return undef unless defined $to || defined $section; + if (defined $section) { + $section = '#' . $self->idify($section, 1); + return $section unless defined $to; + } else { + $section = '' + } + + return ($self->perldoc_url_prefix || '') + . encode_entities($to) . $section + . ($self->perldoc_url_postfix || ''); +} + +=head2 resolve_man_page_link + + my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE'); + my $url = $pod->resolve_man_page_link('crontab'); + +Resolves a man page link target and numeric section to a URL. The resulting +link will be returned for the above examples as: + + http://man.he.net/man5/crontab + http://man.he.net/man1/crontab + +Note that the first argument is required. The section number will be parsed +from it, and if it's missing will default to 1. The second argument is +currently ignored, as L<man.he.net|http://man.he.net> does not currently +include linkable IDs or anchor names in its pages. Subclass to link to a +different man page HTTP server. + +=cut + +sub resolve_man_page_link { + my ($self, $to, $section) = @_; + return undef unless defined $to; + my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/; + return undef unless $page; + return ($self->man_url_prefix || '') + . ($part || 1) . "/" . encode_entities($page) + . ($self->man_url_postfix || ''); + +} + +=head2 idify + + my $id = $pod->idify($text); + my $hash = $pod->idify($text, 1); + +This method turns an arbitrary string into a valid XHTML ID attribute value. +The rules enforced, following +L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are: + +=over + +=item * + +The id must start with a letter (a-z or A-Z) + +=item * + +All subsequent characters can be letters, numbers (0-9), hyphens (-), +underscores (_), colons (:), and periods (.). + +=item * + +Each id must be unique within the document. + +=back + +In addition, the returned value will be unique within the context of the +Pod::Simple::XHTML object unless a second argument is passed a true value. ID +attributes should always be unique within a single XHTML document, but pass +the true value if you are creating not an ID but a URL hash to point to +an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>. + +=cut + +sub idify { + my ($self, $t, $not_unique) = @_; + for ($t) { + s/<[^>]+>//g; # Strip HTML. + s/&[^;]+;//g; # Strip entities. + s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars. + s/^[^a-zA-Z]+//; # First char must be a letter. + s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid. + } + return $t if $not_unique; + my $i = ''; + $i++ while $self->{ids}{"$t$i"}++; + return "$t$i"; +} + +=head2 batch_mode_page_object_init + + $pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth); + +Called by L<Pod::Simple::HTMLBatch> so that the class has a chance to +initialize the converter. Internally it sets the C<batch_mode> property to +true and sets C<batch_mode_current_level()>, but Pod::Simple::XHTML does not +currently use those features. Subclasses might, though. + +=cut + +sub batch_mode_page_object_init { + my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; + $self->batch_mode(1); + $self->batch_mode_current_level($depth); + return $self; +} + +1; + +__END__ + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2003-2005 Allison Randal. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 ACKNOWLEDGEMENTS + +Thanks to L<Hurricane Electrict|http://he.net/> for permission to use its +L<Linux man pages online|http://man.he.net/> site for man page links. + +Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the +site for Perl module links. + +=head1 AUTHOR + +Pod::Simpele::XHTML was created by Allison Randal <allison@perl.org>. + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm new file mode 100644 index 00000000000..2e6b42834e0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm @@ -0,0 +1,185 @@ + +require 5; +package Pod::Simple::XMLOutStream; +use strict; +use Carp (); +use Pod::Simple (); +use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); +$VERSION = '3.14'; +BEGIN { + @ISA = ('Pod::Simple'); + *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; +} + +$ATTR_PAD = "\n" unless defined $ATTR_PAD; + # Don't mess with this unless you know what you're doing. + +$SORT_ATTRS = 0 unless defined $SORT_ATTRS; + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + #$new->accept_codes('VerbatimFormatted'); + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub _handle_element_start { + # ($self, $element_name, $attr_hash_r) + my $fh = $_[0]{'output_fh'}; + my($key, $value); + DEBUG and print "++ $_[1]\n"; + print $fh "<", $_[1]; + if($SORT_ATTRS) { + foreach my $key (sort keys %{$_[2]}) { + unless($key =~ m/^~/s) { + next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; + _xml_escape($value = $_[2]{$key}); + print $fh $ATTR_PAD, $key, '="', $value, '"'; + } + } + } else { # faster + while(($key,$value) = each %{$_[2]}) { + unless($key =~ m/^~/s) { + next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; + _xml_escape($value); + print $fh $ATTR_PAD, $key, '="', $value, '"'; + } + } + } + print $fh ">"; + return; +} + +sub _handle_text { + DEBUG and print "== \"$_[1]\"\n"; + if(length $_[1]) { + my $text = $_[1]; + _xml_escape($text); + print {$_[0]{'output_fh'}} $text; + } + return; +} + +sub _handle_element_end { + DEBUG and print "-- $_[1]\n"; + print {$_[0]{'output_fh'}} "</", $_[1], ">"; + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _xml_escape { + foreach my $x (@_) { + # Escape things very cautiously: + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + # Yes, stipulate the list without a range, so that this can work right on + # all charsets that this module happens to run under. + # Altho, hmm, what about that ord? Presumably that won't work right + # under non-ASCII charsets. Something should be done about that. + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + +__END__ + +=head1 NAME + +Pod::Simple::XMLOutStream -- turn Pod into XML + +=head1 SYNOPSIS + + perl -MPod::Simple::XMLOutStream -e \ + "exit Pod::Simple::XMLOutStream->filter(shift)->any_errata_seen" \ + thingy.pod + +=head1 DESCRIPTION + +Pod::Simple::XMLOutStream is a subclass of L<Pod::Simple> that parses +Pod and turns it into XML. + +Pod::Simple::XMLOutStream inherits methods from +L<Pod::Simple>. + + +=head1 SEE ALSO + +L<Pod::Simple::DumpAsXML> is rather like this class; see its +documentation for a discussion of the differences. + +L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX> + +L<Pod::Simple::Subclassing> + +The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML> + + +=head1 ABOUT EXTENDING POD + +TODO: An example or two of =extend, then point to Pod::Simple::Subclassing + + +=head1 ASK ME! + +If you actually want to use Pod as a format that you want to render to +XML (particularly if to an XML instance with more elements than normal +Pod has), please email me (C<sburke@cpan.org>) and I'll probably have +some recommendations. + +For reasons of concision and energetic laziness, some methods and +options in this module (and the dozen modules it depends on) are +undocumented; but one of those undocumented bits might be just what +you're looking for. + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +pod-people@perl.org mail list. Send an empty email to +pod-people-subscribe@perl.org to subscribe. + +This module is managed in an open GitHub repository, +L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002-2004 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Text.pm new file mode 100644 index 00000000000..c68313c3898 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Text.pm @@ -0,0 +1,878 @@ +# Pod::Text -- Convert POD data to formatted ASCII text. +# +# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009 +# Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module converts POD to formatted text. It replaces the old Pod::Text +# module that came with versions of Perl prior to 5.6.0 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. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text; + +require 5.004; + +use strict; +use vars qw(@ISA @EXPORT %ESCAPES $VERSION); + +use Carp qw(carp croak); +use Exporter (); +use Pod::Simple (); + +@ISA = qw(Pod::Simple Exporter); + +# We have to export pod2text for backward compatibility. +@EXPORT = qw(pod2text); + +$VERSION = '3.14'; + +############################################################################## +# Initialization +############################################################################## + +# This function handles code blocks. It's registered as a callback to +# Pod::Simple and therefore doesn't work as a regular method call, but all it +# does is call output_code with the line. +sub handle_code { + my ($line, $number, $parser) = @_; + $parser->output_code ($line . "\n"); +} + +# Initialize the object and set various Pod::Simple options that we need. +# Here, we also process any additional options passed to the constructor or +# set up defaults if none were given. Note that all internal object keys are +# in all-caps, reserving all lower-case object keys for Pod::Simple and user +# arguments. +sub new { + my $class = shift; + my $self = $class->SUPER::new; + + # Tell Pod::Simple to handle S<> by automatically inserting . + $self->nbsp_for_S (1); + + # Tell Pod::Simple to keep whitespace whenever possible. + if ($self->can ('preserve_whitespace')) { + $self->preserve_whitespace (1); + } else { + $self->fullstop_space_harden (1); + } + + # The =for and =begin targets that we accept. + $self->accept_targets (qw/text TEXT/); + + # Ensure that contiguous blocks of code are merged together. Otherwise, + # some of the guesswork heuristics don't work right. + $self->merge_text (1); + + # Pod::Simple doesn't do anything useful with our arguments, but we want + # to put them in our object as hash keys and values. This could cause + # problems if we ever clash with Pod::Simple's own internal class + # variables. + my %opts = @_; + my @opts = map { ("opt_$_", $opts{$_}) } keys %opts; + %$self = (%$self, @opts); + + # Send errors to stderr if requested. + if ($$self{opt_stderr}) { + $self->no_errata_section (1); + $self->complain_stderr (1); + delete $$self{opt_stderr}; + } + + # Initialize various things from our parameters. + $$self{opt_alt} = 0 unless defined $$self{opt_alt}; + $$self{opt_indent} = 4 unless defined $$self{opt_indent}; + $$self{opt_margin} = 0 unless defined $$self{opt_margin}; + $$self{opt_loose} = 0 unless defined $$self{opt_loose}; + $$self{opt_sentence} = 0 unless defined $$self{opt_sentence}; + $$self{opt_width} = 76 unless defined $$self{opt_width}; + + # Figure out what quotes we'll be using for C<> text. + $$self{opt_quotes} ||= '"'; + if ($$self{opt_quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{opt_quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes}; + } elsif ($$self{opt_quotes} =~ /^(.)(.)$/ + || $$self{opt_quotes} =~ /^(..)(..)$/) { + $$self{LQUOTE} = $1; + $$self{RQUOTE} = $2; + } else { + croak qq(Invalid quote specification "$$self{opt_quotes}"); + } + + # If requested, do something with the non-POD text. + $self->code_handler (\&handle_code) if $$self{opt_code}; + + # Return the created object. + return $self; +} + +############################################################################## +# Core parsing +############################################################################## + +# This is the glue that connects the code below with Pod::Simple itself. The +# goal is to convert the event stream coming from the POD parser into method +# calls to handlers once the complete content of a tag has been seen. Each +# paragraph or POD command will have textual content associated with it, and +# as soon as all of a paragraph or POD command has been seen, that content +# will be passed in to the corresponding method for handling that type of +# object. The exceptions are handlers for lists, which have opening tag +# handlers and closing tag handlers that will be called right away. +# +# The internal hash key PENDING is used to store the contents of a tag until +# all of it has been seen. It holds a stack of open tags, each one +# represented by a tuple of the attributes hash for the tag and the contents +# of the tag. + +# Add a block of text to the contents of the current node, formatting it +# according to the current formatting instructions as we do. +sub _handle_text { + my ($self, $text) = @_; + my $tag = $$self{PENDING}[-1]; + $$tag[1] .= $text; +} + +# Given an element name, get the corresponding method name. +sub method_for_element { + my ($self, $element) = @_; + $element =~ tr/-/_/; + $element =~ tr/A-Z/a-z/; + $element =~ tr/_a-z0-9//cd; + return $element; +} + +# Handle the start of a new element. If cmd_element is defined, assume that +# we need to collect the entire tree for this element before passing it to the +# element method, and create a new tree into which we'll collect blocks of +# text and nested elements. Otherwise, if start_element is defined, call it. +sub _handle_element_start { + my ($self, $element, $attrs) = @_; + my $method = $self->method_for_element ($element); + + # If we have a command handler, we need to accumulate the contents of the + # tag before calling it. + if ($self->can ("cmd_$method")) { + push (@{ $$self{PENDING} }, [ $attrs, '' ]); + } elsif ($self->can ("start_$method")) { + my $method = 'start_' . $method; + $self->$method ($attrs, ''); + } +} + +# Handle the end of an element. If we had a cmd_ method for this element, +# this is where we pass along the text that we've accumulated. Otherwise, if +# we have an end_ method for the element, call that. +sub _handle_element_end { + my ($self, $element) = @_; + my $method = $self->method_for_element ($element); + + # If we have a command handler, pull off the pending text and pass it to + # the handler along with the saved attribute hash. + if ($self->can ("cmd_$method")) { + my $tag = pop @{ $$self{PENDING} }; + my $method = 'cmd_' . $method; + my $text = $self->$method (@$tag); + if (defined $text) { + if (@{ $$self{PENDING} } > 1) { + $$self{PENDING}[-1][1] .= $text; + } else { + $self->output ($text); + } + } + } elsif ($self->can ("end_$method")) { + my $method = 'end_' . $method; + $self->$method (); + } +} + +############################################################################## +# 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{opt_width} - $$self{MARGIN}; + while (length > $width) { + if (s/^([^\n]{0,$width})\s+// || s/^([^\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{opt_sentence}) { + s/ +$//mg; + s/\.\n/. \n/g; + s/\n/ /g; + s/ +/ /g; + } else { + s/\s+/ /g; + } + return $self->wrap ($_); +} + +# Output text to the output device. Replace non-breaking spaces with spaces +# and soft hyphens with nothing, and then try to fix the output encoding if +# necessary to match the input encoding unless UTF-8 output is forced. This +# preserves the traditional pass-through behavior of Pod::Text. +sub output { + my ($self, $text) = @_; + $text =~ tr/\240\255/ /d; + unless ($$self{opt_utf8} || $$self{CHECKED_ENCODING}) { + my $encoding = $$self{encoding} || ''; + if ($encoding) { + eval { binmode ($$self{output_fh}, ":encoding($encoding)") }; + } + $$self{CHECKED_ENCODING} = 1; + } + print { $$self{output_fh} } $text; +} + +# Output a block of code (something that isn't part of the POD text). Called +# by preprocess_paragraph only if we were given the code option. Exists here +# only so that it can be overridden by subclasses. +sub output_code { $_[0]->output ($_[1]) } + +############################################################################## +# Document initialization +############################################################################## + +# Set up various things that have to be initialized on a per-document basis. +sub start_document { + my $self = shift; + my $margin = $$self{opt_indent} + $$self{opt_margin}; + + # Initialize a few per-document variables. + $$self{INDENTS} = []; # Stack of indentations. + $$self{MARGIN} = $margin; # Default left margin. + $$self{PENDING} = [[]]; # Pending output. + + # We have to redo encoding handling for each document. + delete $$self{CHECKED_ENCODING}; + + # If we were given the utf8 option, set an output encoding on our file + # handle. Wrap in an eval in case we're using a version of Perl too old + # to understand this. + # + # This is evil because it changes the global state of a file handle that + # we may not own. However, we can't just blindly encode all output, since + # there may be a pre-applied output encoding (such as from PERL_UNICODE) + # and then we would double-encode. This seems to be the least bad + # approach. + if ($$self{opt_utf8}) { + eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') }; + } + + return ''; +} + +############################################################################## +# Text blocks +############################################################################## + +# Intended for subclasses to override, this method returns text with any +# non-printing formatting codes stripped out so that length() correctly +# returns the length of the text. For basic Pod::Text, it does nothing. +sub strip_format { + my ($self, $string) = @_; + return $string; +} + +# 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, $text) = @_; + my $tag = $$self{ITEM}; + unless (defined $tag) { + carp "Item called without tag"; + return; + } + undef $$self{ITEM}; + + # Calculate the indentation and margin. $fits is set to true if the tag + # will fit into the margin of the paragraph given our indentation level. + my $indent = $$self{INDENTS}[-1]; + $indent = $$self{opt_indent} unless defined $indent; + my $margin = ' ' x $$self{opt_margin}; + my $tag_length = length ($self->strip_format ($tag)); + my $fits = ($$self{MARGIN} - $indent >= $tag_length + 1); + + # If the tag doesn't fit, or if we have no associated text, print out the + # tag separately. Otherwise, put the tag in the margin of the paragraph. + if (!$text || $text =~ /^\s+$/ || !$fits) { + my $realindent = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0); + $output =~ s/\n*$/\n/; + + # If the text is just whitespace, we have an empty item paragraph; + # this can result from =over/=item/=back without any intermixed + # paragraphs. Insert some whitespace to keep the =item from merging + # into the next paragraph. + $output .= "\n" if $text && $text =~ /^\s*$/; + + $self->output ($output); + $$self{MARGIN} = $realindent; + $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/); + } else { + my $space = ' ' x $indent; + $space =~ s/^$margin /$margin:/ if $$self{opt_alt}; + $text = $self->reformat ($text); + $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0); + my $tagspace = ' ' x $tag_length; + $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item"; + $self->output ($text); + } +} + +# Handle a basic block of text. The only tricky thing here is that if there +# is a pending item tag, we need to format this as an item paragraph. +sub cmd_para { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$/\n/; + if (defined $$self{ITEM}) { + $self->item ($text . "\n"); + } else { + $self->output ($self->reformat ($text . "\n")); + } + return ''; +} + +# Handle a verbatim paragraph. Just print it out, but indent it according to +# our margin. +sub cmd_verbatim { + my ($self, $attrs, $text) = @_; + $self->item if defined $$self{ITEM}; + return if $text =~ /^\s*$/; + $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme; + $text =~ s/\s*$/\n\n/; + $self->output ($text); + return ''; +} + +# Handle literal text (produced by =for and similar constructs). Just output +# it with the minimum of changes. +sub cmd_data { + my ($self, $attrs, $text) = @_; + $text =~ s/^\n+//; + $text =~ s/\n{0,2}$/\n/; + $self->output ($text); + return ''; +} + +############################################################################## +# Headings +############################################################################## + +# The common code for handling all headers. Takes the header text, the +# indentation, and the surrounding marker for the alt formatting method. +sub heading { + my ($self, $text, $indent, $marker) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $text =~ s/\s+$//; + if ($$self{opt_alt}) { + my $closemark = reverse (split (//, $marker)); + my $margin = ' ' x $$self{opt_margin}; + $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n"); + } else { + $text .= "\n" if $$self{opt_loose}; + my $margin = ' ' x ($$self{opt_margin} + $indent); + $self->output ($margin . $text . "\n"); + } + return ''; +} + +# First level heading. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, 0, '===='); +} + +# Second level heading. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, $$self{opt_indent} / 2, '== '); +} + +# Third level heading. +sub cmd_head3 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= '); +} + +# Fourth level heading. +sub cmd_head4 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- '); +} + +############################################################################## +# List handling +############################################################################## + +# Handle the beginning of an =over block. Takes the type of the block as the +# first argument, and then the attr hash. This is called by the handlers for +# the four different types of lists (bullet, number, text, and block). +sub over_common_start { + my ($self, $attrs) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + + # Find the indentation level. + my $indent = $$attrs{indent}; + unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) { + $indent = $$self{opt_indent}; + } + + # Add this to our stack of indents and increase our current margin. + push (@{ $$self{INDENTS} }, $$self{MARGIN}); + $$self{MARGIN} += ($indent + 0); + return ''; +} + +# End an =over block. Takes no options other than the class pointer. Output +# any pending items and then pop one level of indentation. +sub over_common_end { + my ($self) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $$self{MARGIN} = pop @{ $$self{INDENTS} }; + return ''; +} + +# Dispatch the start and end calls as appropriate. +sub start_over_bullet { $_[0]->over_common_start ($_[1]) } +sub start_over_number { $_[0]->over_common_start ($_[1]) } +sub start_over_text { $_[0]->over_common_start ($_[1]) } +sub start_over_block { $_[0]->over_common_start ($_[1]) } +sub end_over_bullet { $_[0]->over_common_end } +sub end_over_number { $_[0]->over_common_end } +sub end_over_text { $_[0]->over_common_end } +sub end_over_block { $_[0]->over_common_end } + +# The common handler for all item commands. Takes the type of the item, the +# attributes, and then the text of the item. +sub item_common { + my ($self, $type, $attrs, $text) = @_; + $self->item if defined $$self{ITEM}; + + # Clean up the text. We want to end up with two variables, one ($text) + # which contains any body text after taking out the item portion, and + # another ($item) which contains the actual item text. Note the use of + # the internal Pod::Simple attribute here; that's a potential land mine. + $text =~ s/\s+$//; + my ($item, $index); + if ($type eq 'bullet') { + $item = '*'; + } elsif ($type eq 'number') { + $item = $$attrs{'~orig_content'}; + } else { + $item = $text; + $item =~ s/\s*\n\s*/ /g; + $text = ''; + } + $$self{ITEM} = $item; + + # If body text for this item was included, go ahead and output that now. + if ($text) { + $text =~ s/\s*$/\n/; + $self->item ($text); + } + return ''; +} + +# Dispatch the item commands to the appropriate place. +sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) } +sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) } +sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) } +sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) } + +############################################################################## +# Formatting codes +############################################################################## + +# The simple ones. +sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] } +sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] } +sub cmd_i { return '*' . $_[2] . '*' } +sub cmd_x { return '' } + +# Apply a whole bunch of messy heuristics to not quote things that don't +# benefit from being quoted. These originally come from Barrie Slaymaker and +# largely duplicate code in Pod::Man. +sub cmd_c { + my ($self, $attrs, $text) = @_; + + # A regex that matches the portion of a variable reference that's the + # array or hash index, separated out just because we want to use it in + # several places in the following regex. + my $index = '(?: \[.*\] | \{.*\} )?'; + + # Check for things that we don't want to quote, and if we find any of + # them, return the string with just a font change and no quoting. + $text =~ m{ + ^\s* + (?: + ( [\'\`\"] ) .* \1 # already quoted + | \` .* \' # `quoted' + | \$+ [\#^]? \S $index # special ($^Foo, $") + | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func + | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call + | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number + | 0x [a-fA-F\d]+ # a hex constant + ) + \s*\z + }xo && return $text; + + # If we didn't return, go ahead and quote the text. + return $$self{opt_alt} + ? "``$text''" + : "$$self{LQUOTE}$text$$self{RQUOTE}"; +} + +# Links reduce to the text that we're given, wrapped in angle brackets if it's +# a URL. +sub cmd_l { + my ($self, $attrs, $text) = @_; + if ($$attrs{type} eq 'url') { + if (not defined($$attrs{to}) or $$attrs{to} eq $text) { + return "<$text>"; + } else { + return "$text <$$attrs{to}>"; + } + } else { + return $text; + } +} + +############################################################################## +# 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 -<number>. + 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::Text->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 @fhs = @_; + local *IN; + unless (open (IN, $fhs[0])) { + croak ("Can't open $fhs[0] for reading: $!\n"); + return; + } + $fhs[0] = \*IN; + $parser->output_fh ($fhs[1]); + my $retval = $parser->parse_file ($fhs[0]); + my $fh = $parser->output_fh (); + close $fh; + return $retval; + } else { + $parser->output_fh (\*STDOUT); + return $parser->parse_file (@_); + } +} + +# Reset the underlying Pod::Simple object between calls to parse_from_file so +# that the same object can be reused to convert multiple pages. +sub parse_from_file { + my $self = shift; + $self->reinit; + + # Fake the old cutting option to Pod::Parser. This fiddings with internal + # Pod::Simple state and is quite ugly; we need a better approach. + if (ref ($_[0]) eq 'HASH') { + my $opts = shift @_; + if (defined ($$opts{-cutting}) && !$$opts{-cutting}) { + $$self{in_pod} = 1; + $$self{last_was_blank} = 1; + } + } + + # Do the work. + my $retval = $self->Pod::Simple::parse_from_file (@_); + + # Flush output, since Pod::Simple doesn't do this. Ideally we should also + # close the file descriptor if we had to open one, but we can't easily + # figure this out. + my $fh = $self->output_fh (); + my $oldfh = select $fh; + my $oldflush = $|; + $| = 1; + print $fh ''; + $| = $oldflush; + select $oldfh; + return $retval; +} + +# Pod::Simple failed to provide this backward compatibility function, so +# implement it ourselves. File handles are one of the inputs that +# parse_from_file supports. +sub parse_from_filehandle { + my $self = shift; + $self->parse_from_file (@_); +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text - Convert POD data to formatted ASCII text + +=for stopwords +alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8 + +=head1 SYNOPSIS + + use Pod::Text; + my $parser = Pod::Text->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::Text 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::Simple, Pod::Text supports the same methods and +interfaces. See L<Pod::Simple> for all the details; briefly, one creates a +new parser with C<< Pod::Text->new() >> and then normally calls parse_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 code + +If set to a true value, the non-POD parts of the input file will be included +in the output. Useful for viewing code documented with POD blocks with the +POD rendered and the code left intact. + +=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<=head1> heading. +If set to false (the default), no blank line is printed after C<=head1>, +although one is still printed after C<=head2>. 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 margin + +The width of the left margin in spaces. Defaults to 0. This is the margin +for all text, including headings, not the amount by which regular text is +indented; for the latter, see the I<indent> option. To set the right +margin, see the I<width> option. + +=item quotes + +Sets the quote marks used to surround CE<lt>> text. If the value is a +single character, it is used as both the left and right quote; if it is two +characters, the first character is used as the left quote and the second as +the right quoted; and if it is four characters, the first two are used as +the left quote and the second two as the right quote. + +This may also be set to the special value C<none>, in which case no quote +marks are added around CE<lt>> text. + +=item sentence + +If set to a true value, Pod::Text 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 stderr + +Send error messages about invalid POD to standard error instead of +appending a POD ERRORS section to the generated output. + +=item utf8 + +By default, Pod::Text uses the same output encoding as the input encoding +of the POD source (provided that Perl was built with PerlIO; otherwise, it +doesn't encode its output). If this option is given, the output encoding +is forced to UTF-8. + +Be aware that, when using this option, the input encoding of your POD +source must be properly declared unless it is US-ASCII or Latin-1. POD +input without an C<=encoding> command will be assumed to be in Latin-1, +and if it's actually in UTF-8, the output will be double-encoded. See +L<perlpod(1)> for more information on the C<=encoding> command. + +=item width + +The column at which to wrap text on the right-hand side. Defaults to 76. + +=back + +The standard Pod::Simple method parse_file() takes one argument, the file or +file handle to read from, and writes output to standard output unless that +has been changed with the output_fh() method. See L<Pod::Simple> for the +specific details and for other alternative interfaces. + +=head1 DIAGNOSTICS + +=over 4 + +=item Bizarre space in item + +=item Item called without tag + +(W) Something has gone wrong in internal C<=item> processing. These +messages indicate a bug in Pod::Text; you should never see them. + +=item Can't open %s for reading: %s + +(F) Pod::Text was invoked via the compatibility mode pod2text() interface +and the input file it was given could not be opened. + +=item Invalid quote specification "%s" + +(F) The quote specification given (the quotes option to the constructor) was +invalid. A quote specification must be one, two, or four characters long. + +=back + +=head1 BUGS + +Encoding handling assumes that PerlIO is available and does not work +properly if it isn't. The C<utf8> option is therefore not supported +unless Perl is built with PerlIO support. + +=head1 CAVEATS + +If Pod::Text is given the C<utf8> option, the encoding of its output file +handle will be forced to UTF-8 if possible, overriding any existing +encoding. This will be done even if the file handle is not created by +Pod::Text and was passed in from outside. This maintains consistency +regardless of PERL_UNICODE and other settings. + +If the C<utf8> option is not given, the encoding of its output file handle +will be forced to the detected encoding of the input POD, which preserves +whatever the input text is. This ensures backward compatibility with +earlier, pre-Unicode versions of this module, without large numbers of +Perl warnings. + +This is not ideal, but it seems to be the best compromise. If it doesn't +work for you, please let me know the details of how it broke. + +=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::Simple, +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<Pod::Text::Termcap>. + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original +Pod::Text by Tom Christiansen <tchrist@mox.perl.com> and its conversion to +Pod::Parser by Brad Appleton <bradapp@enteract.com>. Sean Burke's initial +conversion of Pod::Man to use Pod::Simple provided much-needed guidance on +how to use Pod::Simple. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Russ Allbery +<rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm new file mode 100644 index 00000000000..2e8864148b4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm @@ -0,0 +1,155 @@ +# Pod::Text::Color -- Convert POD data to formatted color ASCII text +# +# Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This is just a basic proof of concept. It should later be modified to make +# better use of color, take options changing what colors are used for what +# text, and the like. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Color; + +require 5.004; + +use Pod::Text (); +use Term::ANSIColor qw(colored); + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +$VERSION = '2.06'; + +############################################################################## +# Overrides +############################################################################## + +# Make level one headings bold. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head1 ($attrs, colored ($text, 'bold')); +} + +# Make level two headings bold. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head2 ($attrs, colored ($text, 'bold')); +} + +# Fix the various formatting codes. +sub cmd_b { return colored ($_[2], 'bold') } +sub cmd_f { return colored ($_[2], 'cyan') } +sub cmd_i { return colored ($_[2], 'yellow') } + +# Output any included code in green. +sub output_code { + my ($self, $code) = @_; + $code = colored ($code, 'green'); + $self->output ($code); +} + +# Strip all of the formatting from a provided string, returning the stripped +# version. We will eventually want to use colorstrip() from Term::ANSIColor, +# but it's fairly new so avoid the tight dependency. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/\e\[[\d;]*m//g; + return $text; +} + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the escape sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + + # We have to do $shortchar and $longchar in variables because the + # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. + my $char = '(?:(?:\e\[[\d;]+m)*[^\n])'; + my $shortchar = $char . "{0,$width}"; + my $longchar = $char . "{$width}"; + while (length > $width) { + if (s/^($shortchar)\s+// || s/^($longchar)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text::Color - Convert POD data to formatted color ASCII text + +=for stopwords +Allbery + +=head1 SYNOPSIS + + use Pod::Text::Color; + my $parser = Pod::Text::Color->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::Text::Color is a simple subclass of Pod::Text that highlights output +text using ANSI color escape sequences. Apart from the color, it in all +ways functions like Pod::Text. See L<Pod::Text> for details and available +options. + +Term::ANSIColor is used to get colors and therefore must be installed to use +this module. + +=head1 BUGS + +This is just a basic proof of concept. It should be seriously expanded to +support configurable coloration via options passed to the constructor, and +B<pod2text> should be taught about those. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Simple> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm new file mode 100644 index 00000000000..7578f0f8f58 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm @@ -0,0 +1,208 @@ +# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text +# +# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000 +# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>) +# Copyright 2000 Joe Smith <Joe.Smith@inwap.com>. +# Copyright 2001, 2004, 2008 Russ Allbery <rra@stanford.edu>. +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This was written because the output from: +# +# pod2text Text.pm > plain.txt; less plain.txt +# +# is not as rich as the output from +# +# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt +# +# and because both Pod::Text::Color and Pod::Text::Termcap are not device +# independent. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Overstrike; + +require 5.004; + +use Pod::Text (); + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +$VERSION = '2.04'; + +############################################################################## +# Overrides +############################################################################## + +# Make level one headings bold, overridding any existing formatting. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/$1\b$1/g; + return $self->SUPER::cmd_head1 ($attrs, $text); +} + +# Make level two headings bold, overriding any existing formatting. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/$1\b$1/g; + return $self->SUPER::cmd_head2 ($attrs, $text); +} + +# Make level three headings underscored, overriding any existing formatting. +sub cmd_head3 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/_\b$1/g; + return $self->SUPER::cmd_head3 ($attrs, $text); +} + +# Level four headings look like level three headings. +sub cmd_head4 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/_\b$1/g; + return $self->SUPER::cmd_head4 ($attrs, $text); +} + +# The common code for handling all headers. We have to override to avoid +# interpolating twice and because we don't want to honor alt. +sub heading { + my ($self, $text, $indent, $marker) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $text .= "\n" if $$self{opt_loose}; + my $margin = ' ' x ($$self{opt_margin} + $indent); + $self->output ($margin . $text . "\n"); + return ''; +} + +# Fix the various formatting codes. +sub cmd_b { local $_ = $_[0]->strip_format ($_[2]); s/(.)/$1\b$1/g; $_ } +sub cmd_f { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ } +sub cmd_i { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ } + +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $code =~ s/(.)/$1\b$1/g; + $self->output ($code); +} + +# Strip all of the formatting from a provided string, returning the stripped +# version. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/(.)[\b]\1/$1/g; + $text =~ s/_[\b]//g; + return $text; +} + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the backspaces. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + while (length > $width) { + # This regex represents a single character, that's possibly underlined + # or in bold (in which case, it's three characters; the character, a + # backspace, and a character). Use [^\n] rather than . to protect + # against odd settings of $*. + my $char = '(?:[^\n][\b])?[^\n]'; + if (s/^((?>$char){0,$width})(?:\Z|\s+)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +=for stopwords +overstrike + +Pod::Text::Overstrike - Convert POD data to formatted overstrike text + +=for stopwords +overstruck Overstruck Allbery terminal's + +=head1 SYNOPSIS + + use Pod::Text::Overstrike; + my $parser = Pod::Text::Overstrike->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::Text::Overstrike is a simple subclass of Pod::Text that highlights +output text using overstrike sequences, in a manner similar to nroff. +Characters in bold text are overstruck (character, backspace, character) +and characters in underlined text are converted to overstruck underscores +(underscore, backspace, character). This format was originally designed +for hard-copy terminals and/or line printers, yet is readable on soft-copy +(CRT) terminals. + +Overstruck text is best viewed by page-at-a-time programs that take +advantage of the terminal's B<stand-out> and I<underline> capabilities, such +as the less program on Unix. + +Apart from the overstrike, it in all ways functions like Pod::Text. See +L<Pod::Text> for details and available options. + +=head1 BUGS + +Currently, the outermost formatting instruction wins, so for example +underlined text inside a region of bold text is displayed as simply bold. +There may be some better approach possible. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Simple> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery +<rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>. +Copyright 2001, 2004, 2008 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm new file mode 100644 index 00000000000..e4885c9d262 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm @@ -0,0 +1,195 @@ +# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. +# +# Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009 +# Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This is a simple subclass of Pod::Text that overrides a few key methods to +# output the right termcap escape sequences for formatted text on the current +# terminal type. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Termcap; + +require 5.004; + +use Pod::Text (); +use POSIX (); +use Term::Cap; + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +$VERSION = '2.06'; + +############################################################################## +# Overrides +############################################################################## + +# In the initialization method, grab our terminal characteristics as well as +# do all the stuff we normally do. +sub new { + my ($self, @args) = @_; + my ($ospeed, $term, $termios); + $self = $self->SUPER::new (@args); + + # $ENV{HOME} is usually not set on Windows. The default Term::Cap path + # may not work on Solaris. + my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; + $ENV{TERMPATH} = $home . '/etc/termcap:/usr/share/misc/termcap' + . ':/usr/share/lib/termcap'; + + # Fall back on a hard-coded terminal speed if POSIX::Termios isn't + # available (such as on VMS). + eval { $termios = POSIX::Termios->new }; + if ($@) { + $ospeed = 9600; + } else { + $termios->getattr; + $ospeed = $termios->getospeed || 9600; + } + + # Fall back on the ANSI escape sequences if Term::Cap doesn't work. + eval { $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed } }; + $$self{BOLD} = $$term{_md} || "\e[1m"; + $$self{UNDL} = $$term{_us} || "\e[4m"; + $$self{NORM} = $$term{_me} || "\e[m"; + + unless (defined $$self{width}) { + $$self{opt_width} = $ENV{COLUMNS} || $$term{_co} || 80; + $$self{opt_width} -= 2; + } + + return $self; +} + +# Make level one headings bold. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head1 ($attrs, "$$self{BOLD}$text$$self{NORM}"); +} + +# Make level two headings bold. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head2 ($attrs, "$$self{BOLD}$text$$self{NORM}"); +} + +# Fix up B<> and I<>. Note that we intentionally don't do F<>. +sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" } +sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" } + +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $self->output ($$self{BOLD} . $code . $$self{NORM}); +} + +# Strip all of the formatting from a provided string, returning the stripped +# version. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/\Q$$self{BOLD}//g; + $text =~ s/\Q$$self{UNDL}//g; + $text =~ s/\Q$$self{NORM}//g; + return $text; +} + +# Override the wrapping code to igore the special sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + + # $codes matches a single special sequence. $char matches any number of + # special sequences preceeding a single character other than a newline. + # We have to do $shortchar and $longchar in variables because the + # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. + my $codes = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + my $char = "(?:$codes*[^\\n])"; + my $shortchar = $char . "{0,$width}"; + my $longchar = $char . "{$width}"; + while (length > $width) { + if (s/^($shortchar)\s+// || s/^($longchar)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text::Termcap - Convert POD data to ASCII text with format escapes + +=for stopwords +ECMA-48 VT100 Allbery + +=head1 SYNOPSIS + + use Pod::Text::Termcap; + my $parser = Pod::Text::Termcap->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::Text::Termcap is a simple subclass of Pod::Text that highlights output +text using the correct termcap escape sequences for the current terminal. +Apart from the format codes, it in all ways functions like Pod::Text. See +L<Pod::Text> for details and available options. + +=head1 NOTES + +This module uses Term::Cap to retrieve the formatting escape sequences for +the current terminal, and falls back on the ECMA-48 (the same in this +regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100 +terminals) if the bold, underline, and reset codes aren't set in the +termcap information. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Simple>, L<Term::Cap> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009 Russ Allbery +<rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Usage.pm b/Master/tlpkg/tlperl/lib/Pod/Usage.pm new file mode 100644 index 00000000000..f463fb9c468 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Usage.pm @@ -0,0 +1,730 @@ +############################################################################# +# 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.36'; ## 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<pod2usage> 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<before> 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<exit()> 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<Pod::Select>) +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<English.pm>). + +If you are calling B<pod2usage()> 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<perldoc> when -verbose >= 2 is +specified. This does not work well e.g. if the script was packed +with L<PAR>. The -noperldoc option suppresses the external call to +L<perldoc> and uses the simple text formatter (L<Pod::Text>) to +output the POD. + +=back + +=head1 DESCRIPTION + +B<pod2usage> 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<is> specified but the verbose level is I<not>, 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<not> specified but verbose level I<is> 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<STDOUT>. Otherwise output is printed on C<STDERR>. + +=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<diff(1)> 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<grep(1)> exits with a status of 1 if +it did I<not> find a matching line for the given regular expression. + +=item * + +An exit status of 2 or more implies a fatal error. For example, B<ls(1)> +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<STDERR>. However, usage messages issued due to an explicit request +to print usage (like specifying B<-help> on the command line) should go +to C<STDOUT>, just in case the user wants to pipe the output to a pager +(such as B<more(1)>). + +=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<pod2usage> 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<pod2usage()> 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<there's more than one way to do it>, and +B<pod2usage()> adheres to this philosophy. If you are interested in +seeing a number of different ways to invoke B<pod2usage> (although by no +means exhaustive), please refer to L<"EXAMPLES">. + +=head1 EXAMPLES + +Each of the following invocations of C<pod2usage()> will print just the +"SYNOPSIS" section to C<STDERR> 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<pod2usage()> will print a message +of "Syntax error." (followed by a newline) to C<STDERR>, immediately +followed by just the "SYNOPSIS" section (also printed to C<STDERR>) 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<pod2usage()> will print the +"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to +C<STDOUT> 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<pod2usage()> will print the +entire manual page to C<STDOUT> 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<STDERR> 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<STDOUT>. Some scripts may even wish to go so far as to +provide a means of printing their complete documentation to C<STDOUT> +(perhaps by allowing a C<-man> option). The following complete example +uses B<Pod::Usage> in combination with B<Getopt::Long> 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<This program> will read the given input file(s) and do something + useful with the contents thereof. + + =cut + +=head1 CAVEATS + +By default, B<pod2usage()> 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<pod2usage()> 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<and> the script itself changes the current working directory +(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will +fail even on robust platforms. Don't do that. + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Marek Rouchal E<lt>marekr@cpan.orgE<gt> + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<Pod::Text::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=head1 ACKNOWLEDGMENTS + +Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience +with re-writing this manpage. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find> + +=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{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 { + $self = $self->SUPER::new(); + %$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 |