Wala shell

Advanced PHP File Manager

Server IP: 127.0.0.1 | PHP Version: 8.3.30 | Domains Hosted: 54

Name	Size	Last Modified	Actions
📁 ..	-	2026-03-21 15:45
📄 Escapes.pm package Pod::Escapes; use strict; use warnings; use 5.006; use vars qw( %Code2USASCII %Name2character %Name2character_number %Latin1Code_to_fallback %Latin1Char_to_fallback $FAR_CHAR $FAR_CHAR_NUMBER $NOT_ASCII @ISA $VERSION @EXPORT_OK %EXPORT_TAGS ); require Exporter; @ISA = ('Exporter'); $VERSION = '1.07'; @EXPORT_OK = qw( %Code2USASCII %Name2character %Name2character_number %Latin1Code_to_fallback %Latin1Char_to_fallback e2char e2charnum ); %EXPORT_TAGS = ('ALL' => \@EXPORT_OK); #========================================================================== $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($in =~ m/^\d+$/s) { if($] < 5.007 and $in > 255) { # can't be trusted with Unicode return $FAR_CHAR; } elsif ($] >= 5.007003) { return chr(utf8::unicode_to_native($in)); } elsif ($NOT_ASCII) { return $Code2USASCII{$in} # so "65" => "A" everywhere \|\| $Latin1Code_to_fallback{$in} # Fallback. \|\| $FAR_CHAR; # Fall further back } 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/^[0-9]+$/s) { return 0 + $in; } else { return $Name2character_number{$in}; # returns undef if unknown } } #-------------------------------------------------------------------------- %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"; } } #-------------------------------------------------------------------------- %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 reliably handle them } elsif ($] >= 5.007003) { $Name2character{$name} = chr utf8::unicode_to_native($number); # normal case for more recent Perls where we can translate from Unicode # to the native character set. } elsif (exists $Code2USASCII{$number}) { $Name2character{$name} = $Code2USASCII{$number}; # on older Perls, we can use the translations we have hard-coded in this # file, but these don't include the non-ASCII-range characters } elsif ($NOT_ASCII && $number > 127 && $number < 256) { # this range on old non-ASCII-platform perls is wrong if (exists $Latin1Code_to_fallback{$number}) { $Name2character{$name} = $Latin1Code_to_fallback{$number}; } else { $Name2character{$name} = $FAR_CHAR; } } else { $Name2character{$name} = chr $number; } } } #-------------------------------------------------------------------------- 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 syntactically 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 syntactically 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})>, because the strings are returned as native, and the numbers are returned as Unicode. However, for Perls starting with v5.8, C<e2char($n)> is the same as C<chr(utf8::unicode_to_native(e2charnum($n)))>, and ditto for C<$Name2character{$name}> and C<chr(utf8::unicode_to_native($Name2character_number{$name}))>. =head1 SEE ALSO L<Pod::Browser> - a pod web server based on L<Catalyst>. L<Pod::Checker> - check pod documents for syntax errors. L<Pod::Coverage> - check if the documentation for a module is comprehensive. L<perlpod> - description of pod format (for people documenting with pod). L<perlpodspec> - specification of pod format (for people processing it). L<Text::Unidecode> - ASCII transliteration of Unicode text. =head1 REPOSITORY L<https://github.com/neilbowers/Pod-Escapes> =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> Now being maintained by Neil Bowers E<lt>neilb@cpan.orgE<gt> =cut #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # What I used for reading the XHTML .ent files: 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__ #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~	17.47 KB	2014-12-09 21:31
📄 Man.pm # Convert POD data to formatted roff input. # # 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. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl ############################################################################## # Modules and declarations ############################################################################## package Pod::Man; use 5.008; use strict; use warnings; use subs qw(makespace); use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); use Carp qw(carp croak); use Pod::Simple (); # Conditionally import Encode and set $HAS_ENCODE if it is available. This is # required to support building as part of Perl core, since podlators is built # before Encode is. our $HAS_ENCODE; BEGIN { $HAS_ENCODE = eval { require Encode }; } @ISA = qw(Pod::Simple); $VERSION = '4.14'; # 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 } # Formatting instructions for various types of blocks. cleanup makes hyphens # hard, adds spaces between consecutive underscores, and escapes backslashes. # convert translates characters into escapes. guesswork means to apply the # transformations done by the guesswork sub. literal says to protect literal # quotes from being turned into UTF-8 quotes. By default, all transformations # are on except literal, but some elements override. # # DEFAULT specifies the default settings. All other elements should list only # those settings that they are overriding. Data indicates =for roff blocks, # which should be passed along completely verbatim. # # Formatting inherits negatively, in the sense that if the parent has turned # off guesswork, all child elements should leave it off. my %FORMATTING = ( DEFAULT => { cleanup => 1, convert => 1, guesswork => 1, literal => 0 }, Data => { cleanup => 0, convert => 0, guesswork => 0, literal => 0 }, Verbatim => { guesswork => 0, literal => 1 }, C => { guesswork => 0, literal => 1 }, X => { cleanup => 0, guesswork => 0 }, ); ############################################################################## # 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 (my $preserve_whitespace = $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} and not $$self{errors}) { $$self{errors} = 'stderr'; } delete $$self{stderr}; # Validate the errors parameter and act on it. if (not defined $$self{errors}) { $$self{errors} = 'pod'; } if ($$self{errors} eq 'stderr' \|\| $$self{errors} eq 'die') { $self->no_errata_section (1); $self->complain_stderr (1); if ($$self{errors} eq 'die') { $$self{complain_die} = 1; } } elsif ($$self{errors} eq 'pod') { $self->no_errata_section (0); $self->complain_stderr (0); } elsif ($$self{errors} eq 'none') { $self->no_errata_section (1); $self->no_whining (1); } else { croak (qq(Invalid errors setting: "$$self{errors}")); } delete $$self{errors}; # Degrade back to non-utf8 if Encode is not available. # # Suppress the warning message when PERL_CORE is set, indicating this is # running as part of the core Perl build. Perl builds podlators (and all # pure Perl modules) before Encode and other XS modules, so Encode won't # yet be available. Rely on the Perl core build to generate man pages # later, after all the modules are available, so that UTF-8 handling will # be correct. if ($$self{utf8} and !$HAS_ENCODE) { if (!$ENV{PERL_CORE}) { carp ('utf8 mode requested but Encode module not available,' . ' falling back to non-utf8'); } delete $$self{utf8}; } # 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 parameters 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) = (@_); # Handle the quotes option first, which sets both quotes at once. $$self{quotes} \|\|= '"'; if ($$self{quotes} eq 'none') { $$self{LQUOTE} = $$self{RQUOTE} = ''; } elsif (length ($$self{quotes}) == 1) { $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; } elsif (length ($$self{quotes}) % 2 == 0) { my $length = length ($$self{quotes}) / 2; $$self{LQUOTE} = substr ($$self{quotes}, 0, $length); $$self{RQUOTE} = substr ($$self{quotes}, $length); } else { croak(qq(Invalid quote specification "$$self{quotes}")) } # Now handle the lquote and rquote options. if (defined $$self{lquote}) { $$self{LQUOTE} = $$self{lquote} eq 'none' ? q{} : $$self{lquote}; } if (defined $$self{rquote}) { $$self{RQUOTE} = $$self{rquote} eq 'none' ? q{} : $$self{rquote}; } # 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) = @_; # Get the version from the running Perl. my @version = ($] =~ /^(\d+)\.(\d{3})(\d+)$/); 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/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{DEFAULT} }, %{ $FORMATTING{$element} \|\| {} }, }; push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]); DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n"; } elsif (my $start_method = $self->can ("start_$method")) { $self->$start_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 (my $cmd_method = $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 $text = $self->$cmd_method ($$tag[0], $$tag[2]); if (defined $text) { if (@{ $$self{PENDING} } > 1) { $$self{PENDING}[-1][2] .= $text; } else { $self->output ($text); } } } elsif (my $end_method = $self->can ("end_$method")) { $self->$end_method (); } else { DEBUG > 2 and print "No $method end method, skipping\n"; } } ############################################################################## # General formatting ############################################################################## # 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 hyphens 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). # # Allow the text we're changing to small caps to include double quotes, # commas, newlines, and periods as long as it doesn't otherwise interrupt # the string of small caps and still fits the criteria. This lets us turn # entire warranty disclaimers in man page output into small caps. if ($$self{MAGIC_SMALLCAPS}) { s{ ( ^ \| [\s\(\"\'\`\[\{<>] \| \\[ ] ) # (1) ( [A-Z] [A-Z] (?: \s? [/A-Z+:\d_\$&] \| \\- \| \s? [.,\"] )* ) # (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. # Embolden functions in the form func(), including functions that are in # all capitals, but don't embolden 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(BS' . $2 . '\f(BE' }egx; } # Change references to manual pages to put the page name in bold 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 ) (?<! \\ ) # rule out \s0(1) ( [A-Za-z_] (?:[.:\w] \| \\- \| \\s-?[01])+ ) ( \( \d [a-z] \) ) } { $1 . '\f(BS' . $2 . '\f(BE\\|' . $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. my $font_end = "(?:\\f[PR]\|\Q$$self{FONTS}{100}\E)"; $nroff =~ s/\Q$$self{FONTS}{100}\E(.?)\\f([PR])/$1/g; $nroff =~ s/\Q$$self{FONTS}{101}\E(.?)$font_end/\\fI$1\\fP/g; $nroff =~ s/\Q$$self{FONTS}{110}\E(.?)$font_end/\\fB$1\\fP/g; $nroff =~ s/\Q$$self{FONTS}{111}\E(.?)$font_end/\\f\(BI$1\\fP/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/\s+/ /g; $entry =~ s/\"/\"\"/g; $entry =~ s/\\/\\\\/g; $self->output (".IX $type " . '"' . $entry . '"' . "\n"); } } # Output some text, without any additional changes. sub output { my ($self, @text) = @_; if ($$self{ENCODE}) { print { $$self{output_fh} } Encode::encode ('UTF-8', join ('', @text)); } else { 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; } else { delete $$self{CONTENTLESS}; } # When UTF-8 output is set, check whether our output file handle already # has a PerlIO encoding layer set. If it does not, we'll need to encode # our output before printing it (handled in the output() sub). Wrap the # check in an eval to handle versions of Perl without PerlIO. # # PerlIO::get_layers still requires its argument be a glob, so coerce the # file handle to a glob. $$self{ENCODE} = 0; if ($$self{utf8}) { $$self{ENCODE} = 1; eval { my @options = (output => 1, details => 1); my @layers = PerlIO::get_layers ({$$self{output_fh}}, @options); if ($layers[-1] && ($layers[-1] & PerlIO::F_UTF8 ())) { $$self{ENCODE} = 0; } } } # Determine information for the preamble and then output it unless the # document was content-free. if (!$$self{CONTENTLESS}) { my ($name, $section); if (defined $$self{name}) { $name = $$self{name}; $section = $$self{section} \|\| 1; } else { ($name, $section) = $self->devise_title; } my $date = defined($$self{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 handles dying on POD errors, since # Pod::Parser currently doesn't. Otherwise, does nothing but print out a # final comment at the end of the document under debugging. sub end_document { my ($self) = @_; if ($$self{complain_die} && $self->errors_seen) { croak ("POD document had syntax errors"); } 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 Pod::Parser gave us an IO::File reference as the source file name, # convert that to the empty string as well. Then, if we don't have a # valid name, convert it to STDIN. # # In podlators 4.00 through 4.07, this also produced a warning, but that # was surprising to a lot of programs that had expected to be able to pipe # POD through pod2man without specifying the name. In the name of # backward compatibility, just quietly set STDIN as the page title. if ($name =~ /^IO::File(?:=\w+)\(0x[\da-f]+\)$/i) { $name = ''; } if ($name eq '') { $name = 'STDIN'; } # If the section isn't 3, then the name defaults to just the basename of # the file. if ($section !~ /^3/) { require File::Basename; $name = uc File::Basename::basename ($name); } else { require File::Spec; my ($volume, $dirs, $file) = File::Spec->splitpath ($name); # 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 of: # # /lib/perl/ standard or site_perl module # /perl/lib/ from -Dprefix=/opt/perl # /perl/ random module hierarchy # # 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. my @dirs = File::Spec->splitdir ($dirs); if (@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 POD_MAN_DATE is set, that overrides anything else. This can be used for # reproducible generation of the same file even if the input file timestamps # are unpredictable or the POD comes from standard input. # # Otherwise, if SOURCE_DATE_EPOCH is set and can be parsed as seconds since # the UNIX epoch, base the timestamp on that. See # <https://reproducible-builds.org/specs/source-date-epoch/> # # Otherwise, use the modification date of the input if we can stat it. Be # aware that Pod::Simple returns the stringification of the file handle as # source_filename for input from a file handle, so we'll stat some random ref # string in that case. If that fails, instead use the current time. # # $self - Pod::Man object, used to get the source file # # Returns: YYYY-MM-DD date suitable for the left-hand footer sub devise_date { my ($self) = @_; # If POD_MAN_DATE is set, always use it. if (defined($ENV{POD_MAN_DATE})) { return $ENV{POD_MAN_DATE}; } # If SOURCE_DATE_EPOCH is set and can be parsed, use that. my $time; if (defined($ENV{SOURCE_DATE_EPOCH}) && $ENV{SOURCE_DATE_EPOCH} !~ /\D/) { $time = $ENV{SOURCE_DATE_EPOCH}; } # Otherwise, get the input filename and try to stat it. If that fails, # use the current time. if (!defined $time) { my $input = $self->source_filename; 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. # Use gmtime instead of localtime so that the generated man page does not # depend on the local time zone setting and is more reproducible my ($year, $month, $day) = (gmtime($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, but leave "\ " backslashed space from an S< > at # the end of a line. Reverse the text first, to avoid having to scan the # entire paragraph. $text = reverse $text; $text =~ s/\A\s?(?= \\\|\S\|\z)/\n/; $text = reverse $text; # 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. Reverse the text first, to avoid having to scan # the entire paragraph. $text = reverse $text; $text =~ s/\A\s/\n/; $text = reverse $text; # 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, followed by the URL. We take an option to suppress the URL if anchor # text is given. We need to format the "to" value of the link before # comparing it to the text since we may escape hyphens. sub cmd_l { my ($self, $attrs, $text) = @_; if ($$attrs{type} eq 'url') { my $to = $$attrs{to}; if (defined $to) { my $tag = $$self{PENDING}[-1]; $to = $self->format_text ($$tag[1], $to); } if (not defined ($to) or $to eq $text) { return "<$text>"; } elsif ($$self{nourls}) { 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 fiddles 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; return $self->parse_from_file (@_); } # Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so # ourself unless it was already set by the caller, since our documentation has # always said that this should work. sub parse_file { my ($self, $in) = @_; unless (defined $$self{output_fh}) { $self->output_fh (\STDOUT); } return $self->SUPER::parse_file ($in); } # Do the same for parse_lines, just to be polite. Pod::Simple's man page # implies that the caller is responsible for setting this, but I don't see any # reason not to set a default. sub parse_lines { my ($self, @lines) = @_; unless (defined $$self{output_fh}) { $self->output_fh (\STDOUT); } return $self->SUPER::parse_lines (@lines); } # Likewise for parse_string_document. sub parse_string_document { my ($self, $doc) = @_; unless (defined $$self{output_fh}) { $self->output_fh (\STDOUT); } return $self->SUPER::parse_string_document ($doc); } ############################################################################## # 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" '' . ds C` . ds C' '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 >0, 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. .\" .\" Avoid warning from groff about undefined register 'F'. .de IX .. .nr rF 0 .if \n(.g .if rF .nr rF 1 .if (\n(rF:(\n(.g==0)) \{\ . if \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" .. . if !\nF==2 \{\ . nr % 0 . nr F 2 . \} . \} .\} .rr rF ----END OF PREAMBLE---- #'# for cperl-mode 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(.wu8/10-\(#H)'\'\h"\|\\n:u" . ds ` \\k:\h'-(\\n(.wu8/10-\(#H)'\`\h'\|\\n:u' . ds ^ \\k:\h'-(\\n(.wu10/11-\(#H)'^\h'\|\\n:u' . ds , \\k:\h'-(\\n(.wu8/10)',\h'\|\\n:u' . ds ~ \\k:\h'-(\\n(.wu-\(#H-.1m)'~\h'\|\\n:u' . ds / \\k:\h'-(\\n(.wu8/10-\(#H)'\z\(sl\h'\|\\n:u' .\} . \" troff and (daisy-wheel) nroff accents .ds : \\k:\h'-(\\n(.wu8/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'u2/3)'\s-1o\s+1\(#] .ds Th \(#[\s+2I\s-2\h'-\w'I'u3/5'\v'-.3m'o\v'.3m'\(#] .ds ae a\h'-(\w'a'u4/10)'e .ds Ae A\h'-(\w'A'u4/10)'E . \" corrections for vroff .if v .ds ~ \\k:\h'-(\\n(.wu9/10-\(#H)'\s-2\u~\d\s+2\h'\|\\n:u' .if v .ds ^ \\k:\h'-(\\n(.wu10/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__ =for stopwords en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8 UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased Christiansen nourls parsers Kernighan lquote rquote =head1 NAME Pod::Man - Convert POD data to formatted roff input =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 for the C<.TH> macro. The default, if this option is not specified, is "User Contributed Perl Documentation". =item date Sets the left-hand footer for the C<.TH> macro. If this option is not set, the contents of the environment variable POD_MAN_DATE, if set, will be used. Failing that, the value of SOURCE_DATE_EPOCH, the modification date of the input file, or the current time if stat() can't find that file (which will be the case if the input is from C<STDIN>) will be used. If obtained from the file modification date or the current time, the date will be formatted as C<YYYY-MM-DD> and will be based on UTC (so that the output will be reproducible regardless of local time zone). =item errors How to report errors. C<die> says to throw an exception on any POD formatting error. C<stderr> says to report errors on standard error, but not to throw an exception. C<pod> says to include a POD ERRORS section in the resulting documentation summarizing the errors. C<none> ignores POD errors entirely, as much as possible. The default is C<pod>. =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 lquote =item rquote Sets the quote marks used to surround CE<lt>> text. C<lquote> sets the left quote mark and C<rquote> sets the right quote mark. Either may also be set to the special value C<none>, in which case no quote mark is added on that side of CE<lt>> text (but the font is still changed for troff output). Also see the C<quotes> option, which can be used to set both quotes at once. If both C<quotes> and one of the other options is set, C<lquote> or C<rquote> overrides C<quotes>. =item name Set the name of the manual page for the C<.TH> macro. 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. If generating a manual page from standard input, the name will be set to C<STDIN> if this option is not provided. Providing this option is strongly recommended to set a meaningful manual page name. =item nourls Normally, LZ<><> formatting codes with a URL but anchor text are formatted to show both the anchor text and the URL. In other words: L<foo\|http://example.com/> is formatted as: foo <http://example.com/> This option, if set to a true value, suppresses the URL when anchor text is given, so this example would be formatted as just C<foo>. This can produce less cluttered output in cases where the URLs are not particularly important. =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. Otherwise, it is split in half, and the first half of the string is used as the left quote and the second is used 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). Also see the C<lquote> and C<rquote> options, which can be used to set the left and right quotes independently. If both C<quotes> and one of the other options is set, C<lquote> or C<rquote> overrides C<quotes>. =item release Set the centered footer for the C<.TH> macro. By default, this is set to the version of Perl you run Pod::Man under. Setting this to the empty string will cause some roff implementations to use the system default value. Note that some system C<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 for your target system, 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. This is equivalent to setting C<errors> to C<stderr> if C<errors> is not already set. It is supported for backward compatibility. =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 should be properly declared unless it's US-ASCII. Pod::Simple will attempt to guess the encoding and may be successful if it's Latin-1 or UTF-8, but it will produce warnings. Use the C<=encoding> command to declare the encoding. See L<perlpod(1)> for more information. =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_fh() 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. As with parse_file(), parse_lines() and parse_string_document() default to sending their output to C<STDOUT> unless changed with the output_fh() method. Be aware that parse_lines() and parse_string_document() both expect raw bytes, not decoded characters. To put the output from any parse method into a string instead of a file handle, call the output_string() method instead of output_fh(). See L<Pod::Simple> for more specific details on the methods available to all derived parsers. =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 errors setting "%s" (F) The C<errors> parameter to the constructor was set to an unknown value. =item Invalid quote specification "%s" (F) The quote specification given (the C<quotes> option to the constructor) was invalid. A quote specification must be either one character long or an even number (greater than one) characters long. =item POD document had syntax errors (F) The POD document being formatted had syntax errors and the C<errors> option was set to C<die>. =back =head1 ENVIRONMENT =over 4 =item PERL_CORE If set and Encode is not available, silently fall back to non-UTF-8 mode without complaining to standard error. This environment variable is set during Perl core builds, which build Encode after podlators. Encode is expected to not (yet) be available in that case. =item POD_MAN_DATE If set, this will be used as the value of the left-hand footer unless the C<date> option is explicitly set, overriding the timestamp of the input file or the current time. This is primarily useful to ensure reproducible builds of the same output file given the same source and Pod::Man version, even when file timestamps may not be consistent. =item SOURCE_DATE_EPOCH If set, and POD_MAN_DATE and the C<date> options are not set, this will be used as the modification time of the source file, overriding the timestamp of the input file or the current time. It should be set to the desired time in seconds since UNIX epoch. This is primarily useful to ensure reproducible builds of the same output file given the same source and Pod::Man version, even when file timestamps may not be consistent. See L<https://reproducible-builds.org/specs/source-date-epoch/> for the full specification. (Arguably, according to the specification, this variable should be used only if the timestamp of the input file is not available and Pod::Man uses the current time. However, for reproducible builds in Debian, results were more reliable if this variable overrode the timestamp of the input file.) =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@cpan.org>, 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 <sburke@cpan.org> (but I've since hacked them beyond recognition and all bugs are mine). =head1 COPYRIGHT AND LICENSE Copyright 1999-2010, 2012-2019 Russ Allbery <rra@cpan.org> 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. =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.troff.org/54.pdf>. 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<https://www.eyrie.org/~eagle/software/podlators/>. It is also part of the Perl core distribution as of 5.6.0. =cut # Local Variables: # copyright-at-end-flag: t # End:	77.88 KB	2020-01-04 23:16
📄 ParseLink.pm # Parse an L<> formatting code in POD text. # # 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. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl ############################################################################## # Modules and declarations ############################################################################## package Pod::ParseLink; use 5.008; use strict; use warnings; use vars qw(@EXPORT @ISA $VERSION); use Exporter; @ISA = qw(Exporter); @EXPORT = qw(parselink); $VERSION = '4.14'; ############################################################################## # 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__ =for stopwords markup Allbery URL =head1 NAME Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text =head1 SYNOPSIS use Pod::ParseLink; my $link = get_link(); 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 AUTHOR Russ Allbery <rra@cpan.org> =head1 COPYRIGHT AND LICENSE Copyright 2001, 2008, 2009, 2014, 2018-2019 Russ Allbery <rra@cpan.org> 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::Parser> The current version of this module is always available from its web site at L<https://www.eyrie.org/~eagle/software/podlators/>. =cut # Local Variables: # copyright-at-end-flag: t # End:	6.25 KB	2020-01-04 23:16
📁 Perldoc	-	2025-02-27 15:06
📄 Perldoc.pm 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::Basename qw(basename); use File::Spec::Functions qw(catfile catdir splitdir); use vars qw($VERSION @Pagers $Bindir $Pod2man $Temp_Files_Created $Temp_File_Lifetime ); $VERSION = '3.2801'; #.......................................................................... 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. use Carp qw(croak carp); # these are also in BaseTo, which I don't want to inherit sub debugging { my $self = shift; ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() ) } sub debug { my( $self, @messages ) = @_; return unless $self->debugging; print STDERR map { "DEBUG : $_" } @messages; } sub warn { my( $self, @messages ) = @_; carp( join "\n", @messages, '' ); } sub die { my( $self, @messages ) = @_; croak( join "\n", @messages, '' ); } #.......................................................................... 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; is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos; } $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 __PACKAGE__->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{mhlDriFfXqnTdULva}) { no strict 'refs'; $subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; } # And these are so that GetOptsOO knows they take options: sub opt_a_with { shift->_elem('opt_a', @_) } 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 { $self->warn( qq("$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 { $self->warn( qq("$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 { $self->warn( qq("$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 ) { $self->aside("Considering $prefix$stem\n"); push @classes, $prefix . $stem; } # 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; $self->warn( "@_\n" ) if @_; # Erase evidence of previous errors (if any), so exit status is simple. $! = 0; CORE::die( <<EOF ); perldoc [options] PageName\|ModuleName\|ProgramName\|URL... 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 Pod::Man and groff (-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 groff -l Display the module's file name -U Don't attempt to drop privs for security -F Arguments are file names, not modules (implies -U) -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 -a Search Perl API -v Search predefined Perl variables PageName\|ModuleName\|ProgramName\|URL... 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', or a URL starting with http(s). BuiltinFunction is the name of a perl function. Will extract documentation from `perlfunc' or `perlop'. 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 program_name { my( $self ) = @_; if( my $link = readlink( $0 ) ) { $self->debug( "The value in $0 is a symbolic link to $link\n" ); } my $basename = basename( $0 ); $self->debug( "\$0 is [$0]\nbasename is [$basename]\n" ); # possible name forms # perldoc # perldoc-v5.14 # perldoc-5.14 # perldoc-5.14.2 # perlvar # an alias mentioned in Camel 3 { my( $untainted ) = $basename =~ m/( \A perl (?: doc \| func \| faq \| help \| op \| toc \| var # Camel 3 ) (?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version (?: \. (?: bat \| exe \| com ) )? # possible extension \z ) /x; $self->debug($untainted); return $untainted if $untainted; } $self->warn(<<"HERE"); You called the perldoc command with a name that I didn't recognize. This might mean that someone is tricking you into running a program you don't intend to use, but it also might mean that you created your own link to perldoc. I think your program name is [$basename]. I'll allow this if the filename only has [a-zA-Z0-9._-]. HERE { my( $untainted ) = $basename =~ m/( \A [a-zA-Z0-9._-]+ \z )/x; $self->debug($untainted); return $untainted if $untainted; } $self->die(<<"HERE"); I think that your name for perldoc is potentially unsafe, so I'm going to disallow it. I'd rather you be safe than sorry. If you intended to use the name I'm disallowing, please tell the maintainers about it. Write to: Pod-Perldoc\@rt.cpan.org HERE } #.......................................................................... sub usage_brief { my $self = shift; my $program_name = $self->program_name; CORE::die( <<"EOUSAGE" ); Usage: $program_name [-hVriDtumUFXlT] [-n nroffer_program] [-d output_filename] [-o output_format] [-M FormatterModule] [-w formatter_option:option_value] [-L translation_code] PageName\|ModuleName\|ProgramName Examples: $program_name -f PerlFunc $program_name -q FAQKeywords $program_name -v PerlVar $program_name -a PerlAPI The -h option prints more help. Also try "$program_name 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 if ( $] < 5.008 ) { $self->aside("Your old perl doesn't have proper unicode support."); } else { # http://www.perl.com/pub/2012/04/perlunicookbook-decode-argv-as-utf8.html # Decode command line arguments as UTF-8. See RT#98906 for example problem. use Encode qw(decode_utf8); @ARGV = map { decode_utf8($_, 1) } @ARGV; } $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'}; $self->{'search_path'} = [ ] unless exists $self->{'search_path'}; 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'); 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->options_reading; $self->pagers_guessing; $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); $self->drop_privs_maybe unless ($self->opt_U \|\| $self->opt_F); $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 = qw(perlfunc perlop) } elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } elsif( $self->opt_v) { @pages = ("perlvar") } elsif( $self->opt_a) { @pages = ("perlapi") } 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_extend_searchpath(); # for when we're apparently in a module or extension directory my @found = $self->grand_search_init(\@pages); exit ($self->is_vms ? 98962 : 1) unless @found; if ($self->opt_l and not $self->opt_q ) { 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'} \|\| [] }; $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list; local @INC = @INC; pop @INC if $INC[-1] eq '.'; 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( ( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2) # the always case-insensitive filesystems 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-suppressible warnings from 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"; } } $self->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'} \|\| $self->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; my $me = $self->program_name; $self->die( "When using Perldoc to format with $formatter_class, you have to\n" . "specify -T or -dsomefile$ext\n" . "See `$me 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; # This used to set a default, but that's now moved into any # formatter that cares to have a default. if( $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 or $self->opt_a) { my $count; $count++ if $self->opt_f; $count++ if $self->opt_q; $count++ if $self->opt_a; $self->usage("Only one of -f or -q or -a") if $count > 1; $self->warn( "Perldoc is meant for reading one file 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 (/^http(s)?:\/\//) { require HTTP::Tiny; require File::Temp; my $response = HTTP::Tiny->new->get($_); if ($response->{success}) { my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1); $fh->print($response->{content}); push @found, $filename; ($self->{podnames}{$filename} = m{./([^/#?]+)} ? uc $1 : "UNKNOWN") =~ s/\.P(?:[ML]\|OD)\z//; } else { print STDERR "No " . ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; if ( /^https/ ) { print STDERR "You may need an SSL library (such as IO::Socket::SSL) for that URL.\n"; } } next; } 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 $self->die( "Can't close $$self{'podidx'}: $!" ); next; } $self->aside( "Searching for $_\n" ); if ($self->opt_F) { next unless -r; push @found, $_ if $self->opt_l or $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'}, @{$self->{search_path}}, @INC); unless ($self->opt_m) { if ($self->is_vms) { my($i,$trn); for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { push(@searchdirs,$trn); } push(@searchdirs,'perl_root:[lib.pods]') # 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"; my $me = $self->program_name; for my $dir (@{ $self->{'found'} }) { opendir(DIR, $dir) or $self->die( "opendir $dir: $!" ); while (my $file = readdir(DIR)) { next if ($file =~ /^\./s); $file =~ s/\.(pm\|pod)\z//; # XXX: badfs print STDERR "\t$me $_\::$file\n"; } closedir(DIR) or $self->die( "closedir $dir: $!" ); } } } } push(@found,@files); } return @found; } #.......................................................................... sub maybe_generate_dynamic_pod { my($self, $found_things) = @_; my @dynamic_pod; $self->search_perlapi($found_things, \@dynamic_pod) if $self->opt_a; $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 and ! $self->opt_a) { 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'); if ( $] >= 5.008 && $self->opt_L ) { binmode($buffd, ":encoding(UTF-8)"); print $buffd "=encoding utf8\n\n"; } push @{ $self->{'temp_file_list'} }, $buffer; # I.e., it MIGHT be deleted at the end. my $in_list = !$self->not_dynamic && $self->opt_f \|\| $self->opt_v \|\| $self->opt_a; print $buffd "=over 8\n\n" if $in_list; print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" ); print $buffd "=back\n" if $in_list; close $buffd or $self->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 not_dynamic { my ($self,$value) = @_; $self->{__not_dynamic} = $value if @_ == 2; return $self->{__not_dynamic}; } #.......................................................................... 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; local @INC = @INC; pop @INC if $INC[-1] eq '.'; 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 $self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" ); } } return; } #.......................................................................... sub open_fh { my ($self, $op, $path) = @_; open my $fh, $op, $path or $self->die("Couldn't open $path: $!"); return $fh; } sub set_encoding { my ($self, $fh, $encoding) = @_; if ( $encoding =~ /utf-?8/i ) { $encoding = ":encoding(UTF-8)"; } else { $encoding = ":encoding($encoding)"; } if ( $] < 5.008 ) { $self->aside("Your old perl doesn't have proper unicode support."); } else { binmode($fh, $encoding); } return $fh; } sub search_perlvar { my($self, $found_things, $pod) = @_; my $opt = $self->opt_v; if ( $opt !~ /^ (?: [\@\%\$]\S+ \| [A-Z]\w* ) $/x ) { CORE::die( "'$opt' does not look like a Perl variable\n" ); } DEBUG > 2 and print "Search: @$found_things\n"; my $perlvar = shift @$found_things; my $fh = $self->open_fh("<", $perlvar); if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ... $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 $_; my $enc; while (<$fh>) { $enc = $1 if /^=encoding\s+(\S+)/; last if /^=over 8/; } $fh = $self->set_encoding($fh, $enc) if $enc; # Look for our variable my $found = 0; my $inheader = 1; my $inlist = 0; while (<$fh>) { 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) { CORE::die( "No documentation for perl variable '$opt' found\n" ); } close $fh or $self->die( "Can't close $perlvar: $!" ); return; } #.......................................................................... # Check whether an item POD section contains any documentation text. The POD # section is passed as refernce to list of lines. # If there is no text, return true; otherwise false. sub item_has_no_text { for (@{$_[0]}) { next if /^=over\s/; next if /^=item\s/; next if /^X</; next if /^\s$/; return 0; } return 1; } sub search_perlop { my ($self,$found_things,$pod) = @_; $self->not_dynamic( 1 ); my $perlop = shift @$found_things; # XXX FIXME: getting filehandles should probably be done in a single place # especially since we need to support UTF8 or other encoding when dealing # with perlop, perlfunc, perlapi, perlfaq[1-9] my $fh = $self->open_fh('<', $perlop); my $thing = $self->opt_f; my @previous_lines; my $stop_line; my $wrap_into_over; my $push = 0; my $pod_candidate = []; while( my $line = <$fh> ) { $line =~ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); # A strategy is to capture the previous lines from =head or =item until we # get a match on X<$thing>. If the current line contains X<$thing>, then # we push "=over" (in case of =item), the previous lines, the current line # and keep pushing current line until we see a terminating POD keyworkd # (=head, =item, =over, corrsponding to the starting POD keyword). Then we # append =back (in case of =item). # # If this was =item, we are done. If the =item was empty (like two # consequtive =item-s documented at once) we continue gathering other # =item-s until we get some content. Then we are done. # # If this was a =head, we stash the POD section and do another search in # hope we will found =item section. (=item sections tends to be more # focused on =X<$thing> than =head sections.) If did not found any =item # section, we will return the last found =head section. if ( $line =~ m!X<+\s\Q$thing\E\s>+! ) { if ( @previous_lines ) { push @$pod_candidate, "=over 8\n\n" if $wrap_into_over; push @$pod_candidate, @previous_lines; @previous_lines = (); } push @$pod_candidate, $line; $push = 1; } elsif ( $push and $line =~ m/$stop_line/ ) { $push = 0; # X<tr> exists twice in perlop. Prefer =item location over =head # location. We assume =item is more specific. if ($wrap_into_over) { # However, the X<tr> =item section is empty (except of bunch of # X<> kewords) and documented in the next =item section. Thus # continue until the so far gathered text looks empty. if ($line =~ /^=item\s/ && item_has_no_text($pod_candidate)) { $push = 1; push @$pod_candidate, $line; # and continue appending following =item section } else { # We have an =item with a content. push @$pod_candidate, "\n\n=back\n"; # Replace pod with the candidate @$pod = @$pod_candidate; last; } } else { # Copy the candidate to pod push @$pod, @$pod_candidate; $pod_candidate = []; # And search for another occurance of the X<> reference with the # prospect it will be an =item. } } elsif ( $push ) { push @$pod_candidate, $line; } if ( !$push ) { # Gather a smallest block starting with "=head" or "=item" if ($line =~ /^=head([1234])\s/) { $stop_line = join('', 1..$1); $stop_line = qr/^=head[$stop_line]\s/; $wrap_into_over = 0; @previous_lines = (); } elsif ($line =~ /^=item\s/) { $stop_line = qr/^=(?:item\s\|back\b)/; $wrap_into_over = 1; @previous_lines = (); } push @previous_lines, $line; } } #end while # we overfilled by 1 line, so pop off final array element if we have any if ( scalar @$pod ) { DEBUG > 8 and print "PERLOP POD --->" . (join "", @$pod) . "<---\n"; } else { DEBUG > 4 and print "No pod from perlop\n"; } close $fh; return; } #.......................................................................... sub search_perlapi { my($self, $found_things, $pod) = @_; DEBUG > 2 and print "Search: @$found_things\n"; my $perlapi = shift @$found_things; my $fh = $self->open_fh('<', $perlapi); my $search_re = quotemeta($self->opt_a); DEBUG > 2 and print "Going to perlapi-scan for $search_re in $perlapi\n"; local $_; # Look for our function my $found = 0; my $inlist = 0; my @related; my $related_re; while (<$fh>) { /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); if ( m/^=item\s+$search_re\b/ ) { $found = 1; } elsif (@related > 1 and /^=item/) { $related_re \|\|= join "\|", @related; if (m/^=item\s+(?:$related_re)\b/) { $found = 1; } else { last; } } elsif (/^=item/) { last if $found > 1 and not $inlist; } elsif ($found and /^X<[^>]+>/) { push @related, m/X<([^>]+)>/g; } 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) { CORE::die( sprintf "No documentation for perl api function '%s' found\n", $self->opt_a ) ; } close $fh or $self->die( "Can't open $perlapi: $!" ); return; } #.......................................................................... sub search_perlfunc { my($self, $found_things, $pod) = @_; DEBUG > 2 and print "Search: @$found_things\n"; my $pfunc = shift @$found_things; my $fh = $self->open_fh("<", $pfunc); # "Funk is its own reward" # 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 $pfunc\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'); if ( $] < 5.008 ) { $self->aside("Your old perl doesn't really have proper unicode support."); } } # Skip introduction local $_; while (<$fh>) { /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); last if /^=head2 (?:$re\|Alphabetical Listing of Perl Functions)/; } # Look for our function my $found = 0; my $inlist = 0; my @perlops = qw(m q qq qr qx qw s tr y); my @related; my $related_re; while (<$fh>) { # "The Mothership Connection is here!" last if( grep{ $self->opt_f eq $_ }@perlops ); if ( /^=over/ and not $found ) { ++$inlist; } elsif ( /^=back/ and not $found and $inlist ) { --$inlist; } if ( m/^=item\s+$search_re\b/ and $inlist < 2 ) { $found = 1; } elsif (@related > 1 and /^=item/) { $related_re \|\|= join "\|", @related; if (m/^=item\s+(?:$related_re)\b/) { $found = 1; } else { last if $found > 1 and $inlist < 2; } } elsif (/^=item\|^=back/) { last if $found > 1 and $inlist < 2; } elsif ($found and /^X<[^>]+>/) { push @related, m/X<([^>]+)>/g; } next unless $found; if (/^=over/) { ++$inlist; } elsif (/^=back/) { --$inlist; } push @$pod, $_; ++$found if /^\w/; # found descriptive text } if( !@$pod ){ $self->search_perlop( $found_things, $pod ); } if (!@$pod) { CORE::die( sprintf "No documentation for perl function '%s' found\n", $self->opt_f ) ; } close $fh or $self->die( "Can't close $pfunc: $!" ); 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 $self->die( <<EOD ); Invalid regular expression '$search_key' given as -q pattern: $@ Did you mean \\Q$search_key ? EOD local $_; foreach my $file (@$found_things) { $self->die( "invalid file spec: $!" ) if $file =~ /[<>\|]/; my $fh = $self->open_fh("<", $file); while (<$fh>) { /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); 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($fh); } CORE::die("No documentation for perl FAQ keyword '$search_key' found\n") unless @$pod; if ( $self->opt_l ) { CORE::die((join "\n", keys %found_in) . "\n"); } return; } #.......................................................................... sub render_findings { # Return the filename to open my($self, $found_things) = @_; my $formatter_class = $self->{'formatter_class'} \|\| $self->die( "No formatter class set!?" ); my $formatter = $formatter_class->can('new') ? $formatter_class->new : $formatter_class ; if(! @$found_things) { $self->die( "Nothing found?!" ); # should have been caught before here } elsif(@$found_things > 1) { $self->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 : () ) }; $self->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 { $self->warn( "$formatter_class doesn't recognize the $switch switch.\n" ); } } } } $self->{'output_is_binary'} = $formatter->can('write_with_binmode') && $formatter->write_with_binmode; if( $self->{podnames} and exists $self->{podnames}{$file} and $formatter->can('name') ) { $formatter->name($self->{podnames}{$file}); } 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-suppressible warnings from the formatting! } eval { $formatter->parse_from_file( $file, $out_fh ) }; } $self->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 $self->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 { $self->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 $self->warn( "Odd, couldn't unlink $file: $!" ); } else { DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; } return; } #.......................................................................... sub after_rendering { my $self = $_[0]; $self->after_rendering_VMS if $self->is_vms; $self->after_rendering_MSWin32 if $self->is_mswin32; $self->after_rendering_Dos if $self->is_dos; $self->after_rendering_OS2 if $self->is_os2; return; } sub after_rendering_VMS { return } sub after_rendering_Dos { return } sub after_rendering_OS2 { return } sub after_rendering_MSWin32 { return } #.......................................................................... # : : : : : : : : : #.......................................................................... 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 $self->is_vms or $self->is_mswin32 or $self->is_dos or $self->is_os2 ) { # On a case-forgiving file system, or if case is important, # that is it, all we can do. $self->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 _ && lc($try) eq lc($path)) { return $try; } elsif (-f _) { $self->warn( "Ignored $try: unreadable or file/dir mismatch\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 $self->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 $self->die( "closedir $p_dirspec: $!" ); return "" unless $found; push @p, $cip; my $p_filespec = catfile(@p); return $p_filespec if -f $p_filespec and -r _; $self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _; } } return ""; } #.......................................................................... sub pagers_guessing { # TODO: This whole subroutine needs to be rewritten. It's semi-insane # right now. my $self = shift; my @pagers; push @pagers, $self->pagers; $self->{'pagers'} = \@pagers; if ($self->is_mswin32) { push @pagers, qw( more< less notepad ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } elsif ($self->is_vms) { push @pagers, qw( most more less type/page ); } elsif ($self->is_dos) { push @pagers, qw( less.exe more.com< ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } elsif ( $self->is_amigaos) { push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE ); unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER}; } else { if ($self->is_os2) { unshift @pagers, 'less', 'cmd /c more <'; } push @pagers, qw( more less pg view cat ); unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER}; } if ($self->is_cygwin) { if (($pagers[0] eq 'less') \|\| ($pagers[0] eq '/usr/bin/less')) { unshift @pagers, '/usr/bin/less -isrR'; unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } } if ( $self->opt_m ) { unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER} } else { unshift @pagers, "$ENV{MANPAGER} <" if $ENV{MANPAGER}; unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER}; } $self->aside("Pagers: ", (join ", ", @pagers)); 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(@found > 1) { $self->warn( "Perldoc is only really meant for reading one document at a time.\n" . "So these files are being ignored: " . join(' ', @found[1 .. $#found] ) . "\n" ) } return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers); } #.......................................................................... 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 ""; } my $path = $self->minus_f_nocase($dir,$file); if( length $path and ($self->opt_m ? $self->isprintable($path) : $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 isprintable { my($self, $file, $readit) = @_; my $size= 1024; my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc. return 1 if !$readit && $file =~ /\.(?:pl\|pm\|pod\|cmd\|com\|bat)\z/i; my $data; local($_); my $fh = $self->open_fh("<", $file); read $fh, $data, $size; close $fh; $size= length($data); $data =~ tr/\x09-\x0D\x20-\x7E//d; return length($data) <= $size$maxunprintfrac; } #.......................................................................... 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 ( $self->is_cygwin and -x $file and -f "$file.exe" ) { $self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D; return 0; } local($_); my $fh = $self->open_fh("<", $file); while (<$fh>) { if (/^=head/) { close($fh) or $self->die( "Can't close $file: $!" ); return 1; } } close($fh) or $self->die( "Can't close $file: $!" ); return 0; } #.......................................................................... sub maybe_extend_searchpath { my $self = shift; # Does this look like a module or extension directory? if (-f "Makefile.PL" \|\| -f "Build.PL") { push @{$self->{search_path} }, '.','lib'; # don't add if superuser if ($< && $> && -d "blib") { # don't be looking too hard now! push @{ $self->{search_path} }, 'blib'; $self->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 DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; my $fh = $self->open_fh(">", $outspec); 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; 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"); my $fh = $self->open_fh("<", $output); local $_; while (<$fh>) { print or $self->die( "Can't print to stdout: $!" ); } close $fh or $self->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 $self->is_vms; $output =~ s{/}{\\}g if $self->is_mswin32 \|\| $self->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. # if we are on an amiga convert unix path to an amiga one $output =~ s/^\/(.)\/(.)/$1:$2/ if $self->is_amigaos; foreach my $pager (@pagers) { $self->aside("About to try calling $pager $output\n"); if ($self->is_vms) { last if system("$pager $output") == 0; } elsif($self->is_amigaos) { 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 $self->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 $self->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 ( $self->is_vms and $ret = $self->check_file($dir,"$s.com")) or ( $self->is_os2 and $ret = $self->check_file($dir,"$s.cmd")) or ( ($self->is_mswin32 or $self->is_dos or $self->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 $self->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 $self->die( "Can't closedir $dir: $!" ); next unless @newdirs; # what a wicked map! @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->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) \|\| CORE::die "Can't close STDOUT: $!" } ~; # What for? to let the pager know that nothing more will come? $self->die( $@ ) if $@; $already_asserted = 1; return; } } #.......................................................................... sub tweak_found_pathnames { my($self, $found) = @_; if ($self->is_mswin32) { foreach (@$found) { s,/,\\,g } } foreach (@$found) { s,',\\',g } # RT 37347 return; } #.......................................................................... # : : : : : : : : : #.......................................................................... sub am_taint_checking { my $self = shift; $self->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; DEBUG and print "Attempting to drop privs...\n"; # Attempt to drop privs if we should be tainting and aren't if (!( $self->is_vms \|\| $self->is_mswin32 \|\| $self->is_dos \|\| $self->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: Mark Allen C<< <mallen@cpan.org> >> Past contributions from: brian d foy C<< <bdfoy@cpan.org> >> Adriano R. Ferreira C<< <ferreira@cpan.org> >>, Sean M. Burke C<< <sburke@cpan.org> >> =cut	65.27 KB	2022-02-14 23:51
📁 Simple	-	2025-02-27 15:06
📄 Simple.pm 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.42'; @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 head5 head6 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 STDERR "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 STDERR "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n"; print STDERR "# We are under a Unicode-safe Perl.\n"; } # The NO BREAK SPACE and SOFT HYHPEN are used in several submodules. if ($] ge 5.007_003) { # On sufficiently modern Perls we can handle any # character set $Pod::Simple::nbsp = chr utf8::unicode_to_native(0xA0); $Pod::Simple::shy = chr utf8::unicode_to_native(0xAD); } elsif (Pod::Simple::ASCII) { # Hard code ASCII early Perl $Pod::Simple::nbsp = "\xA0"; $Pod::Simple::shy = "\xAD"; } else { # EBCDIC on early Perl. We know what the values are for the code # pages supported then. $Pod::Simple::nbsp = "\x41"; $Pod::Simple::shy = "\xCA"; } # 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( '_output_is_for_JustPod', # For use only by Pod::Simple::JustPod, # If non-zero, don't expand Z<> E<> S<> L<>, # and count how many brackets in format codes '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 'keep_encoding_directive', # whether to emit =encoding '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 'expand_verbatim_tabs', # 0: preserve tabs in verbatim blocks # n: expand tabs to stops every n columns 'parse_characters', # Whether parser should expect chars rather than octets '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', # ... when a =cut line is seen 'pod_handler', # ... when a =pod line is seen 'whiteline_handler', # ... when a line with only whitespace is seen #Called like: # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler; # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler; # $pod_handler->($line, $self->{'line_count'}, $self) if $pod_handler; # $wl_handler->($line, $self->{'line_count'}, $self) if $wl_handler; 'parse_empty_lists', # whether to acknowledge empty =over/=back blocks 'raw_mode', # to report entire raw lines instead of Pod elements ); #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ sub any_errata_seen { # good for using as an exit() value... return shift->{'errors_seen'} \|\| 0; } sub errata_seen { return shift->{'all_errata'} \|\| {}; } # Returns the encoding only if it was recognized as being handled and set sub detected_encoding { return shift->{'detected_encoding'}; } sub encoding { my $this = shift; return $this->{'encoding'} unless @_; # GET. $this->_handle_encoding_line("=encoding $_[0]"); if ($this->{'_processed_encoding'}) { delete $this->{'_processed_encoding'}; if(! $this->{'encoding_command_statuses'} ) { DEBUG > 2 and print STDERR " CRAZY ERROR: encoding wasn't really handled?!\n"; } elsif( $this->{'encoding_command_statuses'}[-1] ) { $this->scream( "=encoding $_[0]", sprintf "Couldn't do %s: %s", $this->{'encoding_command_reqs' }[-1], $this->{'encoding_command_statuses'}[-1], ); } else { DEBUG > 2 and print STDERR " (encoding successfully handled.)\n"; } return $this->{'encoding'}; } else { return undef; } } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ # 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; my_qr = \&Pod::Simple::BlackBox::my_qr; } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 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 STDERR "# 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__ ); my $obj = bless { 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) }, 'accept_directives' => { %Known_directives }, 'accept_targets' => {}, }, $class; $obj->expand_verbatim_tabs(8); return $obj; } # 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 STDERR "Learning to accept \"=$d\" as directive of type $type\n"; } DEBUG > 6 and print STDERR "$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 STDERR "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 STDERR "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 STDERR "OK, won't accept \"$t\" as target.\n"; } return sort keys %{ $this->{'accept_targets'} } if wantarray; return; } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ # # And now codes (not targets or directives) # XXX Probably it is an error that the digit '9' is excluded from these re's. # Broken for early Perls on EBCDIC my $xml_name_re = my_qr('[^-.0-8:A-Z_a-z[:^ascii:]]', '9'); $xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ unless $xml_name_re; 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; # 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 =~ $xml_name_re # 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; # 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 =~ $xml_name_re # 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 STDERR "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 # supports \r, \n ,\r\n #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 STDERR "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 } my $at_eof = ! $lines[-1]; # keep track of the undef pop @lines if $at_eof; # silence warnings # be eol agnostic s/\r\n?/\n/g for @lines; # make sure there are only one line elements for parse_lines @lines = split(/(?<=\n)/, join('', @lines)); # push the undef back after popping it to set source_dead to true push @lines, undef if $at_eof; $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} ); } elsif($to =~ m/^>&(?:STDERR\|2)$/i) { $self->output_fh( STDERR{IO} ); } else { require Symbol; my $out_fh = Symbol::gensym(); DEBUG and print STDERR "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 STDERR "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n"; return; } push @{$self->{'all_errata'}{$_[0]}}, $_[1]; return $self->_complain_warn(@_) if $self->{'complain_stderr'}; return $self->_complain_errata(@_); } sub scream { # like whine, but not suppressible #my($self,$line,$complaint) = @_; my $self = shift(@_); ++$self->{'errors_seen'}; push @{$self->{'all_errata'}{$_[0]}}, $_[1]; 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 STDERR "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n"; } else { DEBUG > 9 and print STDERR "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 STDERR " 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 STDERR "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->{'_output_is_for_JustPod'} # Retain these as-is for pod output && $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 STDERR "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 STDERR "\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 STDERR " Considering children of this $treelet->[0] node...\n"; for($i = 2; $i < @$treelet; ++$i) { # iterate over children DEBUG > 3 and print STDERR " Considering child at $i ", pretty($treelet->[$i]), "\n"; if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') { DEBUG > 3 and print STDERR " 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 STDERR " Merging ", $i-1, ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n"; $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0]; DEBUG > 4 and print STDERR " 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 STDERR " 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 STDERR " +Enqueuing ", pretty( $treelet->[$i][1]{$attrname} ), " as an attribute value to tweak.\n"; } } } } } } DEBUG > 2 and print STDERR "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 STDERR "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 STDERR " 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 STDERR " 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 STDERR " Noting child $i : $treelet->[$i][0]<...>\n"; $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] }; if( DEBUG > 3 ) { if(!defined $is) { print STDERR " Code $was<> is UNKNOWN!\n"; } elsif($is eq $was) { DEBUG > 4 and print STDERR " Code $was<> stays the same.\n"; } else { print STDERR " 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 STDERR " 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 STDERR "End of _remap_sequences traversal.\n\n"; if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) { DEBUG and print STDERR "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 STDERR "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 STDERR "Extensor has good syntax.\n"; unless($new_letter =~ m/^[A-Z]$/s or $new_letter) { DEBUG > 2 and print STDERR " $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 STDERR " $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 STDERR " 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 STDERR "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 STDERR " Mapping '$new_letter' to known extension '$e'\n"; $canonical_form = $e; last; # first acceptable elementname wins! } else { DEBUG > 1 and print STDERR " 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 STDERR "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 STDERR "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). # ############# The "raw" attribute that is already there. # 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 STDERR "Ogling L node " . pretty($ell) . "\n"; # bitch if it's empty or is just '/' if (@{$ell} == 3 and $ell->[2] =~ m!\A\s/\s\z!) { $self->whine( $start_line, "L<> contains only '/'" ); $treelet->[$i] = 'L</>'; # just make it a text node next; # and move on } 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 } if( (! ref $ell->[2] && $ell->[2] =~ /\A\s/) \|\|(! ref $ell->[-1] && $ell->[-1] =~ /\s\z/) ) { $self->whine( $start_line, "L<> starts or ends with whitespace" ); } # 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]+[)]$}s) { # man sections # Hopefully neither too broad nor too restrictive a RE DEBUG > 1 and print STDERR "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 STDERR "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 STDERR "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 STDERR " 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 STDERR " 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 STDERR " 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 STDERR " FOUND a '\|' in it. Splitting into [$1] + [$2]\n"; if ($link_text[0] =~ m{[\|/]}) { $self->whine( $start_line, "alternative text '$link_text[0]' contains non-escaped \| or /" ); } 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 STDERR " 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 STDERR " 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 STDERR " 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 STDERR " Quotes removed: ", pretty(@section_name), "\n"; } else { DEBUG > 3 and print STDERR " 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; $ell->[1]{'~tolerated'} = 1; } # 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]; $ell->[1]{'~deprecated'} = 1; # That's support for the now-deprecated syntax. # 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]+[)]$}s ) { $ell->[1]{'type'} = 'man'; DEBUG > 3 and print STDERR "Considering this ($ell_content[0]) a man link.\n"; } else { $ell->[1]{'type'} = 'pod'; DEBUG > 3 and print STDERR "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 STDERR "L-section content: ", pretty($ell->[1]{'section'}), "\n"; } if( @ell_content ) { $ell->[1]{'to'} = Pod::Simple::LinkSection->new( ['', {}, @ell_content] ); DEBUG > 3 and print STDERR "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 STDERR "End of L-parsing for this node " . pretty($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 STDERR " 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 STDERR "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 STDERR "Ogling E<$content>\n"; # XXX E<>'s contents should* be a valid char in the scope of the current # =encoding directive. Defaults to iso-8859-1, I believe. Fix this in the # future sometime. $charnum = Pod::Escapes::e2charnum($content); DEBUG > 1 and print STDERR " Considering E<$content> with char ", defined($charnum) ? $charnum : "undef", ".\n"; if(!defined( $charnum )) { DEBUG > 1 and print STDERR "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 STDERR "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 STDERR " 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/$Pod::Simple::nbsp/g if $in_s; # 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 STDERR "\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 STDERR " _out to ", \$out, "\n"; $mutor->($parser) if $mutor; $parser->parse_string_document( $_[0] ); # use Data::Dumper; print STDERR 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 STDERR " _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 STDERR 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?	53.52 KB	2020-11-10 14:19
📄 Simple.pod =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 in L<perlpod>; the most common formatter is called C<perldoc>. Be sure to read L</ENCODING> if your Pod contains non-ASCII characters. 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>. But note that Pod::Simple doesn't understand and properly parse Perl itself, so if you have a file which contains a Perl program that has a multi-line quoted string which has lines that look like pod, Pod::Simple will treat them as pod. This can be avoided if the file makes these into indented here documents instead. 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> or C<STDERR>, 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. Returns false in cases where the document contains content, but does not make use of any Pod markup. =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->parse_characters( I<SOMEVALUE> ) >> The Pod parser normally expects to read octets and to convert those octets to characters based on the C<=encoding> declaration in the Pod source. Set this option to a true value to indicate that the Pod source is already a Perl character stream. This tells the parser to ignore any C<=encoding> command and to skip all the code paths involving decoding octets. =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 you're 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; }); =item C<< $parser->expand_verbatim_tabs( I<n> ) >> Default: 8 If after any stripping of indentation in verbatim blocks, there remain tabs, this method call indicates what to do with them. C<0> means leave them as tabs, any other number indicates that each tab is to be translated so as to have tab stops every C<n> columns. This is independent of other methods (except that it operates after any verbatim input stripping is done). Like the other methods, the input parameter is not checked for validity. C<undef> or containing non-digits has the same effect as 8. =back =head1 TERTIARY METHODS =over =item C<< $parser->abandon_output_fh() >>X<abandon_output_fh> Cancel output to the file handle. Any POD read by the C<$parser> is not effected. =item C<< $parser->abandon_output_string() >>X<abandon_output_string> Cancel output to the output string. Any POD read by the C<$parser> is not effected. =item C<< $parser->accept_code( @codes ) >>X<accept_code> Alias for L<< accept_codes >>. =item C<< $parser->accept_codes( @codes ) >>X<accept_codes> Allows C<$parser> to accept a list of L<perlpod/Formatting Codes>. This can be used to implement user-defined codes. =item C<< $parser->accept_directive_as_data( @directives ) >>X<accept_directive_as_data> Allows C<$parser> to accept a list of directives for data paragraphs. A directive is the label of a L<perlpod/Command Paragraph>. A data paragraph is one delimited by C<< =begin/=for/=end >> directives. This can be used to implement user-defined directives. =item C<< $parser->accept_directive_as_processed( @directives ) >>X<accept_directive_as_processed> Allows C<$parser> to accept a list of directives for processed paragraphs. A directive is the label of a L<perlpod/Command Paragraph>. A processed paragraph is also known as L<perlpod/Ordinary Paragraph>. This can be used to implement user-defined directives. =item C<< $parser->accept_directive_as_verbatim( @directives ) >>X<accept_directive_as_verbatim> Allows C<$parser> to accept a list of directives for L<perlpod/Verbatim Paragraph>. A directive is the label of a L<perlpod/Command Paragraph>. This can be used to implement user-defined directives. =item C<< $parser->accept_target( @targets ) >>X<accept_target> Alias for L<< accept_targets >>. =item C<< $parser->accept_target_as_text( @targets ) >>X<accept_target_as_text> Alias for L<< accept_targets_as_text >>. =item C<< $parser->accept_targets( @targets ) >>X<accept_targets> Accepts targets for C<< =begin/=for/=end >> sections of the POD. =item C<< $parser->accept_targets_as_text( @targets ) >>X<accept_targets_as_text> Accepts targets for C<< =begin/=for/=end >> sections that should be parsed as POD. For details, see L<< perlpodspec/About Data Paragraphs >>. =item C<< $parser->any_errata_seen() >>X<any_errata_seen> Used to check if any errata was seen. I<Example:> die "too many errors\n" if $parser->any_errata_seen(); =item C<< $parser->errata_seen() >>X<errata_seen> Returns a hash reference of all errata seen, both whines and screams. The hash reference's keys are the line number and the value is an array reference of the errors for that line. I<Example:> if ( $parser->any_errata_seen() ) { $logger->log( $parser->errata_seen() ); } =item C<< $parser->detected_encoding() >>X<detected_encoding> Return the encoding corresponding to C<< =encoding >>, but only if the encoding was recognized and handled. =item C<< $parser->encoding() >>X<encoding> Return encoding of the document, even if the encoding is not correctly handled. =item C<< $parser->parse_from_file( $source, $to ) >>X<parse_from_file> Parses from C<$source> file to C<$to> file. Similar to L<< Pod::Parser/parse_from_file >>. =item C<< $parser->scream( @error_messages ) >>X<scream> Log an error that can't be ignored. =item C<< $parser->unaccept_code( @codes ) >>X<unaccept_code> Alias for L<< unaccept_codes >>. =item C<< $parser->unaccept_codes( @codes ) >>X<unaccept_codes> Removes C<< @codes >> as valid codes for the parse. =item C<< $parser->unaccept_directive( @directives ) >>X<unaccept_directive> Alias for L<< unaccept_directives >>. =item C<< $parser->unaccept_directives( @directives ) >>X<unaccept_directives> Removes C<< @directives >> as valid directives for the parse. =item C<< $parser->unaccept_target( @targets ) >>X<unaccept_target> Alias for L<< unaccept_targets >>. =item C<< $parser->unaccept_targets( @targets ) >>X<unaccept_targets> Removes C<< @targets >> as valid targets for the parse. =item C<< $parser->version_report() >>X<version_report> Returns a string describing the version. =item C<< $parser->whine( @error_messages ) >>X<whine> Log an error unless C<< $parser->no_whining( TRUE ); >>. =back =head1 ENCODING The Pod::Simple parser expects to read B<octets>. The parser will decode the octets into Perl's internal character string representation using the value of the C<=encoding> declaration in the POD source. If the POD source does not include an C<=encoding> declaration, the parser will attempt to guess the encoding (selecting one of UTF-8 or CP 1252) by examining the first non-ASCII bytes and applying the heuristic described in L<perlpodspec>. (If the POD source contains only ASCII bytes, the encoding is assumed to be ASCII.) If you set the C<parse_characters> option to a true value the parser will expect characters rather than octets; will ignore any C<=encoding>; and will make no attempt to decode the input. =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<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Please use L<https://github.com/perl-pod/pod-simple/issues/new> to file a bug report. =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> =item * Karl Williamson C<khw@cpan.org> =back Documentation has been contributed by: =over =item * Gabor Szabo C<szabgab@gmail.com> =item * Shawn H Corey C<SHCOREY at cpan.org> =back =cut	14.79 KB	2020-11-10 14:19
📁 Text	-	2025-02-27 15:06
📄 Text.pm # Convert POD data to formatted text. # # 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. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl ############################################################################## # Modules and declarations ############################################################################## package Pod::Text; use 5.008; use strict; use warnings; use vars qw(@ISA @EXPORT %ESCAPES $VERSION); use Carp qw(carp croak); use Encode qw(encode); use Exporter (); use Pod::Simple (); @ISA = qw(Pod::Simple Exporter); # We have to export pod2text for backward compatibility. @EXPORT = qw(pod2text); $VERSION = '4.14'; # Ensure that $Pod::Simple::nbsp and $Pod::Simple::shy are available. Code # taken from Pod::Simple 3.32, but was only added in 3.30. my ($NBSP, $SHY); if ($Pod::Simple::VERSION ge 3.30) { $NBSP = $Pod::Simple::nbsp; $SHY = $Pod::Simple::shy; } else { $NBSP = chr utf8::unicode_to_native(0xA0); $SHY = chr utf8::unicode_to_native(0xAD); } ############################################################################## # 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} and not $$self{opt_errors}) { $$self{opt_errors} = 'stderr'; } delete $$self{opt_stderr}; # Validate the errors parameter and act on it. if (not defined $$self{opt_errors}) { $$self{opt_errors} = 'pod'; } if ($$self{opt_errors} eq 'stderr' \|\| $$self{opt_errors} eq 'die') { $self->no_errata_section (1); $self->complain_stderr (1); if ($$self{opt_errors} eq 'die') { $$self{complain_die} = 1; } } elsif ($$self{opt_errors} eq 'pod') { $self->no_errata_section (0); $self->complain_stderr (0); } elsif ($$self{opt_errors} eq 'none') { $self->no_errata_section (1); $self->no_whining (1); } else { croak (qq(Invalid errors setting: "$$self{errors}")); } delete $$self{errors}; # 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 (length ($$self{opt_quotes}) % 2 == 0) { my $length = length ($$self{opt_quotes}) / 2; $$self{LQUOTE} = substr ($$self{opt_quotes}, 0, $length); $$self{RQUOTE} = substr ($$self{opt_quotes}, $length); } 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})[ \t\n]+// \|\| 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. Be careful # not to use \s here, which in Unicode input may match non-breaking spaces # that we don't want to smash. if ($$self{opt_sentence}) { s/ +$//mg; s/\.\n/. \n/g; s/\n/ /g; s/ +/ /g; } else { s/[ \t\n]+/ /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) = @_; my $text = join ('', @text); if ($NBSP) { $text =~ s/$NBSP/ /g; } if ($SHY) { $text =~ s/$SHY//g; } unless ($$self{opt_utf8}) { my $encoding = $$self{encoding} \|\| ''; if ($encoding && $encoding ne $$self{ENCODING}) { $$self{ENCODING} = $encoding; eval { binmode ($$self{output_fh}, ":encoding($encoding)") }; } } if ($$self{ENCODE}) { print { $$self{output_fh} } encode ('UTF-8', $text); } else { 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, $attrs) = @_; if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) { $$self{CONTENTLESS} = 1; } else { delete $$self{CONTENTLESS}; } 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. $$self{ENCODING} = ''; # When UTF-8 output is set, check whether our output file handle already # has a PerlIO encoding layer set. If it does not, we'll need to encode # our output before printing it (handled in the output() sub). $$self{ENCODE} = 0; if ($$self{opt_utf8}) { $$self{ENCODE} = 1; eval { my @options = (output => 1, details => 1); my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1]; if ($flag && ($flag & PerlIO::F_UTF8 ())) { $$self{ENCODE} = 0; $$self{ENCODING} = 'UTF-8'; } }; } return ''; } # Handle the end of the document. The only thing we do is handle dying on POD # errors, since Pod::Parser currently doesn't. sub end_document { my ($self) = @_; if ($$self{complain_die} && $self->errors_seen) { croak ("POD document had syntax errors"); } } ############################################################################## # 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>"; } elsif ($$self{opt_nourls}) { 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 fiddles 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 (@_); } # Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so # ourself unless it was already set by the caller, since our documentation has # always said that this should work. sub parse_file { my ($self, $in) = @_; unless (defined $$self{output_fh}) { $self->output_fh (\STDOUT); } return $self->SUPER::parse_file ($in); } # Do the same for parse_lines, just to be polite. Pod::Simple's man page # implies that the caller is responsible for setting this, but I don't see any # reason not to set a default. sub parse_lines { my ($self, @lines) = @_; unless (defined $$self{output_fh}) { $self->output_fh (\STDOUT); } return $self->SUPER::parse_lines (@lines); } # Likewise for parse_string_document. sub parse_string_document { my ($self, $doc) = @_; unless (defined $$self{output_fh}) { $self->output_fh (\*STDOUT); } return $self->SUPER::parse_string_document ($doc); } ############################################################################## # Module return value and documentation ############################################################################## 1; __END__ =for stopwords alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8 nourls parsers =head1 NAME Pod::Text - Convert POD data to formatted text =head1 SYNOPSIS use Pod::Text; my $parser = Pod::Text->new (sentence => 1, 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 text. 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 errors How to report errors. C<die> says to throw an exception on any POD formatting error. C<stderr> says to report errors on standard error, but not to throw an exception. C<pod> says to include a POD ERRORS section in the resulting documentation summarizing the errors. C<none> ignores POD errors entirely, as much as possible. The default is C<pod>. =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 nourls Normally, LZ<><> formatting codes with a URL but anchor text are formatted to show both the anchor text and the URL. In other words: L<foo\|http://example.com/> is formatted as: foo <http://example.com/> This option, if set to a true value, suppresses the URL when anchor text is given, so this example would be formatted as just C<foo>. This can produce less cluttered output in cases where the URLs are not particularly important. =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. Otherwise, it is split in half, and the first half of the string is used as the left quote and the second is used 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 false. =item stderr Send error messages about invalid POD to standard error instead of appending a POD ERRORS section to the generated output. This is equivalent to setting C<errors> to C<stderr> if C<errors> is not already set. It is supported for backward compatibility. =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 should be properly declared unless it's US-ASCII. Pod::Simple will attempt to guess the encoding and may be successful if it's Latin-1 or UTF-8, but it will produce warnings. Use the C<=encoding> command to declare the encoding. See L<perlpod(1)> for more information. =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 naming the POD file to read from. By default, the output is sent to C<STDOUT>, but this can be changed with the output_fh() 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. As with parse_file(), parse_lines() and parse_string_document() default to sending their output to C<STDOUT> unless changed with the output_fh() method. Be aware that parse_lines() and parse_string_document() both expect raw bytes, not decoded characters. To put the output from any parse method into a string instead of a file handle, call the output_string() method instead of output_fh(). See L<Pod::Simple> for more specific details on the methods available to all derived parsers. =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 errors setting "%s" (F) The C<errors> parameter to the constructor was set to an unknown value. =item Invalid quote specification "%s" (F) The quote specification given (the C<quotes> option to the constructor) was invalid. A quote specification must be either one character long or an even number (greater than one) characters long. =item POD document had syntax errors (F) The POD document being formatted had syntax errors and the C<errors> option was set to C<die>. =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 AUTHOR Russ Allbery <rra@cpan.org>, 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-2002, 2004, 2006, 2008-2009, 2012-2016, 2018-2019 Russ Allbery <rra@cpan.org> 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<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)> The current version of this module is always available from its web site at L<https://www.eyrie.org/~eagle/software/podlators/>. It is also part of the Perl core distribution as of 5.6.0. =cut # Local Variables: # copyright-at-end-flag: t # End:	35.59 KB	2020-01-04 23:16
📄 Usage.pm ############################################################################# # Pod/Usage.pm -- print usage messages for the running script. # # Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. # Copyright (c) 2001-2016 by Marek Rouchal. # This file is part of "Pod-Usage". Pod-Usage is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. ############################################################################# package Pod::Usage; use strict; require 5.006; ## requires this Perl version or later use Carp; use Config; use Exporter; use File::Spec; our $VERSION = '2.01'; our @EXPORT = qw(&pod2usage); our @ISA; BEGIN { $Pod::Usage::Formatter \|\|= 'Pod::Text'; eval "require $Pod::Usage::Formatter"; die $@ if $@; @ISA = ( $Pod::Usage::Formatter ); } our $MAX_HEADING_LEVEL = 3; ##--------------------------------------------------------------------------- ##--------------------------------- ## 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 doesn't 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) { $_ = length($dirname) ? File::Spec->catfile($dirname, $basename) : $basename; last if (-e $_) && ($opts{'-input'} = $_); } } ## Now create a pod reader and constrain it to the desired sections. my $parser = Pod::Usage->new(USAGE_OPTIONS => \%opts); if ($opts{'-verbose'} == 0) { $parser->select('(?:SYNOPSIS\|USAGE)\s'); } elsif ($opts{'-verbose'} == 1) { my $opt_re = '(?i)' . '(?:OPTIONS\|ARGUMENTS)' . '(?:\s(?:AND\|\/)\s(?:OPTIONS\|ARGUMENTS))?'; $parser->select( '(?:SYNOPSIS\|USAGE)\s', $opt_re, "DESCRIPTION/$opt_re" ); } elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { $parser->select('.'); } elsif ($opts{'-verbose'} == 99) { my $sections = $opts{'-sections'}; $parser->select( (ref $sections) ? @$sections : $sections ); $opts{'-verbose'} = 1; } ## Check for perldoc my $progpath = $opts{'-perldoc'} ? $opts{'-perldoc'} : File::Spec->catfile($Config{scriptdirexp} \|\| $Config{scriptdir}, 'perldoc'); my $version = sprintf("%vd",$^V); if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) { $progpath .= $version; } $opts{'-noperldoc'} = 1 unless -e $progpath; ## Now translate the pod document and then exit with the desired status if ( !$opts{'-noperldoc'} and $opts{'-verbose'} >= 2 and !ref($opts{'-input'}) and $opts{'-output'} == \STDOUT ) { ## spit out the entire PODs. Might as well invoke perldoc print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); if(defined $opts{-input} && $opts{-input} =~ /^\s(\S.?)\s$/) { # the perldocs back to 5.005 should all have -F # without -F there are warnings in -T scripts my $f = $1; my @perldoc_cmd = ($progpath); if ($opts{'-perldocopt'}) { $opts{'-perldocopt'} =~ s/^\s+\|\s+$//g; push @perldoc_cmd, split(/\s+/, $opts{'-perldocopt'}); } push @perldoc_cmd, ('-F', $f); unshift @perldoc_cmd, $opts{'-perlcmd'} if $opts{'-perlcmd'}; system(@perldoc_cmd); # RT16091: fall back to more if perldoc failed if($?) { # RT131844: prefer PAGER env my $pager = $ENV{PAGER} \|\| $Config{pager}; if(defined($pager) && length($pager)) { my $cmd = $pager . ' ' . ($^O =~ /win/i ? qq("$f") : quotemeta($f)); system($cmd); } else { # the most humble fallback; should work (at least) on nix and Win system('more', $f); } } } else { croak "Unspecified input file or insecure argument.\n"; } } else { $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); } exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); } ##--------------------------------------------------------------------------- ##------------------------------- ## Method definitions begin here ##------------------------------- sub new { my $this = shift; my $class = ref($this) \|\| $this; my %params = @_; my $self = {%params}; bless $self, $class; if ($self->can('initialize')) { $self->initialize(); } else { # pass through options to Pod::Text my %opts; for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) { my $val = $params{USAGE_OPTIONS}{"-$_"}; $opts{$_} = $val if defined $val; } $self = $self->SUPER::new(%opts); %$self = (%$self, %params); } return $self; } # This subroutine was copied in whole-cloth from Pod::Select 1.60 in order to # allow the ejection of Pod::Select from the core without breaking Pod::Usage. # -- rjbs, 2013-03-18 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; } 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 = _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] } # Override Pod::Text->cmd_i to return just "arg", not "arg". # newer version based on Pod::Simple sub cmd_i { my $self = shift; # RT121489: highlighting should be there with Termcap return $self->SUPER::cmd_i(@_) if $self->isa('Pod::Text::Termcap'); 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 and Pod::Simple. 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/^\sSYNOPSIS\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]; # we have to get rid of the lower headings splice(@{$self->{USAGE_HEADINGS}},$idx+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 < $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-\|^[BCFILSZ]$/) { 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 aren't printing the entire manpage. if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { ## Change the title of the SYNOPSIS section to USAGE s/^=head1\s+SYNOPSIS\s$/=head1 USAGE/; ## Try to do some lowercasing instead of all-caps in headings s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; ## Use a colon to end all headings s/\s$/:/ unless (/:\s$/); $_ .= "\n"; } return $self->SUPER::preprocess_paragraph($_); } 1; # keep require happy __END__ =for stopwords pod2usage verboseness downcased MSWin32 Marek Rouchal Christiansen ATOOMIC rjbs McDougall =head1 NAME Pod::Usage - extracts POD documentation and shows usage information =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 ); pod2usage( -verbose => 2, -perlcmd => $path_to_perl, -perldoc => $path_to_perldoc, -perldocopt => $perldoc_options ); =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> I<string> =item C<-msg> I<string> The text of a message to print immediately prior to printing the program's usage message. =item C<-exitval> I<value> The desired exit status to pass to the B<exit()> function. This should be an integer, or else the string C<NOEXIT> to indicate that control should simply be returned without terminating the invoking process. =item C<-verbose> I<value> The desired level of "verboseness" to use when printing the usage message. If the value is 0, then only the "SYNOPSIS" and/or "USAGE" sections of the pod documentation are printed. If the value is 1, then the "SYNOPSIS" and/or "USAGE" sections, 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, using L<perldoc> if available; otherwise L<Pod::Text> is used for the formatting. For better readability, the all-capital headings are downcased, e.g. C<SYNOPSIS> =E<gt> C<Synopsis>. The special verbosity level 99 requires to also specify the -sections parameter; then these sections are extracted and printed. =item C<-sections> I<spec> There are two ways to specify the selection. Either a string (scalar) representing a selection regexp for sections to be printed when -verbose is set to 99, e.g. "NAME\|SYNOPSIS\|DESCRIPTION\|VERSION" With the above regexp all content following (and including) any of the given C<=head1> headings will be shown. It is possible to restrict the output to particular subsections only, e.g.: "DESCRIPTION/Algorithm" This will output only the C<=head2 Algorithm> heading and content within the C<=head1 DESCRIPTION> section. The regexp binding is stronger than the section separator, such that e.g.: "DESCRIPTION\|OPTIONS\|ENVIRONMENT/Caveats" will print any C<=head2 Caveats> section (only) within any of the three C<=head1> sections. Alternatively, an array reference of section specifications can be used: pod2usage(-verbose => 99, -sections => [ qw(DESCRIPTION DESCRIPTION/Introduction) ] ); This will print only the content of C<=head1 DESCRIPTION> and the C<=head2 Introduction> sections, but no other C<=head2>, and no other C<=head1> either. =item C<-output> I<handle> 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> I<handle> 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> I<string> 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>. This option suppresses the external call to L<perldoc> and uses the simple text formatter (L<Pod::Text>) to output the POD. =item C<-perlcmd> By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is specified. In case of special or unusual Perl installations, this option may be used to supply the path to a L<perl> executable which should run L<perldoc>. =item C<-perldoc> I<path-to-perldoc> By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is specified. In case L<perldoc> is not installed where the L<perl> interpreter thinks it is (see L<Config>), the -perldoc option may be used to supply the correct path to L<perldoc>. =item C<-perldocopt> I<string> By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is specified. This option may be used to supply options to L<perldoc>. The string may contain several, space-separated options. =back =head2 Formatting base class The default text formatter is L<Pod::Text>. The base class for Pod::Usage can be defined by pre-setting C<$Pod::Usage::Formatter> I<before> loading Pod::Usage, e.g.: BEGIN { $Pod::Usage::Formatter = 'Pod::Text::Termcap'; } use Pod::Usage qw(pod2usage); Pod::Usage uses L<Pod::Simple>'s _handle_element_end() method to implement the section selection, and in case of verbosity < 2 it down-cases the all-caps headings to first capital letter and rest lowercase, and adds a colon/newline at the end of the headings, for better readability. Same for verbosity = 99. =head2 Pass-through options The following options are passed through to the underlying text formatter. See the manual pages of these modules for more information. alt code indent loose margin quotes sentence stderr utf8 width =head1 DESCRIPTION B<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> does not 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 strict; use Pod::Usage; use Getopt::Long; ## Parse options my %opt; GetOptions(\%opt, "help\|?", "man", "flag1") \|\| pod2usage(2); pod2usage(1) if ($opt{help}); pod2usage(-exitval => 0, -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 strict; use Pod::Usage qw(pod2usage); use Getopt::Long qw(GetOptions); ## Parse options my %opt; GetOptions(\%opt, "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">. =head2 Scripts The Pod::Usage distribution comes with a script pod2usage which offers a command line interface to the functionality of Pod::Usage. See L<pod2usage>. =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 strict; use Getopt::Long qw(GetOptions); use Pod::Usage qw(pod2usage); 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 4 =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> is not 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. Or use L<FindBin> to locate the script: use FindBin; pod2usage(-input => $FindBin::Bin . "/" . $FindBin::Script); =head1 SUPPORT This module is managed in a GitHub repository, L<https://github.com/Dual-Life/Pod-Usage> Feel free to fork and contribute, or to clone and send patches! Please use L<https://github.com/Dual-Life/Pod-Usage/issues/new> to file a bug report. The previous ticketing system, L<https://rt.cpan.org/Dist/Display.html?Queue=Pod-Usage>, is deprecated for this package. More general questions or discussion about POD should be sent to the C<pod-people@perl.org> mail list. Send an empty email to C<pod-people-subscribe@perl.org> to subscribe. =head1 AUTHOR Marek Rouchal E<lt>marekr@cpan.orgE<gt> Nicolas R E<lt>nicolas@atoomic.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 LICENSE Pod::Usage (the distribution) is licensed under the same terms as Perl. =head1 ACKNOWLEDGMENTS Nicolas R (ATOOMIC) for setting up the Github repo and modernizing this package. rjbs for refactoring Pod::Usage to not use Pod::Parser any more. Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience with re-writing this manpage. =head1 SEE ALSO B<Pod::Usage> is now a standalone distribution, depending on L<Pod::Text> which in turn depends on L<Pod::Simple>. L<Pod::Perldoc>, L<Getopt::Long>, L<Pod::Find>, L<FindBin>, L<Pod::Text>, L<Pod::Text::Termcap>, L<Pod::Simple> =cut	30.27 KB	2020-10-13 23:14

Terminal