| Current File : /home/mmdealscpanel/yummmdeals.com/Pod.zip |
PK 07�Z����G_ G_ Html.pmnu �[��� package Pod::Html;
use strict;
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION = 1.2202;
@ISA = qw(Exporter);
@EXPORT = qw(pod2html htmlify);
@EXPORT_OK = qw(anchorify);
use Carp;
use Config;
use Cwd;
use File::Basename;
use File::Spec;
use File::Spec::Unix;
use Getopt::Long;
use Pod::Simple::Search;
use locale; # make \w work right in non-ASCII lands
=head1 NAME
Pod::Html - module to convert pod files to HTML
=head1 SYNOPSIS
use Pod::Html;
pod2html([options]);
=head1 DESCRIPTION
Converts files from pod format (see L<perlpod>) to HTML format. It
can automatically generate indexes and cross-references, and it keeps
a cache of things it knows how to cross-reference.
=head1 FUNCTIONS
=head2 pod2html
pod2html("pod2html",
"--podpath=lib:ext:pod:vms",
"--podroot=/usr/src/perl",
"--htmlroot=/perl/nmanual",
"--recurse",
"--infile=foo.pod",
"--outfile=/perl/nmanual/foo.html");
pod2html takes the following arguments:
=over 4
=item backlink
--backlink
Turns every C<head1> heading into a link back to the top of the page.
By default, no backlinks are generated.
=item cachedir
--cachedir=name
Creates the directory cache in the given directory.
=item css
--css=stylesheet
Specify the URL of a cascading style sheet. Also disables all HTML/CSS
C<style> attributes that are output by default (to avoid conflicts).
=item flush
--flush
Flushes the directory cache.
=item header
--header
--noheader
Creates header and footer blocks containing the text of the C<NAME>
section. By default, no headers are generated.
=item help
--help
Displays the usage message.
=item htmldir
--htmldir=name
Sets the directory to which all cross references in the resulting
html file will be relative. Not passing this causes all links to be
absolute since this is the value that tells Pod::Html the root of the
documentation tree.
Do not use this and --htmlroot in the same call to pod2html; they are
mutually exclusive.
=item htmlroot
--htmlroot=name
Sets the base URL for the HTML files. When cross-references are made,
the HTML root is prepended to the URL.
Do not use this if relative links are desired: use --htmldir instead.
Do not pass both this and --htmldir to pod2html; they are mutually
exclusive.
=item index
--index
--noindex
Generate an index at the top of the HTML file. This is the default
behaviour.
=item infile
--infile=name
Specify the pod file to convert. Input is taken from STDIN if no
infile is specified.
=item outfile
--outfile=name
Specify the HTML file to create. Output goes to STDOUT if no outfile
is specified.
=item poderrors
--poderrors
--nopoderrors
Include a "POD ERRORS" section in the outfile if there were any POD
errors in the infile. This section is included by default.
=item podpath
--podpath=name:...:name
Specify which subdirectories of the podroot contain pod files whose
HTML converted forms can be linked to in cross references.
=item podroot
--podroot=name
Specify the base directory for finding library pods. Default is the
current working directory.
=item quiet
--quiet
--noquiet
Don't display I<mostly harmless> warning messages. These messages
will be displayed by default. But this is not the same as C<verbose>
mode.
=item recurse
--recurse
--norecurse
Recurse into subdirectories specified in podpath (default behaviour).
=item title
--title=title
Specify the title of the resulting HTML file.
=item verbose
--verbose
--noverbose
Display progress messages. By default, they won't be displayed.
=back
=head2 htmlify
htmlify($heading);
Converts a pod section specification to a suitable section specification
for HTML. Note that we keep spaces and special characters except
C<", ?> (Netscape problem) and the hyphen (writer's problem...).
=head2 anchorify
anchorify(@heading);
Similar to C<htmlify()>, but turns non-alphanumerics into underscores. Note
that C<anchorify()> is not exported by default.
=head1 ENVIRONMENT
Uses C<$Config{pod2html}> to setup default options.
=head1 AUTHOR
Marc Green, E<lt>marcgreen@cpan.orgE<gt>.
Original version by Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
=head1 SEE ALSO
L<perlpod>
=head1 COPYRIGHT
This program is distributed under the Artistic License.
=cut
my $Cachedir;
my $Dircache;
my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
my($Podfile, @Podpath, $Podroot);
my $Poderrors;
my $Css;
my $Recurse;
my $Quiet;
my $Verbose;
my $Doindex;
my $Backlink;
my($Title, $Header);
my %Pages = (); # associative array used to find the location
# of pages referenced by L<> links.
my $Curdir = File::Spec->curdir;
init_globals();
sub init_globals {
$Cachedir = "."; # The directory to which directory caches
# will be written.
$Dircache = "pod2htmd.tmp";
$Htmlroot = "/"; # http-server base directory from which all
# relative paths in $podpath stem.
$Htmldir = ""; # The directory to which the html pages
# will (eventually) be written.
$Htmlfile = ""; # write to stdout by default
$Htmlfileurl = ""; # The url that other files would use to
# refer to this file. This is only used
# to make relative urls that point to
# other files.
$Poderrors = 1;
$Podfile = ""; # read from stdin by default
@Podpath = (); # list of directories containing library pods.
$Podroot = $Curdir; # filesystem base directory from which all
# relative paths in $podpath stem.
$Css = ''; # Cascading style sheet
$Recurse = 1; # recurse on subdirectories in $podpath.
$Quiet = 0; # not quiet by default
$Verbose = 0; # not verbose by default
$Doindex = 1; # non-zero if we should generate an index
$Backlink = 0; # no backlinks added by default
$Header = 0; # produce block header/footer
$Title = ''; # title to give the pod(s)
}
sub pod2html {
local(@ARGV) = @_;
local $_;
init_globals();
parse_command_line();
# prevent '//' in urls
$Htmlroot = "" if $Htmlroot eq "/";
$Htmldir =~ s#/\z##;
if ( $Htmlroot eq ''
&& defined( $Htmldir )
&& $Htmldir ne ''
&& substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
) {
# Set the 'base' url for this file, so that we can use it
# as the location from which to calculate relative links
# to other files. If this is '', then absolute links will
# be used throughout.
#$Htmlfileurl = "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
# Is the above not just "$Htmlfileurl = $Htmlfile"?
$Htmlfileurl = Pod::Html::_unixify($Htmlfile);
}
# load or generate/cache %Pages
unless (get_cache($Dircache, \@Podpath, $Podroot, $Recurse)) {
# generate %Pages
my $pwd = getcwd();
chdir($Podroot) ||
die "$0: error changing to directory $Podroot: $!\n";
# find all pod modules/pages in podpath, store in %Pages
# - callback used to remove Podroot and extension from each file
# - laborious to allow '.' in dirnames (e.g., /usr/share/perl/5.14.1)
Pod::Simple::Search->new->inc(0)->verbose($Verbose)->laborious(1)
->callback(\&_save_page)->recurse($Recurse)->survey(@Podpath);
chdir($pwd) || die "$0: error changing to directory $pwd: $!\n";
# cache the directory list for later use
warn "caching directories for later use\n" if $Verbose;
open my $cache, '>', $Dircache
or die "$0: error open $Dircache for writing: $!\n";
print $cache join(":", @Podpath) . "\n$Podroot\n";
my $_updirs_only = ($Podroot =~ /\.\./) && !($Podroot =~ /[^\.\\\/]/);
foreach my $key (keys %Pages) {
if($_updirs_only) {
my $_dirlevel = $Podroot;
while($_dirlevel =~ /\.\./) {
$_dirlevel =~ s/\.\.//;
# Assume $Pages{$key} has '/' separators (html dir separators).
$Pages{$key} =~ s/^[\w\s\-\.]+\///;
}
}
print $cache "$key $Pages{$key}\n";
}
close $cache or die "error closing $Dircache: $!";
}
# set options for the parser
my $parser = Pod::Simple::XHTML::LocalPodLinks->new();
$parser->codes_in_verbatim(0);
$parser->anchor_items(1); # the old Pod::Html always did
$parser->backlink($Backlink); # linkify =head1 directives
$parser->htmldir($Htmldir);
$parser->htmlfileurl($Htmlfileurl);
$parser->htmlroot($Htmlroot);
$parser->index($Doindex);
$parser->no_errata_section(!$Poderrors); # note the inverse
$parser->output_string(\my $output); # written to file later
$parser->pages(\%Pages);
$parser->quiet($Quiet);
$parser->verbose($Verbose);
# XXX: implement default title generator in pod::simple::xhtml
# copy the way the old Pod::Html did it
$Title = html_escape($Title);
# We need to add this ourselves because we use our own header, not
# ::XHTML's header. We need to set $parser->backlink to linkify
# the =head1 directives
my $bodyid = $Backlink ? ' id="_podtop_"' : '';
my $csslink = '';
my $tdstyle = ' style="background-color: #cccccc; color: #000"';
if ($Css) {
$csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
$csslink =~ s,\\,/,g;
$csslink =~ s,(/.):,$1|,;
$tdstyle= '';
}
# header/footer block
my $block = $Header ? <<END_OF_BLOCK : '';
<table border="0" width="100%" cellspacing="0" cellpadding="3">
<tr><td class="_podblock_"$tdstyle valign="middle">
<big><strong><span class="_podblock_"> $Title</span></strong></big>
</td></tr>
</table>
END_OF_BLOCK
# create own header/footer because of --header
$parser->html_header(<<"HTMLHEAD");
<?xml version="1.0" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>$Title</title>$csslink
<meta http-equiv="content-type" content="text/html; charset=utf-8" />
<link rev="made" href="mailto:$Config{perladmin}" />
</head>
<body$bodyid>
$block
HTMLHEAD
$parser->html_footer(<<"HTMLFOOT");
$block
</body>
</html>
HTMLFOOT
my $input;
unless (@ARGV && $ARGV[0]) {
if ($Podfile and $Podfile ne '-') {
$input = $Podfile;
} else {
$input = '-'; # XXX: make a test case for this
}
} else {
$Podfile = $ARGV[0];
$input = *ARGV;
}
warn "Converting input file $Podfile\n" if $Verbose;
$parser->parse_file($input);
# Write output to file
$Htmlfile = "-" unless $Htmlfile; # stdout
my $fhout;
if($Htmlfile and $Htmlfile ne '-') {
open $fhout, ">", $Htmlfile
or die "$0: cannot open $Htmlfile file for output: $!\n";
} else {
open $fhout, ">-";
}
binmode $fhout, ":utf8";
print $fhout $output;
close $fhout or die "Failed to close $Htmlfile: $!";
chmod 0644, $Htmlfile unless $Htmlfile eq '-';
}
##############################################################################
sub usage {
my $podfile = shift;
warn "$0: $podfile: @_\n" if @_;
die <<END_OF_USAGE;
Usage: $0 --help --htmldir=<name> --htmlroot=<URL>
--infile=<name> --outfile=<name>
--podpath=<name>:...:<name> --podroot=<name>
--cachedir=<name> --flush --recurse --norecurse
--quiet --noquiet --verbose --noverbose
--index --noindex --backlink --nobacklink
--header --noheader --poderrors --nopoderrors
--css=<URL> --title=<name>
--[no]backlink - turn =head1 directives into links pointing to the top of
the page (off by default).
--cachedir - directory for the directory cache files.
--css - stylesheet URL
--flush - flushes the directory cache.
--[no]header - produce block header/footer (default is no headers).
--help - prints this message.
--htmldir - directory for resulting HTML files.
--htmlroot - http-server base directory from which all relative paths
in podpath stem (default is /).
--[no]index - generate an index at the top of the resulting html
(default behaviour).
--infile - filename for the pod to convert (input taken from stdin
by default).
--outfile - filename for the resulting html file (output sent to
stdout by default).
--[no]poderrors - include a POD ERRORS section in the output if there were
any POD errors in the input (default behavior).
--podpath - colon-separated list of directories containing library
pods (empty by default).
--podroot - filesystem base directory from which all relative paths
in podpath stem (default is .).
--[no]quiet - suppress some benign warning messages (default is off).
--[no]recurse - recurse on those subdirectories listed in podpath
(default behaviour).
--title - title that will appear in resulting html file.
--[no]verbose - self-explanatory (off by default).
END_OF_USAGE
}
sub parse_command_line {
my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,
$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,
$opt_outfile,$opt_poderrors,$opt_podpath,$opt_podroot,
$opt_quiet,$opt_recurse,$opt_title,$opt_verbose);
unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
my $result = GetOptions(
'backlink!' => \$opt_backlink,
'cachedir=s' => \$opt_cachedir,
'css=s' => \$opt_css,
'flush' => \$opt_flush,
'help' => \$opt_help,
'header!' => \$opt_header,
'htmldir=s' => \$opt_htmldir,
'htmlroot=s' => \$opt_htmlroot,
'index!' => \$opt_index,
'infile=s' => \$opt_infile,
'outfile=s' => \$opt_outfile,
'poderrors!' => \$opt_poderrors,
'podpath=s' => \$opt_podpath,
'podroot=s' => \$opt_podroot,
'quiet!' => \$opt_quiet,
'recurse!' => \$opt_recurse,
'title=s' => \$opt_title,
'verbose!' => \$opt_verbose,
);
usage("-", "invalid parameters") if not $result;
usage("-") if defined $opt_help; # see if the user asked for help
$opt_help = ""; # just to make -w shut-up.
@Podpath = split(":", $opt_podpath) if defined $opt_podpath;
$Backlink = $opt_backlink if defined $opt_backlink;
$Cachedir = _unixify($opt_cachedir) if defined $opt_cachedir;
$Css = $opt_css if defined $opt_css;
$Header = $opt_header if defined $opt_header;
$Htmldir = _unixify($opt_htmldir) if defined $opt_htmldir;
$Htmlroot = _unixify($opt_htmlroot) if defined $opt_htmlroot;
$Doindex = $opt_index if defined $opt_index;
$Podfile = _unixify($opt_infile) if defined $opt_infile;
$Htmlfile = _unixify($opt_outfile) if defined $opt_outfile;
$Poderrors = $opt_poderrors if defined $opt_poderrors;
$Podroot = _unixify($opt_podroot) if defined $opt_podroot;
$Quiet = $opt_quiet if defined $opt_quiet;
$Recurse = $opt_recurse if defined $opt_recurse;
$Title = $opt_title if defined $opt_title;
$Verbose = $opt_verbose if defined $opt_verbose;
warn "Flushing directory caches\n"
if $opt_verbose && defined $opt_flush;
$Dircache = "$Cachedir/pod2htmd.tmp";
if (defined $opt_flush) {
1 while unlink($Dircache);
}
}
my $Saved_Cache_Key;
sub get_cache {
my($dircache, $podpath, $podroot, $recurse) = @_;
my @cache_key_args = @_;
# A first-level cache:
# Don't bother reading the cache files if they still apply
# and haven't changed since we last read them.
my $this_cache_key = cache_key(@cache_key_args);
return 1 if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
$Saved_Cache_Key = $this_cache_key;
# load the cache of %Pages if possible. $tests will be
# non-zero if successful.
my $tests = 0;
if (-f $dircache) {
warn "scanning for directory cache\n" if $Verbose;
$tests = load_cache($dircache, $podpath, $podroot);
}
return $tests;
}
sub cache_key {
my($dircache, $podpath, $podroot, $recurse) = @_;
return join('!',$dircache,$recurse,@$podpath,$podroot,stat($dircache));
}
#
# load_cache - tries to find if the cache stored in $dircache is a valid
# cache of %Pages. if so, it loads them and returns a non-zero value.
#
sub load_cache {
my($dircache, $podpath, $podroot) = @_;
my $tests = 0;
local $_;
warn "scanning for directory cache\n" if $Verbose;
open(my $cachefh, '<', $dircache) ||
die "$0: error opening $dircache for reading: $!\n";
$/ = "\n";
# is it the same podpath?
$_ = <$cachefh>;
chomp($_);
$tests++ if (join(":", @$podpath) eq $_);
# is it the same podroot?
$_ = <$cachefh>;
chomp($_);
$tests++ if ($podroot eq $_);
# load the cache if its good
if ($tests != 2) {
close($cachefh);
return 0;
}
warn "loading directory cache\n" if $Verbose;
while (<$cachefh>) {
/(.*?) (.*)$/;
$Pages{$1} = $2;
}
close($cachefh);
return 1;
}
#
# html_escape: make text safe for HTML
#
sub html_escape {
my $rest = $_[0];
$rest =~ s/&/&/g;
$rest =~ s/</</g;
$rest =~ s/>/>/g;
$rest =~ s/"/"/g;
# ' is only in XHTML, not HTML4. Be conservative
#$rest =~ s/'/'/g;
return $rest;
}
#
# htmlify - converts a pod section specification to a suitable section
# specification for HTML. Note that we keep spaces and special characters
# except ", ? (Netscape problem) and the hyphen (writer's problem...).
#
sub htmlify {
my( $heading) = @_;
$heading =~ s/(\s+)/ /g;
$heading =~ s/\s+\Z//;
$heading =~ s/\A\s+//;
# The hyphen is a disgrace to the English language.
# $heading =~ s/[-"?]//g;
$heading =~ s/["?]//g;
$heading = lc( $heading );
return $heading;
}
#
# similar to htmlify, but turns non-alphanumerics into underscores
#
sub anchorify {
my ($anchor) = @_;
$anchor = htmlify($anchor);
$anchor =~ s/\W/_/g;
return $anchor;
}
#
# store POD files in %Pages
#
sub _save_page {
my ($modspec, $modname) = @_;
# Remove Podroot from path
$modspec = $Podroot eq File::Spec->curdir
? File::Spec->abs2rel($modspec)
: File::Spec->abs2rel($modspec,
File::Spec->canonpath($Podroot));
# Convert path to unix style path
$modspec = Pod::Html::_unixify($modspec);
my ($file, $dir) = fileparse($modspec, qr/\.[^.]*/); # strip .ext
$Pages{$modname} = $dir.$file;
}
sub _unixify {
my $full_path = shift;
return '' unless $full_path;
return $full_path if $full_path eq '/';
my ($vol, $dirs, $file) = File::Spec->splitpath($full_path);
my @dirs = $dirs eq File::Spec->curdir()
? (File::Spec::Unix->curdir())
: File::Spec->splitdir($dirs);
if (defined($vol) && $vol) {
$vol =~ s/:$// if $^O eq 'VMS';
$vol = uc $vol if $^O eq 'MSWin32';
if( $dirs[0] ) {
unshift @dirs, $vol;
}
else {
$dirs[0] = $vol;
}
}
unshift @dirs, '' if File::Spec->file_name_is_absolute($full_path);
return $file unless scalar(@dirs);
$full_path = File::Spec::Unix->catfile(File::Spec::Unix->catdir(@dirs),
$file);
$full_path =~ s|^\/|| if $^O eq 'MSWin32'; # C:/foo works, /C:/foo doesn't
$full_path =~ s/\^\././g if $^O eq 'VMS'; # unescape dots
return $full_path;
}
package Pod::Simple::XHTML::LocalPodLinks;
use strict;
use warnings;
use parent 'Pod::Simple::XHTML';
use File::Spec;
use File::Spec::Unix;
__PACKAGE__->_accessorize(
'htmldir',
'htmlfileurl',
'htmlroot',
'pages', # Page name => relative/path/to/page from root POD dir
'quiet',
'verbose',
);
sub resolve_pod_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to || defined $section;
if (defined $section) {
$section = '#' . $self->idify($section, 1);
return $section unless defined $to;
} else {
$section = '';
}
my $path; # path to $to according to %Pages
unless (exists $self->pages->{$to}) {
# Try to find a POD that ends with $to and use that.
# e.g., given L<XHTML>, if there is no $Podpath/XHTML in %Pages,
# look for $Podpath/*/XHTML in %Pages, with * being any path,
# as a substitute (e.g., $Podpath/Pod/Simple/XHTML)
my @matches;
foreach my $modname (keys %{$self->pages}) {
push @matches, $modname if $modname =~ /::\Q$to\E\z/;
}
if ($#matches == -1) {
warn "Cannot find \"$to\" in podpath: " .
"cannot find suitable replacement path, cannot resolve link\n"
unless $self->quiet;
return '';
} elsif ($#matches == 0) {
warn "Cannot find \"$to\" in podpath: " .
"using $matches[0] as replacement path to $to\n"
unless $self->quiet;
$path = $self->pages->{$matches[0]};
} else {
warn "Cannot find \"$to\" in podpath: " .
"more than one possible replacement path to $to, " .
"using $matches[-1]\n" unless $self->quiet;
# Use [-1] so newer (higher numbered) perl PODs are used
$path = $self->pages->{$matches[-1]};
}
} else {
$path = $self->pages->{$to};
}
my $url = File::Spec::Unix->catfile(Pod::Html::_unixify($self->htmlroot),
$path);
if ($self->htmlfileurl ne '') {
# then $self->htmlroot eq '' (by definition of htmlfileurl) so
# $self->htmldir needs to be prepended to link to get the absolute path
# that will be relativized
$url = relativize_url(
File::Spec::Unix->catdir(Pod::Html::_unixify($self->htmldir), $url),
$self->htmlfileurl # already unixified
);
}
return $url . ".html$section";
}
#
# relativize_url - convert an absolute URL to one relative to a base URL.
# Assumes both end in a filename.
#
sub relativize_url {
my ($dest, $source) = @_;
# Remove each file from its path
my ($dest_volume, $dest_directory, $dest_file) =
File::Spec::Unix->splitpath( $dest );
$dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' );
my ($source_volume, $source_directory, $source_file) =
File::Spec::Unix->splitpath( $source );
$source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' );
my $rel_path = '';
if ($dest ne '') {
$rel_path = File::Spec::Unix->abs2rel( $dest, $source );
}
if ($rel_path ne '' && substr( $rel_path, -1 ) ne '/') {
$rel_path .= "/$dest_file";
} else {
$rel_path .= "$dest_file";
}
return $rel_path;
}
1;
PK 07�Z�U� 8 8 Functions.pmnu �[��� package Pod::Functions;
use strict;
=head1 NAME
Pod::Functions - Group Perl's functions a la perlfunc.pod
=head1 SYNOPSIS
use Pod::Functions;
my @misc_ops = @{ $Kinds{ 'Misc' } };
my $misc_dsc = $Type_Description{ 'Misc' };
or
perl /path/to/lib/Pod/Functions.pm
This will print a grouped list of Perl's functions, like the
L<perlfunc/"Perl Functions by Category"> section.
=head1 DESCRIPTION
It exports the following variables:
=over 4
=item %Kinds
This holds a hash-of-lists. Each list contains the functions in the category
the key denotes.
=item %Type
In this hash each key represents a function and the value is the category.
The category can be a comma separated list.
=item %Flavor
In this hash each key represents a function and the value is a short
description of that function.
=item %Type_Description
In this hash each key represents a category of functions and the value is
a short description of that category.
=item @Type_Order
This list of categories is used to produce the same order as the
L<perlfunc/"Perl Functions by Category"> section.
=back
=cut
our $VERSION = '1.11';
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order);
foreach (
[String => 'Functions for SCALARs or strings'],
[Regexp => 'Regular expressions and pattern matching'],
[Math => 'Numeric functions'],
[ARRAY => 'Functions for real @ARRAYs'],
[LIST => 'Functions for list data'],
[HASH => 'Functions for real %HASHes'],
['I/O' => 'Input and output functions'],
[Binary => 'Functions for fixed-length data or records'],
[File => 'Functions for filehandles, files, or directories'],
[Flow => 'Keywords related to the control flow of your Perl program'],
[Namespace => 'Keywords related to scoping'],
[Misc => 'Miscellaneous functions'],
[Process => 'Functions for processes and process groups'],
[Modules => 'Keywords related to Perl modules'],
[Objects => 'Keywords related to classes and object-orientation'],
[Socket => 'Low-level socket functions'],
[SysV => 'System V interprocess communication functions'],
[User => 'Fetching user and group info'],
[Network => 'Fetching network info'],
[Time => 'Time-related functions'],
) {
push @Type_Order, $_->[0];
$Type_Description{$_->[0]} = $_->[1];
};
while (<DATA>) {
chomp;
s/^#.*//;
next unless $_;
my($name, @data) = split "\t", $_;
$Flavor{$name} = pop @data;
$Type{$name} = join ',', @data;
for my $t (@data) {
push @{$Kinds{$t}}, $name;
}
}
close DATA;
my( $typedesc, $list );
unless (caller) {
foreach my $type ( @Type_Order ) {
$list = join(", ", sort @{$Kinds{$type}});
$typedesc = $Type_Description{$type} . ":";
write;
}
}
format =
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$typedesc
~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$typedesc
~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$list
.
1;
__DATA__
-X File a file test (-r, -x, etc)
abs Math absolute value function
accept Socket accept an incoming socket connect
alarm Process schedule a SIGALRM
atan2 Math arctangent of Y/X in the range -PI to PI
bind Socket binds an address to a socket
binmode I/O prepare binary files for I/O
bless Objects create an object
break Flow break out of a C<given> block
caller Flow Namespace get context of the current subroutine call
chdir File change your current working directory
chmod File changes the permissions on a list of files
chomp String remove a trailing record separator from a string
chop String remove the last character from a string
chown File change the ownership on a list of files
chr String get character this number represents
chroot File make directory new root for path lookups
close I/O close file (or pipe or socket) handle
closedir I/O close directory handle
connect Socket connect to a remote socket
continue Flow optional trailing block in a while or foreach
cos Math cosine function
crypt String one-way passwd-style encryption
dbmclose I/O Objects breaks binding on a tied dbm file
dbmopen I/O Objects create binding on a tied dbm file
defined Misc test whether a value, variable, or function is defined
delete HASH deletes a value from a hash
die Flow I/O raise an exception or bail out
do Flow Modules turn a BLOCK into a TERM
dump Flow create an immediate core dump
each ARRAY HASH retrieve the next key/value pair from a hash
endgrent User be done using group file
endhostent User be done using hosts file
endnetent User be done using networks file
endprotoent Network be done using protocols file
endpwent User be done using passwd file
endservent Network be done using services file
eof I/O test a filehandle for its end
eval Flow catch exceptions or compile and run code
evalbytes Flow similar to string eval, but intend to parse a bytestream
exec Process abandon this program to run another
exists HASH test whether a hash key is present
exit Flow terminate this program
exp Math raise I<e> to a power
fc String return casefolded version of a string
fcntl File file control system call
__FILE__ Flow the name of the current source file
fileno I/O return file descriptor from filehandle
flock I/O lock an entire file with an advisory lock
fork Process create a new process just like this one
format I/O declare a picture format with use by the write() function
formline Misc internal function used for formats
getc I/O get the next character from the filehandle
getgrent User get next group record
getgrgid User get group record given group user ID
getgrnam User get group record given group name
gethostbyaddr Network get host record given its address
gethostbyname Network get host record given name
gethostent Network get next hosts record
getlogin User return who logged in at this tty
getnetbyaddr Network get network record given its address
getnetbyname Network get networks record given name
getnetent Network get next networks record
getpeername Socket find the other end of a socket connection
getpgrp Process get process group
getppid Process get parent process ID
getpriority Process get current nice value
getprotobyname Network get protocol record given name
getprotobynumber Network get protocol record numeric protocol
getprotoent Network get next protocols record
getpwent User get next passwd record
getpwnam User get passwd record given user login name
getpwuid User get passwd record given user ID
getservbyname Network get services record given its name
getservbyport Network get services record given numeric port
getservent Network get next services record
getsockname Socket retrieve the sockaddr for a given socket
getsockopt Socket get socket options on a given socket
glob File expand filenames using wildcards
gmtime Time convert UNIX time into record or string using Greenwich time
goto Flow create spaghetti code
grep LIST locate elements in a list test true against a given criterion
hex Math String convert a hexadecimal string to a number
import Modules Namespace patch a module's namespace into your own
index String find a substring within a string
int Math get the integer portion of a number
ioctl File system-dependent device control system call
join LIST join a list into a string using a separator
keys ARRAY HASH retrieve list of indices from a hash
kill Process send a signal to a process or process group
last Flow exit a block prematurely
lc String return lower-case version of a string
lcfirst String return a string with just the next letter in lower case
length String return the number of characters in a string
__LINE__ Flow the current source line number
link File create a hard link in the filesystem
listen Socket register your socket as a server
local Namespace create a temporary value for a global variable (dynamic scoping)
localtime Time convert UNIX time into record or string using local time
lock Misc get a thread lock on a variable, subroutine, or method
log Math retrieve the natural logarithm for a number
lstat File stat a symbolic link
m// Regexp match a string with a regular expression pattern
map LIST apply a change to a list to get back a new list with the changes
mkdir File create a directory
msgctl SysV SysV IPC message control operations
msgget SysV get SysV IPC message queue
msgrcv SysV receive a SysV IPC message from a message queue
msgsnd SysV send a SysV IPC message to a message queue
my Namespace declare and assign a local variable (lexical scoping)
next Flow iterate a block prematurely
no Modules unimport some module symbols or semantics at compile time
oct Math String convert a string to an octal number
open File open a file, pipe, or descriptor
opendir File open a directory
ord String find a character's numeric representation
our Namespace declare and assign a package variable (lexical scoping)
pack Binary String convert a list into a binary representation
package Modules Namespace Objects declare a separate global namespace
__PACKAGE__ Flow the current package
pipe Process open a pair of connected filehandles
pop ARRAY remove the last element from an array and return it
pos Regexp find or set the offset for the last/next m//g search
print I/O output a list to a filehandle
printf I/O output a formatted list to a filehandle
prototype Misc get the prototype (if any) of a subroutine
push ARRAY append one or more elements to an array
q/STRING/ String singly quote a string
qq/STRING/ String doubly quote a string
qr/STRING/ Regexp compile pattern
quotemeta Regexp quote regular expression magic characters
qw/STRING/ LIST quote a list of words
qx/STRING/ Process backquote quote a string
rand Math retrieve the next pseudorandom number
read Binary I/O fixed-length buffered input from a filehandle
readdir I/O get a directory from a directory handle
readline I/O fetch a record from a file
readlink File determine where a symbolic link is pointing
readpipe Process execute a system command and collect standard output
recv Socket receive a message over a Socket
redo Flow start this loop iteration over again
ref Objects find out the type of thing being referenced
rename File change a filename
require Modules load in external functions from a library at runtime
reset Misc clear all variables of a given name
return Flow get out of a function early
reverse LIST String flip a string or a list
rewinddir I/O reset directory handle
rindex String right-to-left substring search
rmdir File remove a directory
s/// Regexp replace a pattern with a string
say I/O output a list to a filehandle, appending a newline
scalar Misc force a scalar context
seek I/O reposition file pointer for random-access I/O
seekdir I/O reposition directory pointer
select File I/O reset default output or do I/O multiplexing
semctl SysV SysV semaphore control operations
semget SysV get set of SysV semaphores
semop SysV SysV semaphore operations
send Socket send a message over a socket
setgrent User prepare group file for use
sethostent Network prepare hosts file for use
setnetent Network prepare networks file for use
setpgrp Process set the process group of a process
setpriority Process set a process's nice value
setprotoent Network prepare protocols file for use
setpwent User prepare passwd file for use
setservent Network prepare services file for use
setsockopt Socket set some socket options
shift ARRAY remove the first element of an array, and return it
shmctl SysV SysV shared memory operations
shmget SysV get SysV shared memory segment identifier
shmread SysV read SysV shared memory
shmwrite SysV write SysV shared memory
shutdown Socket close down just half of a socket connection
sin Math return the sine of a number
sleep Process block for some number of seconds
socket Socket create a socket
socketpair Socket create a pair of sockets
sort LIST sort a list of values
splice ARRAY add or remove elements anywhere in an array
split Regexp split up a string using a regexp delimiter
sprintf String formatted print into a string
sqrt Math square root function
srand Math seed the random number generator
stat File get a file's status information
state Namespace declare and assign a persistent lexical variable
study Regexp no-op, formerly optimized input data for repeated searches
sub Flow declare a subroutine, possibly anonymously
__SUB__ Flow the current subroutine, or C<undef> if not in a subroutine
substr String get or alter a portion of a string
symlink File create a symbolic link to a file
syscall Binary I/O execute an arbitrary system call
sysopen File open a file, pipe, or descriptor
sysread Binary I/O fixed-length unbuffered input from a filehandle
sysseek Binary I/O position I/O pointer on handle used with sysread and syswrite
system Process run a separate program
syswrite Binary I/O fixed-length unbuffered output to a filehandle
tell I/O get current seekpointer on a filehandle
telldir I/O get current seekpointer on a directory handle
tie Objects bind a variable to an object class
tied Objects get a reference to the object underlying a tied variable
time Time return number of seconds since 1970
times Process Time return elapsed time for self and child processes
tr/// String transliterate a string
truncate I/O shorten a file
uc String return upper-case version of a string
ucfirst String return a string with just the next letter in upper case
umask File set file creation mode mask
undef Misc remove a variable or function definition
unlink File remove one link to a file
unpack Binary LIST convert binary structure into normal perl variables
unshift ARRAY prepend more elements to the beginning of a list
untie Objects break a tie binding to a variable
use Modules Namespace Objects load in a module at compile time and import its namespace
utime File set a file's last access and modify times
values ARRAY HASH return a list of the values in a hash
vec Binary test or set particular bits in a string
wait Process wait for any child process to die
waitpid Process wait for a particular child process to die
wantarray Flow get void vs scalar vs list context of current subroutine call
warn I/O print debugging info
write I/O print a picture record
y/// String transliterate a string
PK Į[�b�_ �_ Select.pmnu �[��� #############################################################################
# Pod/Select.pm -- function to select portions of POD docs
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Select;
use strict;
use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);
$VERSION = '1.63'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
=head1 NAME
Pod::Select, podselect() - extract selected sections of POD from input
=head1 SYNOPSIS
use Pod::Select;
## Select all the POD sections for each file in @filelist
## and print the result on standard output.
podselect(@filelist);
## Same as above, but write to tmp.out
podselect({-output => "tmp.out"}, @filelist):
## Select from the given filelist, only those POD sections that are
## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist):
## Select the "DESCRIPTION" section of the PODs from STDIN and write
## the result to STDERR.
podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN);
or
use Pod::Select;
## Create a parser object for selecting POD sections from the input
$parser = new Pod::Select();
## Select all the POD sections for each file in @filelist
## and print the result to tmp.out.
$parser->parse_from_file("<&STDIN", "tmp.out");
## Select from the given filelist, only those POD sections that are
## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
$parser->select("NAME|SYNOPSIS", "OPTIONS");
for (@filelist) { $parser->parse_from_file($_); }
## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from
## STDIN and write the result to STDERR.
$parser->select("DESCRIPTION");
$parser->add_selection("SEE ALSO");
$parser->parse_from_filehandle(\*STDIN, \*STDERR);
=head1 REQUIRES
perl5.005, Pod::Parser, Exporter, Carp
=head1 EXPORTS
podselect()
=head1 DESCRIPTION
B<NOTE: This module is considered legacy; modern Perl releases (5.18 and
higher) are going to remove Pod-Parser from core and use L<Pod-Simple>
for all things POD.>
B<podselect()> is a function which will extract specified sections of
pod documentation from an input stream. This ability is provided by the
B<Pod::Select> module which is a subclass of B<Pod::Parser>.
B<Pod::Select> provides a method named B<select()> to specify the set of
POD sections to select for processing/printing. B<podselect()> merely
creates a B<Pod::Select> object and then invokes the B<podselect()>
followed by B<parse_from_file()>.
=head1 SECTION SPECIFICATIONS
B<podselect()> and B<Pod::Select::select()> may be given one or more
"section specifications" to restrict the text processed to only the
desired set of sections and their corresponding subsections. A section
specification is a string containing one or more Perl-style regular
expressions separated by forward slashes ("/"). If you need to use a
forward slash literally within a section title you can escape it with a
backslash ("\/").
The formal syntax of a section specification is:
=over 4
=item *
I<head1-title-regex>/I<head2-title-regex>/...
=back
Any omitted or empty regular expressions will default to ".*".
Please note that each regular expression given is implicitly
anchored by adding "^" and "$" to the beginning and end. Also, if a
given regular expression starts with a "!" character, then the
expression is I<negated> (so C<!foo> would match anything I<except>
C<foo>).
Some example section specifications follow.
=over 4
=item *
Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:
C<NAME|SYNOPSIS>
=item *
Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>
section:
C<DESCRIPTION/Question|Answer>
=item *
Match the C<Comments> subsection of I<all> sections:
C</Comments>
=item *
Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:
C<DESCRIPTION/!Comments>
=item *
Match the C<DESCRIPTION> section but do I<not> match any of its subsections:
C<DESCRIPTION/!.+>
=item *
Match all top level sections but none of their subsections:
C</!.+>
=back
=begin _NOT_IMPLEMENTED_
=head1 RANGE SPECIFICATIONS
B<podselect()> and B<Pod::Select::select()> may be given one or more
"range specifications" to restrict the text processed to only the
desired ranges of paragraphs in the desired set of sections. A range
specification is a string containing a single Perl-style regular
expression (a regex), or else two Perl-style regular expressions
(regexs) separated by a ".." (Perl's "range" operator is "..").
The regexs in a range specification are delimited by forward slashes
("/"). If you need to use a forward slash literally within a regex you
can escape it with a backslash ("\/").
The formal syntax of a range specification is:
=over 4
=item *
/I<start-range-regex>/[../I<end-range-regex>/]
=back
Where each the item inside square brackets (the ".." followed by the
end-range-regex) is optional. Each "range-regex" is of the form:
=cmd-expr text-expr
Where I<cmd-expr> is intended to match the name of one or more POD
commands, and I<text-expr> is intended to match the paragraph text for
the command. If a range-regex is supposed to match a POD command, then
the first character of the regex (the one after the initial '/')
absolutely I<must> be a single '=' character; it may not be anything
else (not even a regex meta-character) if it is supposed to match
against the name of a POD command.
If no I<=cmd-expr> is given then the text-expr will be matched against
plain textblocks unless it is preceded by a space, in which case it is
matched against verbatim text-blocks. If no I<text-expr> is given then
only the command-portion of the paragraph is matched against.
Note that these two expressions are each implicitly anchored. This
means that when matching against the command-name, there will be an
implicit '^' and '$' around the given I<=cmd-expr>; and when matching
against the paragraph text there will be an implicit '\A' and '\Z'
around the given I<text-expr>.
Unlike with section-specs, the '!' character does I<not> have any special
meaning (negation or otherwise) at the beginning of a range-spec!
Some example range specifications follow.
=over 4
=item
Match all C<=for html> paragraphs:
C</=for html/>
=item
Match all paragraphs between C<=begin html> and C<=end html>
(note that this will I<not> work correctly if such sections
are nested):
C</=begin html/../=end html/>
=item
Match all paragraphs between the given C<=item> name until the end of the
current section:
C</=item mine/../=head\d/>
=item
Match all paragraphs between the given C<=item> until the next item, or
until the end of the itemized list (note that this will I<not> work as
desired if the item contains an itemized list nested within it):
C</=item mine/../=(item|back)/>
=back
=end _NOT_IMPLEMENTED_
=cut
#############################################################################
#use diagnostics;
use Carp;
use Pod::Parser 1.04;
@ISA = qw(Pod::Parser);
@EXPORT = qw(&podselect);
## Maximum number of heading levels supported for '=headN' directives
*MAX_HEADING_LEVEL = \3;
#############################################################################
=head1 OBJECT METHODS
The following methods are provided in this module. Each one takes a
reference to the object itself as an implicit first parameter.
=cut
##---------------------------------------------------------------------------
## =begin _PRIVATE_
##
## =head1 B<_init_headings()>
##
## Initialize the current set of active section headings.
##
## =cut
##
## =end _PRIVATE_
sub _init_headings {
my $self = shift;
local *myData = $self;
## Initialize current section heading titles if necessary
unless (defined $myData{_SECTION_HEADINGS}) {
local *section_headings = $myData{_SECTION_HEADINGS} = [];
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
$section_headings[$i] = '';
}
}
}
##---------------------------------------------------------------------------
=head1 B<curr_headings()>
($head1, $head2, $head3, ...) = $parser->curr_headings();
$head1 = $parser->curr_headings(1);
This method returns a list of the currently active section headings and
subheadings in the document being parsed. The list of headings returned
corresponds to the most recently parsed paragraph of the input.
If an argument is given, it must correspond to the desired section
heading number, in which case only the specified section heading is
returned. If there is no current section heading at the specified
level, then C<undef> is returned.
=cut
sub curr_headings {
my $self = shift;
$self->_init_headings() unless (defined $self->{_SECTION_HEADINGS});
my @headings = @{ $self->{_SECTION_HEADINGS} };
return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings;
}
##---------------------------------------------------------------------------
=head1 B<select()>
$parser->select($section_spec1,$section_spec2,...);
This method is used to select the particular sections and subsections of
POD documentation that are to be printed and/or processed. The existing
set of selected sections is I<replaced> with the given set of sections.
See B<add_selection()> for adding to the current set of selected
sections.
Each of the C<$section_spec> arguments should be a section specification
as described in L<"SECTION SPECIFICATIONS">. The section specifications
are parsed by this method and the resulting regular expressions are
stored in the invoking object.
If no C<$section_spec> arguments are given, then the existing set of
selected sections is cleared out (which means C<all> sections will be
processed).
This method should I<not> normally be overridden by subclasses.
=cut
sub select {
my ($self, @sections) = @_;
local *myData = $self;
local $_;
### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?)
##---------------------------------------------------------------------
## The following is a blatant hack for backward compatibility, and for
## implementing add_selection(). If the *first* *argument* is the
## string "+", then the remaining section specifications are *added*
## to the current set of selections; otherwise the given section
## specifications will *replace* the current set of selections.
##
## This should probably be fixed someday, but for the present time,
## it seems incredibly unlikely that "+" would ever correspond to
## a legitimate section heading
##---------------------------------------------------------------------
my $add = ($sections[0] eq '+') ? shift(@sections) : '';
## Reset the set of sections to use
unless (@sections) {
delete $myData{_SELECTED_SECTIONS} unless ($add);
return;
}
$myData{_SELECTED_SECTIONS} = []
unless ($add && exists $myData{_SELECTED_SECTIONS});
local *selected_sections = $myData{_SELECTED_SECTIONS};
## Compile each spec
for my $spec (@sections) {
if ( defined($_ = _compile_section_spec($spec)) ) {
## Store them in our sections array
push(@selected_sections, $_);
}
else {
carp qq{Ignoring section spec "$spec"!\n};
}
}
}
##---------------------------------------------------------------------------
=head1 B<add_selection()>
$parser->add_selection($section_spec1,$section_spec2,...);
This method is used to add to the currently selected sections and
subsections of POD documentation that are to be printed and/or
processed. See <select()> for replacing the currently selected sections.
Each of the C<$section_spec> arguments should be a section specification
as described in L<"SECTION SPECIFICATIONS">. The section specifications
are parsed by this method and the resulting regular expressions are
stored in the invoking object.
This method should I<not> normally be overridden by subclasses.
=cut
sub add_selection {
my $self = shift;
return $self->select('+', @_);
}
##---------------------------------------------------------------------------
=head1 B<clear_selections()>
$parser->clear_selections();
This method takes no arguments, it has the exact same effect as invoking
<select()> with no arguments.
=cut
sub clear_selections {
my $self = shift;
return $self->select();
}
##---------------------------------------------------------------------------
=head1 B<match_section()>
$boolean = $parser->match_section($heading1,$heading2,...);
Returns a value of true if the given section and subsection heading
titles match any of the currently selected section specifications in
effect from prior calls to B<select()> and B<add_selection()> (or if
there are no explicitly selected/deselected sections).
The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of
the corresponding sections, subsections, etc. to try and match. If
C<$headingN> is omitted then it defaults to the current corresponding
section heading title in the input.
This method should I<not> normally be overridden by subclasses.
=cut
sub match_section {
my $self = shift;
my (@headings) = @_;
local *myData = $self;
## Return true if no restrictions were explicitly specified
my $selections = (exists $myData{_SELECTED_SECTIONS})
? $myData{_SELECTED_SECTIONS} : undef;
return 1 unless ((defined $selections) && @{$selections});
## Default any unspecified sections to the current one
my @current_headings = $self->curr_headings();
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
(defined $headings[$i]) or $headings[$i] = $current_headings[$i];
}
## Look for a match against the specified section expressions
for my $section_spec ( @{$selections} ) {
##------------------------------------------------------
## Each portion of this spec must match in order for
## the spec to be matched. So we will start with a
## match-value of 'true' and logically 'and' it with
## the results of matching a given element of the spec.
##------------------------------------------------------
my $match = 1;
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
my $regex = $section_spec->[$i];
my $negated = ($regex =~ s/^\!//);
$match &= ($negated ? ($headings[$i] !~ /${regex}/)
: ($headings[$i] =~ /${regex}/));
last unless ($match);
}
return 1 if ($match);
}
return 0; ## no match
}
##---------------------------------------------------------------------------
=head1 B<is_selected()>
$boolean = $parser->is_selected($paragraph);
This method is used to determine if the block of text given in
C<$paragraph> falls within the currently selected set of POD sections
and subsections to be printed or processed. This method is also
responsible for keeping track of the current input section and
subsections. It is assumed that C<$paragraph> is the most recently read
(but not yet processed) input paragraph.
The value returned will be true if the C<$paragraph> and the rest of the
text in the same section as C<$paragraph> should be selected (included)
for processing; otherwise a false value is returned.
=cut
sub is_selected {
my ($self, $paragraph) = @_;
local $_;
local *myData = $self;
$self->_init_headings() unless (defined $myData{_SECTION_HEADINGS});
## Keep track of current sections levels and headings
$_ = $paragraph;
if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/)
{
## This is a section heading command
my ($level, $heading) = ($2, $3);
$level = 1 + (length($1) / 3) if ((! length $level) || (length $1));
## Reset the current section heading at this level
$myData{_SECTION_HEADINGS}->[$level - 1] = $heading;
## Reset subsection headings of this one to empty
for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) {
$myData{_SECTION_HEADINGS}->[$i] = '';
}
}
return $self->match_section();
}
#############################################################################
=head1 EXPORTED FUNCTIONS
The following functions are exported by this module. Please note that
these are functions (not methods) and therefore C<do not> take an
implicit first argument.
=cut
##---------------------------------------------------------------------------
=head1 B<podselect()>
podselect(\%options,@filelist);
B<podselect> will print the raw (untranslated) POD paragraphs of all
POD sections in the given input files specified by C<@filelist>
according to the options given in C<\%options>.
If any argument to B<podselect> is a reference to a hash
(associative array) then the values with the following keys are
processed as follows:
=over 4
=item B<-output>
A string corresponding to the desired output file (or ">&STDOUT"
or ">&STDERR"), or a filehandle to write on. The default is to use
standard output.
=item B<-sections>
A reference to an array of sections specifications (as described in
L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD
sections and subsections to be selected from input. If no section
specifications are given, then all sections of the PODs are used.
=begin _NOT_IMPLEMENTED_
=item B<-ranges>
A reference to an array of range specifications (as described in
L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD
paragraphs to be selected from the desired input sections. If no range
specifications are given, then all paragraphs of the desired sections
are used.
=end _NOT_IMPLEMENTED_
=back
All other arguments are optional and should correspond to filehandles to
read from or the names of input files containing POD sections. A file name
of "", "-" or "<&STDIN" will be interpreted to mean standard input (which
is the default if no arguments are given).
=cut
sub podselect {
my(@argv) = @_;
my %defaults = ();
my $pod_parser = new Pod::Select(%defaults);
my $num_inputs = 0;
my $output = '>&STDOUT';
my %opts;
local $_;
for (@argv) {
my $ref = ref($_);
if ($ref && $ref eq 'HASH') {
%opts = (%defaults, %{$_});
##-------------------------------------------------------------
## Need this for backward compatibility since we formerly used
## options that were all uppercase words rather than ones that
## looked like Unix command-line options.
## to be uppercase keywords)
##-------------------------------------------------------------
%opts = map {
my ($key, $val) = (lc $_, $opts{$_});
$key =~ s/^(?=\w)/-/;
$key =~ /^-se[cl]/ and $key = '-sections';
#! $key eq '-range' and $key .= 's';
($key => $val);
} (keys %opts);
## Process the options
(exists $opts{'-output'}) and $output = $opts{'-output'};
## Select the desired sections
$pod_parser->select(@{ $opts{'-sections'} })
if ( (defined $opts{'-sections'})
&& ((ref $opts{'-sections'}) eq 'ARRAY') );
#! ## Select the desired paragraph ranges
#! $pod_parser->select(@{ $opts{'-ranges'} })
#! if ( (defined $opts{'-ranges'})
#! && ((ref $opts{'-ranges'}) eq 'ARRAY') );
}
elsif(!$ref || $ref eq 'GLOB') {
$pod_parser->parse_from_file($_, $output);
++$num_inputs;
}
else {
croak "Input from $ref reference not supported!\n";
}
}
$pod_parser->parse_from_file('-') unless ($num_inputs > 0);
}
#############################################################################
=head1 PRIVATE METHODS AND DATA
B<Pod::Select> makes uses a number of internal methods and data fields
which clients should not need to see or use. For the sake of avoiding
name collisions with client data and methods, these methods and fields
are briefly discussed here. Determined hackers may obtain further
information about them by reading the B<Pod::Select> source code.
Private data fields are stored in the hash-object whose reference is
returned by the B<new()> constructor for this class. The names of all
private methods and data-fields used by B<Pod::Select> begin with a
prefix of "_" and match the regular expression C</^_\w+$/>.
=cut
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head1 B<_compile_section_spec()>
$listref = $parser->_compile_section_spec($section_spec);
This function (note it is a function and I<not> a method) takes a
section specification (as described in L<"SECTION SPECIFICATIONS">)
given in C<$section_sepc>, and compiles it into a list of regular
expressions. If C<$section_spec> has no syntax errors, then a reference
to the list (array) of corresponding regular expressions is returned;
otherwise C<undef> is returned and an error message is printed (using
B<carp>) for each invalid regex.
=end _PRIVATE_
=cut
sub _compile_section_spec {
my ($section_spec) = @_;
my (@regexs, $negated);
## Compile the spec into a list of regexs
local $_ = $section_spec;
s{\\\\}{\001}g; ## handle escaped backward slashes
s{\\/}{\002}g; ## handle escaped forward slashes
## Parse the regexs for the heading titles
@regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
## Set default regex for omitted levels
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
$regexs[$i] = '.*' unless ((defined $regexs[$i])
&& (length $regexs[$i]));
}
## Modify the regexs as needed and validate their syntax
my $bad_regexs = 0;
for (@regexs) {
$_ .= '.+' if ($_ eq '!');
s{\001}{\\\\}g; ## restore escaped backward slashes
s{\002}{\\/}g; ## restore escaped forward slashes
$negated = s/^\!//; ## check for negation
eval "m{$_}"; ## check regex syntax
if ($@) {
++$bad_regexs;
carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
}
else {
## Add the forward and rear anchors (and put the negator back)
$_ = '^' . $_ unless (/^\^/);
$_ = $_ . '$' unless (/\$$/);
$_ = '!' . $_ if ($negated);
}
}
return (! $bad_regexs) ? [ @regexs ] : undef;
}
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head2 $self->{_SECTION_HEADINGS}
A reference to an array of the current section heading titles for each
heading level (note that the first heading level title is at index 0).
=end _PRIVATE_
=cut
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head2 $self->{_SELECTED_SECTIONS}
A reference to an array of references to arrays. Each subarray is a list
of anchored regular expressions (preceded by a "!" if the expression is to
be negated). The index of the expression in the subarray should correspond
to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}>
that it is to be matched against.
=end _PRIVATE_
=cut
#############################################################################
=head1 SEE ALSO
L<Pod::Parser>
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<pod2text> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
B<Pod::Select> is part of the L<Pod::Parser> distribution.
=cut
1;
# vim: ts=4 sw=4 et
PK Ʈ[�m�� � Simple/Transcode.pmnu �[���
require 5;
package Pod::Simple::Transcode;
use strict;
use vars qw($VERSION @ISA);
$VERSION = '3.35';
BEGIN {
if(defined &DEBUG) {;} # Okay
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG; }
else { *DEBUG = sub () {0}; }
}
foreach my $class (
'Pod::Simple::TranscodeSmart',
'Pod::Simple::TranscodeDumb',
'',
) {
$class or die "Couldn't load any encoding classes";
DEBUG and print STDERR "About to try loading $class...\n";
eval "require $class;";
if($@) {
DEBUG and print STDERR "Couldn't load $class: $@\n";
} else {
DEBUG and print STDERR "OK, loaded $class.\n";
@ISA = ($class);
last;
}
}
sub _blorp { return; } # just to avoid any "empty class" warning
1;
__END__
PK Ʈ[��f� � Simple/Subclassing.podnu �[��� =head1 NAME
Pod::Simple::Subclassing -- write a formatter as a Pod::Simple subclass
=head1 SYNOPSIS
package Pod::SomeFormatter;
use Pod::Simple;
@ISA = qw(Pod::Simple);
$VERSION = '1.01';
use strict;
sub _handle_element_start {
my($parser, $element_name, $attr_hash_r) = @_;
...
}
sub _handle_element_end {
my($parser, $element_name, $attr_hash_r) = @_;
# NOTE: $attr_hash_r is only present when $element_name is "over" or "begin"
# The remaining code excerpts will mostly ignore this $attr_hash_r, as it is
# mostly useless. It is documented where "over-*" and "begin" events are
# documented.
...
}
sub _handle_text {
my($parser, $text) = @_;
...
}
1;
=head1 DESCRIPTION
This document is about using Pod::Simple to write a Pod processor,
generally a Pod formatter. If you just want to know about using an
existing Pod formatter, instead see its documentation and see also the
docs in L<Pod::Simple>.
B<The zeroeth step> in writing a Pod formatter is to make sure that there
isn't already a decent one in CPAN. See L<http://search.cpan.org/>, and
run a search on the name of the format you want to render to. Also
consider joining the Pod People list
L<http://lists.perl.org/showlist.cgi?name=pod-people> and asking whether
anyone has a formatter for that format -- maybe someone cobbled one
together but just hasn't released it.
B<The first step> in writing a Pod processor is to read L<perlpodspec>,
which contains information on writing a Pod parser (which has been
largely taken care of by Pod::Simple), but also a lot of requirements
and recommendations for writing a formatter.
B<The second step> is to actually learn the format you're planning to
format to -- or at least as much as you need to know to represent Pod,
which probably isn't much.
B<The third step> is to pick which of Pod::Simple's interfaces you want to
use:
=over
=item Pod::Simple
The basic L<Pod::Simple> interface that uses C<_handle_element_start()>,
C<_handle_element_end()> and C<_handle_text()>.
=item Pod::Simple::Methody
The L<Pod::Simple::Methody> interface is event-based, similar to that of
L<HTML::Parser> or L<XML::Parser>'s "Handlers".
=item Pod::Simple::PullParser
L<Pod::Simple::PullParser> provides a token-stream interface, sort of
like L<HTML::TokeParser>'s interface.
=item Pod::Simple::SimpleTree
L<Pod::Simple::SimpleTree> provides a simple tree interface, rather like
L<XML::Parser>'s "Tree" interface. Users familiar with XML handling will
be comfortable with this interface. Users interested in outputting XML,
should look into the modules that produce an XML representation of the
Pod stream, notably L<Pod::Simple::XMLOutStream>; you can feed the output
of such a class to whatever XML parsing system you are most at home with.
=back
B<The last step> is to write your code based on how the events (or tokens,
or tree-nodes, or the XML, or however you're parsing) will map to
constructs in the output format. Also be sure to consider how to escape
text nodes containing arbitrary text, and what to do with text
nodes that represent preformatted text (from verbatim sections).
=head1 Events
TODO intro... mention that events are supplied for implicits, like for
missing >'s
In the following section, we use XML to represent the event structure
associated with a particular construct. That is, TODO
=over
=item C<< $parser->_handle_element_start( I<element_name>, I<attr_hashref> ) >>
=item C<< $parser->_handle_element_end( I<element_name> ) >>
=item C<< $parser->_handle_text( I<text_string> ) >>
=back
TODO describe
=over
=item events with an element_name of Document
Parsing a document produces this event structure:
<Document start_line="543">
...all events...
</Document>
The value of the I<start_line> attribute will be the line number of the first
Pod directive in the document.
If there is no Pod in the given document, then the
event structure will be this:
<Document contentless="1" start_line="543">
</Document>
In that case, the value of the I<start_line> attribute will not be meaningful;
under current implementations, it will probably be the line number of the
last line in the file.
=item events with an element_name of Para
Parsing a plain (non-verbatim, non-directive, non-data) paragraph in
a Pod document produces this event structure:
<Para start_line="543">
...all events in this paragraph...
</Para>
The value of the I<start_line> attribute will be the line number of the start
of the paragraph.
For example, parsing this paragraph of Pod:
The value of the I<start_line> attribute will be the
line number of the start of the paragraph.
produces this event structure:
<Para start_line="129">
The value of the
<I>
start_line
</I>
attribute will be the line number of the first Pod directive
in the document.
</Para>
=item events with an element_name of B, C, F, or I.
Parsing a BE<lt>...E<gt> formatting code (or of course any of its
semantically identical syntactic variants
S<BE<lt>E<lt> ... E<gt>E<gt>>,
or S<BE<lt>E<lt>E<lt>E<lt> ... E<gt>E<gt>E<gt>E<gt>>, etc.)
produces this event structure:
<B>
...stuff...
</B>
Currently, there are no attributes conveyed.
Parsing C, F, or I codes produce the same structure, with only a
different element name.
If your parser object has been set to accept other formatting codes,
then they will be presented like these B/C/F/I codes -- i.e., without
any attributes.
=item events with an element_name of S
Normally, parsing an SE<lt>...E<gt> sequence produces this event
structure, just as if it were a B/C/F/I code:
<S>
...stuff...
</S>
However, Pod::Simple (and presumably all derived parsers) offers the
C<nbsp_for_S> option which, if enabled, will suppress all S events, and
instead change all spaces in the content to non-breaking spaces. This is
intended for formatters that output to a format that has no code that
means the same as SE<lt>...E<gt>, but which has a code/character that
means non-breaking space.
=item events with an element_name of X
Normally, parsing an XE<lt>...E<gt> sequence produces this event
structure, just as if it were a B/C/F/I code:
<X>
...stuff...
</X>
However, Pod::Simple (and presumably all derived parsers) offers the
C<nix_X_codes> option which, if enabled, will suppress all X events
and ignore their content. For formatters/processors that don't use
X events, this is presumably quite useful.
=item events with an element_name of L
Because the LE<lt>...E<gt> is the most complex construct in the
language, it should not surprise you that the events it generates are
the most complex in the language. Most of complexity is hidden away in
the attribute values, so for those of you writing a Pod formatter that
produces a non-hypertextual format, you can just ignore the attributes
and treat an L event structure like a formatting element that
(presumably) doesn't actually produce a change in formatting. That is,
the content of the L event structure (as opposed to its
attributes) is always what text should be displayed.
There are, at first glance, three kinds of L links: URL, man, and pod.
When a LE<lt>I<some_url>E<gt> code is parsed, it produces this event
structure:
<L content-implicit="yes" raw="that_url" to="that_url" type="url">
that_url
</L>
The C<type="url"> attribute is always specified for this type of
L code.
For example, this Pod source:
L<http://www.perl.com/CPAN/authors/>
produces this event structure:
<L content-implicit="yes" raw="http://www.perl.com/CPAN/authors/" to="http://www.perl.com/CPAN/authors/" type="url">
http://www.perl.com/CPAN/authors/
</L>
When a LE<lt>I<manpage(section)>E<gt> code is parsed (and these are
fairly rare and not terribly useful), it produces this event structure:
<L content-implicit="yes" raw="manpage(section)" to="manpage(section)" type="man">
manpage(section)
</L>
The C<type="man"> attribute is always specified for this type of
L code.
For example, this Pod source:
L<crontab(5)>
produces this event structure:
<L content-implicit="yes" raw="crontab(5)" to="crontab(5)" type="man">
crontab(5)
</L>
In the rare cases where a man page link has a section specified, that text appears
in a I<section> attribute. For example, this Pod source:
L<crontab(5)/"ENVIRONMENT">
will produce this event structure:
<L content-implicit="yes" raw="crontab(5)/"ENVIRONMENT"" section="ENVIRONMENT" to="crontab(5)" type="man">
"ENVIRONMENT" in crontab(5)
</L>
In the rare case where the Pod document has code like
LE<lt>I<sometext>|I<manpage(section)>E<gt>, then the I<sometext> will appear
as the content of the element, the I<manpage(section)> text will appear
only as the value of the I<to> attribute, and there will be no
C<content-implicit="yes"> attribute (whose presence means that the Pod parser
had to infer what text should appear as the link text -- as opposed to
cases where that attribute is absent, which means that the Pod parser did
I<not> have to infer the link text, because that L code explicitly specified
some link text.)
For example, this Pod source:
L<hell itself!|crontab(5)>
will produce this event structure:
<L raw="hell itself!|crontab(5)" to="crontab(5)" type="man">
hell itself!
</L>
The last type of L structure is for links to/within Pod documents. It is
the most complex because it can have a I<to> attribute, I<or> a
I<section> attribute, or both. The C<type="pod"> attribute is always
specified for this type of L code.
In the most common case, the simple case of a LE<lt>podpageE<gt> code
produces this event structure:
<L content-implicit="yes" raw="podpage" to="podpage" type="pod">
podpage
</L>
For example, this Pod source:
L<Net::Ping>
produces this event structure:
<L content-implicit="yes" raw="Net::Ping" to="Net::Ping" type="pod">
Net::Ping
</L>
In cases where there is link-text explicitly specified, it
is to be found in the content of the element (and not the
attributes), just as with the LE<lt>I<sometext>|I<manpage(section)>E<gt>
case discussed above. For example, this Pod source:
L<Perl Error Messages|perldiag>
produces this event structure:
<L raw="Perl Error Messages|perldiag" to="perldiag" type="pod">
Perl Error Messages
</L>
In cases of links to a section in the current Pod document,
there is a I<section> attribute instead of a I<to> attribute.
For example, this Pod source:
L</"Member Data">
produces this event structure:
<L content-implicit="yes" raw="/"Member Data"" section="Member Data" type="pod">
"Member Data"
</L>
As another example, this Pod source:
L<the various attributes|/"Member Data">
produces this event structure:
<L raw="the various attributes|/"Member Data"" section="Member Data" type="pod">
the various attributes
</L>
In cases of links to a section in a different Pod document,
there are both a I<section> attribute and a L<to> attribute.
For example, this Pod source:
L<perlsyn/"Basic BLOCKs and Switch Statements">
produces this event structure:
<L content-implicit="yes" raw="perlsyn/"Basic BLOCKs and Switch Statements"" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
"Basic BLOCKs and Switch Statements" in perlsyn
</L>
As another example, this Pod source:
L<SWITCH statements|perlsyn/"Basic BLOCKs and Switch Statements">
produces this event structure:
<L raw="SWITCH statements|perlsyn/"Basic BLOCKs and Switch Statements"" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
SWITCH statements
</L>
Incidentally, note that we do not distinguish between these syntaxes:
L</"Member Data">
L<"Member Data">
L</Member Data>
L<Member Data> [deprecated syntax]
That is, they all produce the same event structure (for the most part), namely:
<L content-implicit="yes" raw="$depends_on_syntax" section="Member Data" type="pod">
"Member Data"
</L>
The I<raw> attribute depends on what the raw content of the C<LE<lt>E<gt>> is,
so that is why the event structure is the same "for the most part".
If you have not guessed it yet, the I<raw> attribute contains the raw,
original, unescaped content of the C<LE<lt>E<gt>> formatting code. In addition
to the examples above, take notice of the following event structure produced
by the following C<LE<lt>E<gt>> formatting code.
L<click B<here>|page/About the C<-M> switch>
<L raw="click B<here>|page/About the C<-M> switch" section="About the -M switch" to="page" type="pod">
click B<here>
</L>
Specifically, notice that the formatting codes are present and unescaped
in I<raw>.
There is a known bug in the I<raw> attribute where any surrounding whitespace
is condensed into a single ' '. For example, given LE<60> linkE<62>, I<raw>
will be " link".
=item events with an element_name of E or Z
While there are Pod codes EE<lt>...E<gt> and ZE<lt>E<gt>, these
I<do not> produce any E or Z events -- that is, there are no such
events as E or Z.
=item events with an element_name of Verbatim
When a Pod verbatim paragraph (AKA "codeblock") is parsed, it
produces this event structure:
<Verbatim start_line="543" xml:space="preserve">
...text...
</Verbatim>
The value of the I<start_line> attribute will be the line number of the
first line of this verbatim block. The I<xml:space> attribute is always
present, and always has the value "preserve".
The text content will have tabs already expanded.
=item events with an element_name of head1 .. head4
When a "=head1 ..." directive is parsed, it produces this event
structure:
<head1>
...stuff...
</head1>
For example, a directive consisting of this:
=head1 Options to C<new> et al.
will produce this event structure:
<head1 start_line="543">
Options to
<C>
new
</C>
et al.
</head1>
"=head2" through "=head4" directives are the same, except for the element
names in the event structure.
=item events with an element_name of encoding
In the default case, the events corresponding to C<=encoding> directives
are not emitted. They are emitted if C<keep_encoding_directive> is true.
In that case they produce event structures like
L</"events with an element_name of head1 .. head4"> above.
=item events with an element_name of over-bullet
When an "=over ... Z<>=back" block is parsed where the items are
a bulleted list, it will produce this event structure:
<over-bullet indent="4" start_line="543">
<item-bullet start_line="545">
...Stuff...
</item-bullet>
...more item-bullets...
</over-bullet fake-closer="1">
The attribute I<fake-closer> is only present if it is a true value; it is not
present if it is a false value. It is shown in the above example to illustrate
where the attribute is (in the B<closing> tag). It signifies that the C<=over>
did not have a matching C<=back>, and thus Pod::Simple had to create a fake
closer.
For example, this Pod source:
=over
=item *
Something
=back
Would produce an event structure that does B<not> have the I<fake-closer>
attribute, whereas this Pod source:
=over
=item *
Gasp! An unclosed =over block!
would. The rest of the over-* examples will not demonstrate this attribute,
but they all can have it. See L<Pod::Checker>'s source for an example of this
attribute being used.
The value of the I<indent> attribute is whatever value is after the
"=over" directive, as in "=over 8". If no such value is specified
in the directive, then the I<indent> attribute has the value "4".
For example, this Pod source:
=over
=item *
Stuff
=item *
Bar I<baz>!
=back
produces this event structure:
<over-bullet indent="4" start_line="10">
<item-bullet start_line="12">
Stuff
</item-bullet>
<item-bullet start_line="14">
Bar <I>baz</I>!
</item-bullet>
</over-bullet>
=item events with an element_name of over-number
When an "=over ... Z<>=back" block is parsed where the items are
a numbered list, it will produce this event structure:
<over-number indent="4" start_line="543">
<item-number number="1" start_line="545">
...Stuff...
</item-number>
...more item-number...
</over-bullet>
This is like the "over-bullet" event structure; but note that the contents
are "item-number" instead of "item-bullet", and note that they will have
a "number" attribute, which some formatters/processors may ignore
(since, for example, there's no need for it in HTML when producing
an "<UL><LI>...</LI>...</UL>" structure), but which any processor may use.
Note that the values for the I<number> attributes of "item-number"
elements in a given "over-number" area I<will> start at 1 and go up by
one each time. If the Pod source doesn't follow that order (even though
it really should!), whatever numbers it has will be ignored (with
the correct values being put in the I<number> attributes), and an error
message might be issued to the user.
=item events with an element_name of over-text
These events are somewhat unlike the other over-*
structures, as far as what their contents are. When
an "=over ... Z<>=back" block is parsed where the items are
a list of text "subheadings", it will produce this event structure:
<over-text indent="4" start_line="543">
<item-text>
...stuff...
</item-text>
...stuff (generally Para or Verbatim elements)...
<item-text>
...more item-text and/or stuff...
</over-text>
The I<indent> and I<fake-closer> attributes are as with the other over-* events.
For example, this Pod source:
=over
=item Foo
Stuff
=item Bar I<baz>!
Quux
=back
produces this event structure:
<over-text indent="4" start_line="20">
<item-text start_line="22">
Foo
</item-text>
<Para start_line="24">
Stuff
</Para>
<item-text start_line="26">
Bar
<I>
baz
</I>
!
</item-text>
<Para start_line="28">
Quux
</Para>
</over-text>
=item events with an element_name of over-block
These events are somewhat unlike the other over-*
structures, as far as what their contents are. When
an "=over ... Z<>=back" block is parsed where there are no items,
it will produce this event structure:
<over-block indent="4" start_line="543">
...stuff (generally Para or Verbatim elements)...
</over-block>
The I<indent> and I<fake-closer> attributes are as with the other over-* events.
For example, this Pod source:
=over
For cutting off our trade with all parts of the world
For transporting us beyond seas to be tried for pretended offenses
He is at this time transporting large armies of foreign mercenaries to
complete the works of death, desolation and tyranny, already begun with
circumstances of cruelty and perfidy scarcely paralleled in the most
barbarous ages, and totally unworthy the head of a civilized nation.
=back
will produce this event structure:
<over-block indent="4" start_line="2">
<Para start_line="4">
For cutting off our trade with all parts of the world
</Para>
<Para start_line="6">
For transporting us beyond seas to be tried for pretended offenses
</Para>
<Para start_line="8">
He is at this time transporting large armies of [...more text...]
</Para>
</over-block>
=item events with an element_name of over-empty
B<Note: These events are only triggered if C<parse_empty_lists()> is set to a
true value.>
These events are somewhat unlike the other over-* structures, as far as what
their contents are. When an "=over ... Z<>=back" block is parsed where there
is no content, it will produce this event structure:
<over-empty indent="4" start_line="543">
</over-empty>
The I<indent> and I<fake-closer> attributes are as with the other over-* events.
For example, this Pod source:
=over
=over
=back
=back
will produce this event structure:
<over-block indent="4" start_line="1">
<over-empty indent="4" start_line="3">
</over-empty>
</over-block>
Note that the outer C<=over> is a block because it has no C<=item>s but still
has content: the inner C<=over>. The inner C<=over>, in turn, is completely
empty, and is treated as such.
=item events with an element_name of item-bullet
See L</"events with an element_name of over-bullet">, above.
=item events with an element_name of item-number
See L</"events with an element_name of over-number">, above.
=item events with an element_name of item-text
See L</"events with an element_name of over-text">, above.
=item events with an element_name of for
TODO...
=item events with an element_name of Data
TODO...
=back
=head1 More Pod::Simple Methods
Pod::Simple provides a lot of methods that aren't generally interesting
to the end user of an existing Pod formatter, but some of which you
might find useful in writing a Pod formatter. They are listed below. The
first several methods (the accept_* methods) are for declaring the
capabilities of your parser, notably what C<=for I<targetname>> sections
it's interested in, what extra NE<lt>...E<gt> codes it accepts beyond
the ones described in the I<perlpod>.
=over
=item C<< $parser->accept_targets( I<SOMEVALUE> ) >>
As the parser sees sections like:
=for html <img src="fig1.jpg">
or
=begin html
<img src="fig1.jpg">
=end html
...the parser will ignore these sections unless your subclass has
specified that it wants to see sections targeted to "html" (or whatever
the formatter name is).
If you want to process all sections, even if they're not targeted for you,
call this before you start parsing:
$parser->accept_targets('*');
=item C<< $parser->accept_targets_as_text( I<SOMEVALUE> ) >>
This is like accept_targets, except that it specifies also that the
content of sections for this target should be treated as Pod text even
if the target name in "=for I<targetname>" doesn't start with a ":".
At time of writing, I don't think you'll need to use this.
=item C<< $parser->accept_codes( I<Codename>, I<Codename>... ) >>
This tells the parser that you accept additional formatting codes,
beyond just the standard ones (I B C L F S X, plus the two weird ones
you don't actually see in the parse tree, Z and E). For example, to also
accept codes "N", "R", and "W":
$parser->accept_codes( qw( N R W ) );
B<TODO: document how this interacts with =extend, and long element names>
=item C<< $parser->accept_directive_as_data( I<directive_name> ) >>
=item C<< $parser->accept_directive_as_verbatim( I<directive_name> ) >>
=item C<< $parser->accept_directive_as_processed( I<directive_name> ) >>
In the unlikely situation that you need to tell the parser that you will
accept additional directives ("=foo" things), you need to first set the
parser to treat its content as data (i.e., not really processed at
all), or as verbatim (mostly just expanding tabs), or as processed text
(parsing formatting codes like BE<lt>...E<gt>).
For example, to accept a new directive "=method", you'd presumably
use:
$parser->accept_directive_as_processed("method");
so that you could have Pod lines like:
=method I<$whatever> thing B<um>
Making up your own directives breaks compatibility with other Pod
formatters, in a way that using "=for I<target> ..." lines doesn't;
however, you may find this useful if you're making a Pod superset
format where you don't need to worry about compatibility.
=item C<< $parser->nbsp_for_S( I<BOOLEAN> ); >>
Setting this attribute to a true value (and by default it is false) will
turn "SE<lt>...E<gt>" sequences into sequences of words separated by
C<\xA0> (non-breaking space) characters. For example, it will take this:
I like S<Dutch apple pie>, don't you?
and treat it as if it were:
I like DutchE<nbsp>appleE<nbsp>pie, don't you?
This is handy for output formats that don't have anything quite like an
"SE<lt>...E<gt>" code, but which do have a code for non-breaking space.
There is currently no method for going the other way; but I can
probably provide one upon request.
=item C<< $parser->version_report() >>
This returns a string reporting the $VERSION value from your module (and
its classname) as well as the $VERSION value of Pod::Simple. Note that
L<perlpodspec> requires output formats (wherever possible) to note
this detail in a comment in the output format. For example, for
some kind of SGML output format:
print OUT "<!-- \n", $parser->version_report, "\n -->";
=item C<< $parser->pod_para_count() >>
This returns the count of Pod paragraphs seen so far.
=item C<< $parser->line_count() >>
This is the current line number being parsed. But you might find the
"line_number" event attribute more accurate, when it is present.
=item C<< $parser->nix_X_codes( I<SOMEVALUE> ) >>
This attribute, when set to a true value (and it is false by default)
ignores any "XE<lt>...E<gt>" sequences in the document being parsed.
Many formats don't actually use the content of these codes, so have
no reason to process them.
=item C<< $parser->keep_encoding_directive( I<SOMEVALUE> ) >>
This attribute, when set to a true value (it is false by default)
will keep C<=encoding> and its content in the event structure. Most
formats don't actually need to process the content of an C<=encoding>
directive, even when this directive sets the encoding and the
processor makes use of the encoding information. Indeed, it is
possible to know the encoding without processing the directive
content.
=item C<< $parser->merge_text( I<SOMEVALUE> ) >>
This attribute, when set to a true value (and it is false by default)
makes sure that only one event (or token, or node) will be created
for any single contiguous sequence of text. For example, consider
this somewhat contrived example:
I just LOVE Z<>hotE<32>apple pie!
When that is parsed and events are about to be called on it, it may
actually seem to be four different text events, one right after another:
one event for "I just LOVE ", one for "hot", one for " ", and one for
"apple pie!". But if you have merge_text on, then you're guaranteed
that it will be fired as one text event: "I just LOVE hot apple pie!".
=item C<< $parser->code_handler( I<CODE_REF> ) >>
This specifies code that should be called when a code line is seen
(i.e., a line outside of the Pod). Normally this is undef, meaning
that no code should be called. If you provide a routine, it should
start out like this:
sub get_code_line { # or whatever you'll call it
my($line, $line_number, $parser) = @_;
...
}
Note, however, that sometimes the Pod events aren't processed in exactly
the same order as the code lines are -- i.e., if you have a file with
Pod, then code, then more Pod, sometimes the code will be processed (via
whatever you have code_handler call) before the all of the preceding Pod
has been processed.
=item C<< $parser->cut_handler( I<CODE_REF> ) >>
This is just like the code_handler attribute, except that it's for
"=cut" lines, not code lines. The same caveats apply. "=cut" lines are
unlikely to be interesting, but this is included for completeness.
=item C<< $parser->pod_handler( I<CODE_REF> ) >>
This is just like the code_handler attribute, except that it's for
"=pod" lines, not code lines. The same caveats apply. "=pod" lines are
unlikely to be interesting, but this is included for completeness.
=item C<< $parser->whiteline_handler( I<CODE_REF> ) >>
This is just like the code_handler attribute, except that it's for
lines that are seemingly blank but have whitespace (" " and/or "\t") on them,
not code lines. The same caveats apply. These lines are unlikely to be
interesting, but this is included for completeness.
=item C<< $parser->whine( I<linenumber>, I<complaint string> ) >>
This notes a problem in the Pod, which will be reported in the "Pod
Errors" section of the document and/or sent to STDERR, depending on the
values of the attributes C<no_whining>, C<no_errata_section>, and
C<complain_stderr>.
=item C<< $parser->scream( I<linenumber>, I<complaint string> ) >>
This notes an error like C<whine> does, except that it is not
suppressible with C<no_whining>. This should be used only for very
serious errors.
=item C<< $parser->source_dead(1) >>
This aborts parsing of the current document, by switching on the flag
that indicates that EOF has been seen. In particularly drastic cases,
you might want to do this. It's rather nicer than just calling
C<die>!
=item C<< $parser->hide_line_numbers( I<SOMEVALUE> ) >>
Some subclasses that indiscriminately dump event attributes (well,
except for ones beginning with "~") can use this object attribute for
refraining to dump the "start_line" attribute.
=item C<< $parser->no_whining( I<SOMEVALUE> ) >>
This attribute, if set to true, will suppress reports of non-fatal
error messages. The default value is false, meaning that complaints
I<are> reported. How they get reported depends on the values of
the attributes C<no_errata_section> and C<complain_stderr>.
=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >>
This attribute, if set to true, will suppress generation of an errata
section. The default value is false -- i.e., an errata section will be
generated.
=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >>
This attribute, if set to true will send complaints to STDERR. The
default value is false -- i.e., complaints do not go to STDERR.
=item C<< $parser->bare_output( I<SOMEVALUE> ) >>
Some formatter subclasses use this as a flag for whether output should
have prologue and epilogue code omitted. For example, setting this to
true for an HTML formatter class should omit the
"<html><head><title>...</title><body>..." prologue and the
"</body></html>" epilogue.
If you want to set this to true, you should probably also set
C<no_whining> or at least C<no_errata_section> to true.
=item C<< $parser->preserve_whitespace( I<SOMEVALUE> ) >>
If you set this attribute to a true value, the parser will try to
preserve whitespace in the output. This means that such formatting
conventions as two spaces after periods will be preserved by the parser.
This is primarily useful for output formats that treat whitespace as
significant (such as text or *roff, but not HTML).
=item C<< $parser->parse_empty_lists( I<SOMEVALUE> ) >>
If this attribute is set to true, the parser will not ignore empty
C<=over>/C<=back> blocks. The type of C<=over> will be I<empty>, documented
above, L<events with an element_name of over-empty>.
=back
=head1 SEE ALSO
L<Pod::Simple> -- event-based Pod-parsing framework
L<Pod::Simple::Methody> -- like Pod::Simple, but each sort of event
calls its own method (like C<start_head3>)
L<Pod::Simple::PullParser> -- a Pod-parsing framework like Pod::Simple,
but with a token-stream interface
L<Pod::Simple::SimpleTree> -- a Pod-parsing framework like Pod::Simple,
but with a tree interface
L<Pod::Simple::Checker> -- a simple Pod::Simple subclass that reads
documents, and then makes a plaintext report of any errors found in the
document
L<Pod::Simple::DumpAsXML> -- for dumping Pod documents as tidily
indented XML, showing each event on its own line
L<Pod::Simple::XMLOutStream> -- dumps a Pod document as XML (without
introducing extra whitespace as Pod::Simple::DumpAsXML does).
L<Pod::Simple::DumpAsText> -- for dumping Pod documents as tidily
indented text, showing each event on its own line
L<Pod::Simple::LinkSection> -- class for objects representing the values
of the TODO and TODO attributes of LE<lt>...E<gt> elements
L<Pod::Escapes> -- the module that Pod::Simple uses for evaluating
EE<lt>...E<gt> content
L<Pod::Simple::Text> -- a simple plaintext formatter for Pod
L<Pod::Simple::TextContent> -- like Pod::Simple::Text, but
makes no effort for indent or wrap the text being formatted
L<Pod::Simple::HTML> -- a simple HTML formatter for Pod
L<perlpod|perlpod>
L<perlpodspec|perlpodspec>
L<perldoc>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=for notes
Hm, my old podchecker version (1.2) says:
*** WARNING: node 'http://search.cpan.org/' contains non-escaped | or / at line 38 in file Subclassing.pod
*** WARNING: node 'http://lists.perl.org/showlist.cgi?name=pod-people' contains non-escaped | or / at line 41 in file Subclassing.pod
Yes, L<...> is hard.
=cut
PK Ʈ[�?GK�
�
Simple/TiedOutFH.pmnu �[���
use strict;
package Pod::Simple::TiedOutFH;
use Symbol ('gensym');
use Carp ();
use vars qw($VERSION );
$VERSION = '3.35';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub handle_on { # some horrible frightening things are encapsulated in here
my $class = shift;
$class = ref($class) || $class;
Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_;
my $x = (defined($_[0]) and ref($_[0]))
? $_[0]
: ( \( $_[0] ) )[0]
;
$$x = '' unless defined $$x;
#Pod::Simple::DEBUG and print STDERR "New $class handle on $x = \"$$x\"\n";
my $new = gensym();
tie *$new, $class, $x;
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub TIEHANDLE { # Ties to just a scalar ref
my($class, $scalar_ref) = @_;
$$scalar_ref = '' unless defined $$scalar_ref;
return bless \$scalar_ref, ref($class) || $class;
}
sub PRINT {
my $it = shift;
foreach my $x (@_) { $$$it .= $x }
#Pod::Simple::DEBUG > 10 and print STDERR " appended to $$it = \"$$$it\"\n";
return 1;
}
sub FETCH {
return ${$_[0]};
}
sub PRINTF {
my $it = shift;
my $format = shift;
$$$it .= sprintf $format, @_;
return 1;
}
sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number
sub CLOSE { 1 }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
Chole
* 1 large red onion
* 2 tomatillos
* 4 or 5 roma tomatoes (optionally with the pulp discarded)
* 1 tablespoons chopped ginger root (or more, to taste)
* 2 tablespoons canola oil (or vegetable oil)
* 1 tablespoon garam masala
* 1/2 teaspoon red chili powder, or to taste
* Salt, to taste (probably quite a bit)
* 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed
* juice of one smallish lime
* a dash of balsamic vinegar (to taste)
* cooked rice, preferably long-grain white rice (whether plain,
basmati rice, jasmine rice, or even a mild pilaf)
In a blender or food processor, puree the onions, tomatoes, tomatillos,
and ginger root. You can even do it with a Braun hand "mixer", if you
chop things finer to start with, and work at it.
In a saucepan set over moderate heat, warm the oil until hot.
Add the puree and the balsamic vinegar, and cook, stirring occasionally,
for 20 to 40 minutes. (Cooking it longer will make it sweeter.)
Add the Garam Masala, chili powder, and cook, stirring occasionally, for
5 minutes.
Add the salt and chick peas and cook, stirring, until heated through.
Stir in the lime juice, and optionally one or two teaspoons of tahini.
You can let it simmer longer, depending on how much softer you want the
garbanzos to get.
Serve over rice, like a curry.
Yields 5 to 7 servings.
PK Ʈ[o��� � Simple/LinkSection.pmnu �[���
require 5;
package Pod::Simple::LinkSection;
# Based somewhat dimly on Array::Autojoin
use vars qw($VERSION );
$VERSION = '3.35';
use strict;
use Pod::Simple::BlackBox;
use vars qw($VERSION );
$VERSION = '3.35';
use overload( # So it'll stringify nice
'""' => \&Pod::Simple::BlackBox::stringify_lol,
'bool' => \&Pod::Simple::BlackBox::stringify_lol,
# '.=' => \&tack_on, # grudgingly support
'fallback' => 1, # turn on cleverness
);
sub tack_on {
$_[0] = ['', {}, "$_[0]" ];
return $_[0][2] .= $_[1];
}
sub as_string {
goto &Pod::Simple::BlackBox::stringify_lol;
}
sub stringify {
goto &Pod::Simple::BlackBox::stringify_lol;
}
sub new {
my $class = shift;
$class = ref($class) || $class;
my $new;
if(@_ == 1) {
if (!ref($_[0] || '')) { # most common case: one bare string
return bless ['', {}, $_[0] ], $class;
} elsif( ref($_[0] || '') eq 'ARRAY') {
$new = [ @{ $_[0] } ];
} else {
Carp::croak( "$class new() doesn't know to clone $new" );
}
} else { # misc stuff
$new = [ '', {}, @_ ];
}
# By now it's a treelet: [ 'foo', {}, ... ]
foreach my $x (@$new) {
if(ref($x || '') eq 'ARRAY') {
$x = $class->new($x); # recurse
} elsif(ref($x || '') eq 'HASH') {
$x = { %$x };
}
# otherwise leave it.
}
return bless $new, $class;
}
# Not much in this class is likely to be link-section specific --
# but it just so happens that link-sections are about the only treelets
# that are exposed to the user.
1;
__END__
# TODO: let it be an option whether a given subclass even wants little treelets?
__END__
=head1 NAME
Pod::Simple::LinkSection -- represent "section" attributes of L codes
=head1 SYNOPSIS
# a long story
=head1 DESCRIPTION
This class is not of interest to general users.
Pod::Simple uses this class for representing the value of the
"section" attribute of "L" start-element events. Most applications
can just use the normal stringification of objects of this class;
they stringify to just the text content of the section,
such as "foo" for
C<< LZ<><Stuff/foo> >>, and "bar" for
C<< LZ<><Stuff/bIZ<><ar>> >>.
However, anyone particularly interested in getting the full value of
the treelet, can just traverse the content of the treeleet
@$treelet_object. To wit:
% perl -MData::Dumper -e
"use base qw(Pod::Simple::Methody);
sub start_L { print Dumper($_[1]{'section'} ) }
__PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
"
Output:
$VAR1 = bless( [
'',
{},
'b',
bless( [
'I',
{},
'ar'
], 'Pod::Simple::LinkSection' ),
'baz'
], 'Pod::Simple::LinkSection' );
But stringify it and you get just the text content:
% perl -MData::Dumper -e
"use base qw(Pod::Simple::Methody);
sub start_L { print Dumper( '' . $_[1]{'section'} ) }
__PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
"
Output:
$VAR1 = 'barbaz';
=head1 SEE ALSO
L<Pod::Simple>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2004 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK Ʈ[�h��� � Simple/TranscodeSmart.pmnu �[���
require 5;
use 5.008;
## Anything before 5.8.0 is GIMPY!
## This module is to be use()'d only by Pod::Simple::Transcode
package Pod::Simple::TranscodeSmart;
use strict;
use Pod::Simple;
require Encode;
use vars qw($VERSION );
$VERSION = '3.35';
sub is_dumb {0}
sub is_smart {1}
sub all_encodings {
return Encode::->encodings(':all');
}
sub encoding_is_available {
return Encode::resolve_alias($_[1]);
}
sub encmodver {
return "Encode.pm v" .($Encode::VERSION || '?');
}
sub make_transcoder {
my $e = Encode::find_encoding($_[1]);
die "WHAT ENCODING!?!?" unless $e;
my $x;
return sub {
foreach $x (@_) {
$x = $e->decode($x) unless Encode::is_utf8($x);
}
return;
};
}
1;
PK Ʈ[�U<�� � Simple/DumpAsText.pmnu �[���
require 5;
package Pod::Simple::DumpAsText;
$VERSION = '3.35';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
use strict;
use Carp ();
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->accept_codes('VerbatimFormatted');
$new->keep_encoding_directive(1);
return $new;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_element_start {
# ($self, $element_name, $attr_hash_r)
my $fh = $_[0]{'output_fh'};
my($key, $value);
DEBUG and print STDERR "++ $_[1]\n";
print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n";
$_[0]{'indent'}++;
while(($key,$value) = each %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_perly_escape($key);
_perly_escape($value);
printf $fh qq{%s \\ "%s" => "%s"\n},
' ' x ($_[0]{'indent'} || 0), $key, $value;
}
}
return;
}
sub _handle_text {
DEBUG and print STDERR "== \"$_[1]\"\n";
if(length $_[1]) {
my $indent = ' ' x $_[0]{'indent'};
my $text = $_[1];
_perly_escape($text);
$text =~ # A not-totally-brilliant wrapping algorithm:
s/(
[^\n]{55} # Snare some characters from a line
[^\n\ ]{0,50} # and finish any current word
)
\ {1,10}(?!\n) # capture some spaces not at line-end
/$1"\n$indent . "/gx # => line-break here
;
print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n";
}
return;
}
sub _handle_element_end {
DEBUG and print STDERR "-- $_[1]\n";
print {$_[0]{'output_fh'}}
' ' x --$_[0]{'indent'}, "--", $_[1], "\n";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _perly_escape {
foreach my $x (@_) {
$x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg;
# Escape things very cautiously:
$x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg;
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::DumpAsText -- dump Pod-parsing events as text
=head1 SYNOPSIS
perl -MPod::Simple::DumpAsText -e \
"exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is for dumping, as text, the events gotten from parsing a Pod
document. This class is of interest to people writing Pod formatters
based on Pod::Simple. It is useful for seeing exactly what events you
get out of some Pod that you feed in.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple::DumpAsXML>
L<Pod::Simple>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK Ʈ[����W �W
Simple/RTF.pmnu �[���
require 5;
package Pod::Simple::RTF;
#sub DEBUG () {4};
#sub Pod::Simple::DEBUG () {4};
#sub Pod::Simple::PullParser::DEBUG () {4};
use strict;
use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
$VERSION = '3.35';
use Pod::Simple::PullParser ();
BEGIN {@ISA = ('Pod::Simple::PullParser')}
use Carp ();
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
$WRAP = 1 unless defined $WRAP;
# These are broken for early Perls on EBCDIC; they could be fixed to work
# better there, but not worth it. These are part of a larger [...] class, so
# are just the strings to substitute into it, as opposed to compiled patterns.
my $cntrl = '[:cntrl:]';
$cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/";
my $not_ascii = '[:^ascii:]';
$not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/";
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _openclose {
return map {;
m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
( $1, "{\\$2\n", "/$1", "}" );
} @_;
}
my @_to_accept;
%Tagmap = (
# 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
_openclose(
'B=cs18\b',
'I=cs16\i',
'C=cs19\f1\lang1024\noproof',
'F=cs17\i\lang1024\noproof',
'VerbatimI=cs26\i',
'VerbatimB=cs27\b',
'VerbatimBI=cs28\b\i',
map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
qw[
underline=ul smallcaps=scaps shadow=shad
superscript=super subscript=sub strikethrough=strike
outline=outl emboss=embo engrave=impr
dotted-underline=uld dash-underline=uldash
dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd
double-underline=uldb thick-underline=ulth
word-underline=ulw wave-underline=ulwave
]
# But no double-strikethrough, because MSWord can't agree with the
# RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
),
# Bit of a hack here:
'L=pod' => '{\cs22\i'."\n",
'L=url' => '{\cs23\i'."\n",
'L=man' => '{\cs24\i'."\n",
'/L' => '}',
'Data' => "\n",
'/Data' => "\n",
'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
'/Verbatim' => "\n\\par}\n",
'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
'/VerbatimFormatted' => "\n\\par}\n",
'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n",
'/Para' => "\n\\par}\n",
'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
'/head1' => "\n}\\par}\n",
'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
'/head2' => "\n}\\par}\n",
'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
'/head3' => "\n}\\par}\n",
'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
'/head4' => "\n}\\par}\n",
# wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
'/item-bullet' => "\n\\par}\n",
'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
'/item-number' => "\n\\par}\n",
'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
'/item-text' => "\n\\par}\n",
# we don't need any styles for over-* and /over-*
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $new = shift->SUPER::new(@_);
$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->accept_targets( 'rtf', 'RTF' );
$new->{'Tagmap'} = {%Tagmap};
$new->accept_codes(@_to_accept);
$new->accept_codes('VerbatimFormatted');
DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n";
$new->doc_lang(
( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
: ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
# yes, tolerate hex!
: ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
# yes, tolerate even more hex!
: '1033'
);
$new->head1_halfpoint_size(32);
$new->head2_halfpoint_size(28);
$new->head3_halfpoint_size(25);
$new->head4_halfpoint_size(22);
$new->codeblock_halfpoint_size(18);
$new->header_halfpoint_size(17);
$new->normal_halfpoint_size(25);
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
__PACKAGE__->_accessorize(
'doc_lang',
'head1_halfpoint_size',
'head2_halfpoint_size',
'head3_halfpoint_size',
'head4_halfpoint_size',
'codeblock_halfpoint_size',
'header_halfpoint_size',
'normal_halfpoint_size',
'no_proofing_exemptions',
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub run {
my $self = $_[0];
return $self->do_middle if $self->bare_output;
return
$self->do_beginning && $self->do_middle && $self->do_end;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub do_middle { # the main work
my $self = $_[0];
my $fh = $self->{'output_fh'};
my($token, $type, $tagname, $scratch);
my @stack;
my @indent_stack;
$self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
while($token = $self->get_token) {
if( ($type = $token->type) eq 'text' ) {
if( $self->{'rtfverbatim'} ) {
DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n";
rtf_esc_codely($scratch = $token->text);
print $fh $scratch;
next;
}
DEBUG > 1 and print STDERR " $type " , $token->text, "\n";
$scratch = $token->text;
$scratch =~ tr/\t\cb\cc/ /d;
$self->{'no_proofing_exemptions'} or $scratch =~
s/(?:
^
|
(?<=[\r\n\t "\[\<\(])
) # start on whitespace, sequence-start, or quote
( # something looking like a Perl token:
(?:
[\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc.
)
|
# or starting alpha, but containing anything strange:
(?:
[a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+
)
)
/\cb$1\cc/xsg
;
rtf_esc($scratch);
$scratch =~
s/(
[^\r\n]{65} # Snare 65 characters from a line
[^\r\n ]{0,50} # and finish any current word
)
(\ {1,10})(?![\r\n]) # capture some spaces not at line-end
/$1$2\n/gx # and put a NL before those spaces
if $WRAP;
# This may wrap at well past the 65th column, but not past the 120th.
print $fh $scratch;
} elsif( $type eq 'start' ) {
DEBUG > 1 and print STDERR " +$type ",$token->tagname,
" (", map("<$_> ", %{$token->attr_hash}), ")\n";
if( ($tagname = $token->tagname) eq 'Verbatim'
or $tagname eq 'VerbatimFormatted'
) {
++$self->{'rtfverbatim'};
my $next = $self->get_token;
next unless defined $next;
my $line_count = 1;
if($next->type eq 'text') {
my $t = $next->text_r;
while( $$t =~ m/$/mg ) {
last if ++$line_count > 15; # no point in counting further
}
DEBUG > 3 and print STDERR " verbatim line count: $line_count\n";
}
$self->unget_token($next);
$self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
} elsif( $tagname =~ m/^item-/s ) {
my @to_unget;
my $text_count_here = 0;
$self->{'rtfitemkeepn'} = '';
# Some heuristics to stop item-*'s functioning as subheadings
# from getting split from the things they're subheadings for.
#
# It's not terribly pretty, but it really does make things pretty.
#
while(1) {
push @to_unget, $self->get_token;
pop(@to_unget), last unless defined $to_unget[-1];
# Erroneously used to be "unshift" instead of pop! Adds instead
# of removes, and operates on the beginning instead of the end!
if($to_unget[-1]->type eq 'text') {
if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
DEBUG > 1 and print STDERR " item-* is too long to be keepn'd.\n";
last;
}
} elsif (@to_unget > 1 and
$to_unget[-2]->type eq 'end' and
$to_unget[-2]->tagname =~ m/^item-/s
) {
# Bail out here, after setting rtfitemkeepn yea or nay.
$self->{'rtfitemkeepn'} = '\keepn' if
$to_unget[-1]->type eq 'start' and
$to_unget[-1]->tagname eq 'Para';
DEBUG > 1 and printf STDERR " item-* before %s(%s) %s keepn'd.\n",
$to_unget[-1]->type,
$to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
$self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
last;
} elsif (@to_unget > 40) {
DEBUG > 1 and print STDERR " item-* now has too many tokens (",
scalar(@to_unget),
(DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
") to be keepn'd.\n";
last; # give up
}
# else keep while'ing along
}
# Now put it aaaaall back...
$self->unget_token(@to_unget);
} elsif( $tagname =~ m/^over-/s ) {
push @stack, $1;
push @indent_stack,
int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n";
$self->{'rtfindent'} += $indent_stack[-1];
} elsif ($tagname eq 'L') {
$tagname .= '=' . ($token->attr('type') || 'pod');
} elsif ($tagname eq 'Data') {
my $next = $self->get_token;
next unless defined $next;
unless( $next->type eq 'text' ) {
$self->unget_token($next);
next;
}
DEBUG and print STDERR " raw text ", $next->text, "\n";
printf $fh "\n" . $next->text . "\n";
next;
}
defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
$scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
print $fh $scratch;
if ($tagname eq 'item-number') {
print $fh $token->attr('number'), ". \n";
} elsif ($tagname eq 'item-bullet') {
print $fh "\\'", ord("_"), "\n";
#for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
}
} elsif( $type eq 'end' ) {
DEBUG > 1 and print STDERR " -$type ",$token->tagname,"\n";
if( ($tagname = $token->tagname) =~ m/^over-/s ) {
DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n";
$self->{'rtfindent'} -= pop @indent_stack;
pop @stack;
} elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
--$self->{'rtfverbatim'};
}
defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
$scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
print $fh $scratch;
}
}
return 1;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub do_beginning {
my $self = $_[0];
my $fh = $self->{'output_fh'};
return print $fh join '',
$self->doc_init,
$self->font_table,
$self->stylesheet,
$self->color_table,
$self->doc_info,
$self->doc_start,
"\n"
;
}
sub do_end {
my $self = $_[0];
my $fh = $self->{'output_fh'};
return print $fh '}'; # that should do it
}
###########################################################################
sub stylesheet {
return sprintf <<'END',
{\stylesheet
{\snext0 Normal;}
{\*\cs10 \additive Default Paragraph Font;}
{\*\cs16 \additive \i \sbasedon10 pod-I;}
{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
{\*\cs18 \additive \b \sbasedon10 pod-B;}
{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
}
END
$_[0]->codeblock_halfpoint_size(),
$_[0]->head1_halfpoint_size(),
$_[0]->head2_halfpoint_size(),
$_[0]->head3_halfpoint_size(),
$_[0]->head4_halfpoint_size(),
;
}
###########################################################################
# Override these as necessary for further customization
sub font_table {
return <<'END'; # text font, code font, heading font
{\fonttbl
{\f0\froman Times New Roman;}
{\f1\fmodern Courier New;}
{\f2\fswiss Arial;}
}
END
}
sub doc_init {
return <<'END';
{\rtf1\ansi\deff0
END
}
sub color_table {
return <<'END';
{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
END
}
sub doc_info {
my $self = $_[0];
my $class = ref($self) || $self;
my $tag = __PACKAGE__ . ' ' . $VERSION;
unless($class eq __PACKAGE__) {
$tag = " ($tag)";
$tag = " v" . $self->VERSION . $tag if defined $self->VERSION;
$tag = $class . $tag;
}
return sprintf <<'END',
{\info{\doccomm
%s
using %s v%s
under Perl v%s at %s GMT}
{\author [see doc]}{\company [see doc]}{\operator [see doc]}
}
END
# None of the following things should need escaping, I dare say!
$tag,
$ISA[0], $ISA[0]->VERSION(),
$], scalar(gmtime),
;
}
sub doc_start {
my $self = $_[0];
my $title = $self->get_short_title();
DEBUG and print STDERR "Short Title: <$title>\n";
$title .= ' ' if length $title;
$title =~ s/ *$/ /s;
$title =~ s/^ //s;
$title =~ s/ $/, /s;
# make sure it ends in a comma and a space, unless it's 0-length
my $is_obviously_module_name;
$is_obviously_module_name = 1
if $title =~ m/^\S+$/s and $title =~ m/::/s;
# catches the most common case, at least
DEBUG and print STDERR "Title0: <$title>\n";
$title = rtf_esc($title);
DEBUG and print STDERR "Title1: <$title>\n";
$title = '\lang1024\noproof ' . $title
if $is_obviously_module_name;
return sprintf <<'END',
\deflang%s\plain\lang%s\widowctrl
{\header\pard\qr\plain\f2\fs%s
%s
p.\chpgn\par}
\fs%s
END
($self->doc_lang) x 2,
$self->header_halfpoint_size,
$title,
$self->normal_halfpoint_size,
;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#-------------------------------------------------------------------------
use integer;
sub rtf_esc {
my $x; # scratch
if(!defined wantarray) { # void context: alter in-place!
for(@_) {
s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
}
return;
} elsif(wantarray) { # return an array
return map {; ($x = $_) =~
s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
$x;
} @_;
} else { # return a single scalar
($x = ((@_ == 1) ? $_[0] : join '', @_)
) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
# Escape \, {, }, -, control chars, and 7f-ff.
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
return $x;
}
}
sub rtf_esc_codely {
# Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts.
# We don't want to change the "-" to hard-hyphen, because we want to
# be able to paste this into a file and run it without there being
# dire screaming about the mysterious hard-hyphen character (which
# looks just like a normal dash character).
my $x; # scratch
if(!defined wantarray) { # void context: alter in-place!
for(@_) {
s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
}
return;
} elsif(wantarray) { # return an array
return map {; ($x = $_) =~
s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
$x;
} @_;
} else { # return a single scalar
($x = ((@_ == 1) ? $_[0] : join '', @_)
) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
# Escape \, {, }, -, control chars, and 7f-ff.
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
return $x;
}
}
%Escape = (
(($] lt 5.007_003) # Broken for non-ASCII on early Perls
? (map( (chr($_),chr($_)), # things not apparently needing escaping
0x20 .. 0x7E ),
map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))
: (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))),
0x20 .. 0x7E ),
map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))),
0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))),
# We get to escape out 'F' so that we can send RTF files thru the mail
# without the slightest worry that paragraphs beginning with "From"
# will get munged.
# And some refinements:
"\r" => "\n",
"\cj" => "\n",
"\n" => "\n\\line ",
"\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
"\f" => "\n\\page\n", # Formfeed
"-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
$Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space
$Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen
# CRAZY HACKS:
"\n" => "\\line\n",
"\r" => "\n",
"\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1
"\cc" => "}",
);
1;
__END__
=head1 NAME
Pod::Simple::RTF -- format Pod as RTF
=head1 SYNOPSIS
perl -MPod::Simple::RTF -e \
"exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
thingy.pod > thingy.rtf
=head1 DESCRIPTION
This class is a formatter that takes Pod and renders it as RTF, good for
viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 FORMAT CONTROL ATTRIBUTES
You can set these attributes on the parser object before you
call C<parse_file> (or a similar method) on it:
=over
=item $parser->head1_halfpoint_size( I<halfpoint_integer> );
=item $parser->head2_halfpoint_size( I<halfpoint_integer> );
=item $parser->head3_halfpoint_size( I<halfpoint_integer> );
=item $parser->head4_halfpoint_size( I<halfpoint_integer> );
These methods set the size (in half-points, like 52 for 26-point)
that these heading levels will appear as.
=item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
This method sets the size (in half-points, like 21 for 10.5-point)
that codeblocks ("verbatim sections") will appear as.
=item $parser->header_halfpoint_size( I<halfpoint_integer> );
This method sets the size (in half-points, like 15 for 7.5-point)
that the header on each page will appear in. The header
is usually just "I<modulename> p. I<pagenumber>".
=item $parser->normal_halfpoint_size( I<halfpoint_integer> );
This method sets the size (in half-points, like 26 for 13-point)
that normal paragraphic text will appear in.
=item $parser->no_proofing_exemptions( I<true_or_false> );
Set this value to true if you don't want the formatter to try
putting a hidden code on all Perl symbols (as best as it can
notice them) that labels them as being not in English, and
so not worth spellchecking.
=item $parser->doc_lang( I<microsoft_decimal_language_code> )
This sets the language code to tag this document as being in. By
default, it is currently the value of the environment variable
C<RTFDEFLANG>, or if that's not set, then the value
1033 (for US English).
Setting this appropriately is useful if you want to use the RTF
to spellcheck, and/or if you want it to hyphenate right.
Here are some notable values:
1033 US English
2057 UK English
3081 Australia English
4105 Canada English
1034 Spain Spanish
2058 Mexico Spanish
1031 Germany German
1036 France French
3084 Canada French
1035 Finnish
1044 Norwegian (Bokmal)
2068 Norwegian (Nynorsk)
=back
If you are particularly interested in customizing this module's output
even more, see the source and/or write to me.
=head1 SEE ALSO
L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
L<RTF::Generator>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK Ǯ[���d �d Simple/PullParser.pmnu �[��� require 5;
package Pod::Simple::PullParser;
$VERSION = '3.35';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
use strict;
use Carp ();
use Pod::Simple::PullParserStartToken;
use Pod::Simple::PullParserEndToken;
use Pod::Simple::PullParserTextToken;
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
__PACKAGE__->_accessorize(
'source_fh', # the filehandle we're reading from
'source_scalar_ref', # the scalarref we're reading from
'source_arrayref', # the arrayref we're reading from
);
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And here is how we implement a pull-parser on top of a push-parser...
sub filter {
my($self, $source) = @_;
$self = $self->new unless ref $self;
$source = *STDIN{IO} unless defined $source;
$self->set_source($source);
$self->output_fh(*STDOUT{IO});
$self->run; # define run() in a subclass if you want to use filter()!
return $self;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub parse_string_document {
my $this = shift;
$this->set_source(\ $_[0]);
$this->run;
}
sub parse_file {
my($this, $filename) = @_;
$this->set_source($filename);
$this->run;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# In case anyone tries to use them:
sub run {
use Carp ();
if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed!
Carp::croak "You can call run() only on subclasses of "
. __PACKAGE__;
} else {
Carp::croak join '',
"You can't call run() because ",
ref($_[0]) || $_[0], " didn't define a run() method";
}
}
sub parse_lines {
use Carp ();
Carp::croak "Use set_source with ", __PACKAGE__,
" and subclasses, not parse_lines";
}
sub parse_line {
use Carp ();
Carp::croak "Use set_source with ", __PACKAGE__,
" and subclasses, not parse_line";
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
die "Couldn't construct for $class" unless $self;
$self->{'token_buffer'} ||= [];
$self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken';
$self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken';
$self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken';
DEBUG > 1 and print STDERR "New pullparser object: $self\n";
return $self;
}
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
sub get_token {
my $self = shift;
DEBUG > 1 and print STDERR "\nget_token starting up on $self.\n";
DEBUG > 2 and print STDERR " Items in token-buffer (",
scalar( @{ $self->{'token_buffer'} } ) ,
") :\n", map(
" " . $_->dump . "\n", @{ $self->{'token_buffer'} }
),
@{ $self->{'token_buffer'} } ? '' : ' (no tokens)',
"\n"
;
until( @{ $self->{'token_buffer'} } ) {
DEBUG > 3 and print STDERR "I need to get something into my empty token buffer...\n";
if($self->{'source_dead'}) {
DEBUG and print STDERR "$self 's source is dead.\n";
push @{ $self->{'token_buffer'} }, undef;
} elsif(exists $self->{'source_fh'}) {
my @lines;
my $fh = $self->{'source_fh'}
|| Carp::croak('You have to call set_source before you can call get_token');
DEBUG and print STDERR "$self 's source is filehandle $fh.\n";
# Read those many lines at a time
for(my $i = Pod::Simple::MANY_LINES; $i--;) {
DEBUG > 3 and print STDERR " Fetching a line from source filehandle $fh...\n";
local $/ = $Pod::Simple::NL;
push @lines, scalar(<$fh>); # readline
DEBUG > 3 and print STDERR " Line is: ",
defined($lines[-1]) ? $lines[-1] : "<undef>\n";
unless( defined $lines[-1] ) {
DEBUG and print STDERR "That's it for that source fh! Killing.\n";
delete $self->{'source_fh'}; # so it can be GC'd
last;
}
# but pass thru the undef, which will set source_dead to true
# TODO: look to see if $lines[-1] is =encoding, and if so,
# do horribly magic things
}
if(DEBUG > 8) {
print STDERR "* I've gotten ", scalar(@lines), " lines:\n";
foreach my $l (@lines) {
if(defined $l) {
print STDERR " line {$l}\n";
} else {
print STDERR " line undef\n";
}
}
print STDERR "* end of ", scalar(@lines), " lines\n";
}
$self->SUPER::parse_lines(@lines);
} elsif(exists $self->{'source_arrayref'}) {
DEBUG and print STDERR "$self 's source is arrayref $self->{'source_arrayref'}, with ",
scalar(@{$self->{'source_arrayref'}}), " items left in it.\n";
DEBUG > 3 and print STDERR " Fetching ", Pod::Simple::MANY_LINES, " lines.\n";
$self->SUPER::parse_lines(
splice @{ $self->{'source_arrayref'} },
0,
Pod::Simple::MANY_LINES
);
unless( @{ $self->{'source_arrayref'} } ) {
DEBUG and print STDERR "That's it for that source arrayref! Killing.\n";
$self->SUPER::parse_lines(undef);
delete $self->{'source_arrayref'}; # so it can be GC'd
}
# to make sure that an undef is always sent to signal end-of-stream
} elsif(exists $self->{'source_scalar_ref'}) {
DEBUG and print STDERR "$self 's source is scalarref $self->{'source_scalar_ref'}, with ",
length(${ $self->{'source_scalar_ref'} }) -
(pos(${ $self->{'source_scalar_ref'} }) || 0),
" characters left to parse.\n";
DEBUG > 3 and print STDERR " Fetching a line from source-string...\n";
if( ${ $self->{'source_scalar_ref'} } =~
m/([^\n\r]*)((?:\r?\n)?)/g
) {
#print(">> $1\n"),
$self->SUPER::parse_lines($1)
if length($1) or length($2)
or pos( ${ $self->{'source_scalar_ref'} })
!= length( ${ $self->{'source_scalar_ref'} });
# I.e., unless it's a zero-length "empty line" at the very
# end of "foo\nbar\n" (i.e., between the \n and the EOS).
} else { # that's the end. Byebye
$self->SUPER::parse_lines(undef);
delete $self->{'source_scalar_ref'};
DEBUG and print STDERR "That's it for that source scalarref! Killing.\n";
}
} else {
die "What source??";
}
}
DEBUG and print STDERR "get_token about to return ",
Pod::Simple::pretty( @{$self->{'token_buffer'}}
? $self->{'token_buffer'}[-1] : undef
), "\n";
return shift @{$self->{'token_buffer'}}; # that's an undef if empty
}
sub unget_token {
my $self = shift;
DEBUG and print STDERR "Ungetting ", scalar(@_), " tokens: ",
@_ ? "@_\n" : "().\n";
foreach my $t (@_) {
Carp::croak "Can't unget that, because it's not a token -- it's undef!"
unless defined $t;
Carp::croak "Can't unget $t, because it's not a token -- it's a string!"
unless ref $t;
Carp::croak "Can't unget $t, because it's not a token object!"
unless UNIVERSAL::can($t, 'type');
}
unshift @{$self->{'token_buffer'}}, @_;
DEBUG > 1 and print STDERR "Token buffer now has ",
scalar(@{$self->{'token_buffer'}}), " items in it.\n";
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# $self->{'source_filename'} = $source;
sub set_source {
my $self = shift @_;
return $self->{'source_fh'} unless @_;
Carp::croak("Cannot assign new source to pull parser; create a new instance, instead")
if $self->{'source_fh'} || $self->{'source_scalar_ref'} || $self->{'source_arrayref'};
my $handle;
if(!defined $_[0]) {
Carp::croak("Can't use empty-string as a source for set_source");
} elsif(ref(\( $_[0] )) eq 'GLOB') {
$self->{'source_filename'} = '' . ($handle = $_[0]);
DEBUG and print STDERR "$self 's source is glob $_[0]\n";
# and fall thru
} elsif(ref( $_[0] ) eq 'SCALAR') {
$self->{'source_scalar_ref'} = $_[0];
DEBUG and print STDERR "$self 's source is scalar ref $_[0]\n";
return;
} elsif(ref( $_[0] ) eq 'ARRAY') {
$self->{'source_arrayref'} = $_[0];
DEBUG and print STDERR "$self 's source is array ref $_[0]\n";
return;
} elsif(ref $_[0]) {
$self->{'source_filename'} = '' . ($handle = $_[0]);
DEBUG and print STDERR "$self 's source is fh-obj $_[0]\n";
} elsif(!length $_[0]) {
Carp::croak("Can't use empty-string as a source for set_source");
} else { # It's a filename!
DEBUG and print STDERR "$self 's source is filename $_[0]\n";
{
local *PODSOURCE;
open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!";
$handle = *PODSOURCE{IO};
}
$self->{'source_filename'} = $_[0];
DEBUG and print STDERR " Its name is $_[0].\n";
# TODO: file-discipline things here!
}
$self->{'source_fh'} = $handle;
DEBUG and print STDERR " Its handle is $handle\n";
return 1;
}
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
sub get_title_short { shift->get_short_title(@_) } # alias
sub get_short_title {
my $title = shift->get_title(@_);
$title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s;
# turn "Foo::Bar -- bars for your foo" into "Foo::Bar"
return $title;
}
sub get_title { shift->_get_titled_section(
'NAME', max_token => 50, desperate => 1, @_)
}
sub get_version { shift->_get_titled_section(
'VERSION',
max_token => 400,
accept_verbatim => 1,
max_content_length => 3_000,
@_,
);
}
sub get_description { shift->_get_titled_section(
'DESCRIPTION',
max_token => 400,
max_content_length => 3_000,
@_,
) }
sub get_authors { shift->get_author(@_) } # a harmless alias
sub get_author {
my $this = shift;
# Max_token is so high because these are
# typically at the end of the document:
$this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) ||
$this->_get_titled_section('AUTHORS', max_token => 10_000, @_);
}
#--------------------------------------------------------------------------
sub _get_titled_section {
# Based on a get_title originally contributed by Graham Barr
my($self, $titlename, %options) = (@_);
my $max_token = delete $options{'max_token'};
my $desperate_for_title = delete $options{'desperate'};
my $accept_verbatim = delete $options{'accept_verbatim'};
my $max_content_length = delete $options{'max_content_length'};
my $nocase = delete $options{'nocase'};
$max_content_length = 120 unless defined $max_content_length;
Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ")
. join " ", map "[$_]", sort keys %options
)
if keys %options;
my %content_containers;
$content_containers{'Para'} = 1;
if($accept_verbatim) {
$content_containers{'Verbatim'} = 1;
$content_containers{'VerbatimFormatted'} = 1;
}
my $token_count = 0;
my $title;
my @to_unget;
my $state = 0;
my $depth = 0;
Carp::croak "What kind of titlename is \"$titlename\"?!" unless
defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity
my $titlename_re = quotemeta($titlename);
my $head1_text_content;
my $para_text_content;
my $skipX;
while(
++$token_count <= ($max_token || 1_000_000)
and defined(my $token = $self->get_token)
) {
push @to_unget, $token;
if ($state == 0) { # seeking =head1
if( $token->is_start and $token->tagname eq 'head1' ) {
DEBUG and print STDERR " Found head1. Seeking content...\n";
++$state;
$head1_text_content = '';
}
}
elsif($state == 1) { # accumulating text until end of head1
if( $token->is_text ) {
unless ($skipX) {
DEBUG and print STDERR " Adding \"", $token->text, "\" to head1-content.\n";
$head1_text_content .= $token->text;
}
} elsif( $token->is_tagname('X') ) {
# We're going to want to ignore X<> stuff.
$skipX = $token->is_start;
DEBUG and print STDERR +($skipX ? 'Start' : 'End'), 'ing ignoring of X<> tag';
} elsif( $token->is_end and $token->tagname eq 'head1' ) {
DEBUG and print STDERR " Found end of head1. Considering content...\n";
$head1_text_content = uc $head1_text_content if $nocase;
if($head1_text_content eq $titlename
or $head1_text_content =~ m/\($titlename_re\)/s
# We accept "=head1 Nomen Modularis (NAME)" for sake of i18n
) {
DEBUG and print STDERR " Yup, it was $titlename. Seeking next para-content...\n";
++$state;
} elsif(
$desperate_for_title
# if we're so desperate we'll take the first
# =head1's content as a title
and $head1_text_content =~ m/\S/
and $head1_text_content !~ m/^[ A-Z]+$/s
and $head1_text_content !~
m/\((?:
NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS
| COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS?
| CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT
)\)/sx
# avoid accepting things like =head1 Thingy Thongy (DESCRIPTION)
and ($max_content_length
? (length($head1_text_content) <= $max_content_length) # sanity
: 1)
) {
# Looks good; trim it
($title = $head1_text_content) =~ s/\s+$//;
DEBUG and print STDERR " It looks titular: \"$title\".\n\n Using that.\n";
last;
} else {
--$state;
DEBUG and print STDERR " Didn't look titular ($head1_text_content).\n",
"\n Dropping back to seeking-head1-content mode...\n";
}
}
}
elsif($state == 2) {
# seeking start of para (which must immediately follow)
if($token->is_start and $content_containers{ $token->tagname }) {
DEBUG and print STDERR " Found start of Para. Accumulating content...\n";
$para_text_content = '';
++$state;
} else {
DEBUG and print
" Didn't see an immediately subsequent start-Para. Reseeking H1\n";
$state = 0;
}
}
elsif($state == 3) {
# accumulating text until end of Para
if( $token->is_text ) {
DEBUG and print STDERR " Adding \"", $token->text, "\" to para-content.\n";
$para_text_content .= $token->text;
# and keep looking
} elsif( $token->is_end and $content_containers{ $token->tagname } ) {
DEBUG and print STDERR " Found end of Para. Considering content: ",
$para_text_content, "\n";
if( $para_text_content =~ m/\S/
and ($max_content_length
? (length($para_text_content) <= $max_content_length)
: 1)
) {
# Some minimal sanity constraints, I think.
DEBUG and print STDERR " It looks contentworthy, I guess. Using it.\n";
$title = $para_text_content;
last;
} else {
DEBUG and print STDERR " Doesn't look at all contentworthy!\n Giving up.\n";
undef $title;
last;
}
}
}
else {
die "IMPOSSIBLE STATE $state!\n"; # should never happen
}
}
# Put it all back!
$self->unget_token(@to_unget);
if(DEBUG) {
if(defined $title) { print STDERR " Returning title <$title>\n" }
else { print STDERR "Returning title <>\n" }
}
return '' unless defined $title;
$title =~ s/^\s+//;
return $title;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# Methods that actually do work at parse-time:
sub _handle_element_start {
my $self = shift; # leaving ($element_name, $attr_hash_r)
DEBUG > 2 and print STDERR "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n";
push @{ $self->{'token_buffer'} },
$self->{'start_token_class'}->new(@_);
return;
}
sub _handle_text {
my $self = shift; # leaving ($text)
DEBUG > 2 and print STDERR "== $_[0]\n";
push @{ $self->{'token_buffer'} },
$self->{'text_token_class'}->new(@_);
return;
}
sub _handle_element_end {
my $self = shift; # leaving ($element_name);
DEBUG > 2 and print STDERR "-- $_[0]\n";
push @{ $self->{'token_buffer'} },
$self->{'end_token_class'}->new(@_);
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::PullParser -- a pull-parser interface to parsing Pod
=head1 SYNOPSIS
my $parser = SomePodProcessor->new;
$parser->set_source( "whatever.pod" );
$parser->run;
Or:
my $parser = SomePodProcessor->new;
$parser->set_source( $some_filehandle_object );
$parser->run;
Or:
my $parser = SomePodProcessor->new;
$parser->set_source( \$document_source );
$parser->run;
Or:
my $parser = SomePodProcessor->new;
$parser->set_source( \@document_lines );
$parser->run;
And elsewhere:
require 5;
package SomePodProcessor;
use strict;
use base qw(Pod::Simple::PullParser);
sub run {
my $self = shift;
Token:
while(my $token = $self->get_token) {
...process each token...
}
}
=head1 DESCRIPTION
This class is for using Pod::Simple to build a Pod processor -- but
one that uses an interface based on a stream of token objects,
instead of based on events.
This is a subclass of L<Pod::Simple> and inherits all its methods.
A subclass of Pod::Simple::PullParser should define a C<run> method
that calls C<< $token = $parser->get_token >> to pull tokens.
See the source for Pod::Simple::RTF for an example of a formatter
that uses Pod::Simple::PullParser.
=head1 METHODS
=over
=item my $token = $parser->get_token
This returns the next token object (which will be of a subclass of
L<Pod::Simple::PullParserToken>), or undef if the parser-stream has hit
the end of the document.
=item $parser->unget_token( $token )
=item $parser->unget_token( $token1, $token2, ... )
This restores the token object(s) to the front of the parser stream.
=back
The source has to be set before you can parse anything. The lowest-level
way is to call C<set_source>:
=over
=item $parser->set_source( $filename )
=item $parser->set_source( $filehandle_object )
=item $parser->set_source( \$document_source )
=item $parser->set_source( \@document_lines )
=back
Or you can call these methods, which Pod::Simple::PullParser has defined
to work just like Pod::Simple's same-named methods:
=over
=item $parser->parse_file(...)
=item $parser->parse_string_document(...)
=item $parser->filter(...)
=item $parser->parse_from_file(...)
=back
For those to work, the Pod-processing subclass of
Pod::Simple::PullParser has to have defined a $parser->run method --
so it is advised that all Pod::Simple::PullParser subclasses do so.
See the Synopsis above, or the source for Pod::Simple::RTF.
Authors of formatter subclasses might find these methods useful to
call on a parser object that you haven't started pulling tokens
from yet:
=over
=item my $title_string = $parser->get_title
This tries to get the title string out of $parser, by getting some tokens,
and scanning them for the title, and then ungetting them so that you can
process the token-stream from the beginning.
For example, suppose you have a document that starts out:
=head1 NAME
Hoo::Boy::Wowza -- Stuff B<wow> yeah!
$parser->get_title on that document will return "Hoo::Boy::Wowza --
Stuff wow yeah!". If the document starts with:
=head1 Name
Hoo::Boy::W00t -- Stuff B<w00t> yeah!
Then you'll need to pass the C<nocase> option in order to recognize "Name":
$parser->get_title(nocase => 1);
In cases where get_title can't find the title, it will return empty-string
("").
=item my $title_string = $parser->get_short_title
This is just like get_title, except that it returns just the modulename, if
the title seems to be of the form "SomeModuleName -- description".
For example, suppose you have a document that starts out:
=head1 NAME
Hoo::Boy::Wowza -- Stuff B<wow> yeah!
then $parser->get_short_title on that document will return
"Hoo::Boy::Wowza".
But if the document starts out:
=head1 NAME
Hooboy, stuff B<wow> yeah!
then $parser->get_short_title on that document will return "Hooboy,
stuff wow yeah!". If the document starts with:
=head1 Name
Hoo::Boy::W00t -- Stuff B<w00t> yeah!
Then you'll need to pass the C<nocase> option in order to recognize "Name":
$parser->get_short_title(nocase => 1);
If the title can't be found, then get_short_title returns empty-string
("").
=item $author_name = $parser->get_author
This works like get_title except that it returns the contents of the
"=head1 AUTHOR\n\nParagraph...\n" section, assuming that that section
isn't terribly long. To recognize a "=head1 Author\n\nParagraph\n"
section, pass the C<nocase> option:
$parser->get_author(nocase => 1);
(This method tolerates "AUTHORS" instead of "AUTHOR" too.)
=item $description_name = $parser->get_description
This works like get_title except that it returns the contents of the
"=head1 DESCRIPTION\n\nParagraph...\n" section, assuming that that section
isn't terribly long. To recognize a "=head1 Description\n\nParagraph\n"
section, pass the C<nocase> option:
$parser->get_description(nocase => 1);
=item $version_block = $parser->get_version
This works like get_title except that it returns the contents of
the "=head1 VERSION\n\n[BIG BLOCK]\n" block. Note that this does NOT
return the module's C<$VERSION>!! To recognize a
"=head1 Version\n\n[BIG BLOCK]\n" section, pass the C<nocase> option:
$parser->get_version(nocase => 1);
=back
=head1 NOTE
You don't actually I<have> to define a C<run> method. If you're
writing a Pod-formatter class, you should define a C<run> just so
that users can call C<parse_file> etc, but you don't I<have> to.
And if you're not writing a formatter class, but are instead just
writing a program that does something simple with a Pod::PullParser
object (and not an object of a subclass), then there's no reason to
bother subclassing to add a C<run> method.
=head1 SEE ALSO
L<Pod::Simple>
L<Pod::Simple::PullParserToken> -- and its subclasses
L<Pod::Simple::PullParserStartToken>,
L<Pod::Simple::PullParserTextToken>, and
L<Pod::Simple::PullParserEndToken>.
L<HTML::TokeParser>, which inspired this.
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
JUNK:
sub _old_get_title { # some witchery in here
my $self = $_[0];
my $title;
my @to_unget;
while(1) {
push @to_unget, $self->get_token;
unless(defined $to_unget[-1]) { # whoops, short doc!
pop @to_unget;
last;
}
DEBUG and print STDERR "-Got token ", $to_unget[-1]->dump, "\n";
(DEBUG and print STDERR "Too much in the buffer.\n"),
last if @to_unget > 25; # sanity
my $pattern = '';
if( #$to_unget[-1]->type eq 'end'
#and $to_unget[-1]->tagname eq 'Para'
#and
($pattern = join('',
map {;
($_->type eq 'start') ? ("<" . $_->tagname .">")
: ($_->type eq 'end' ) ? ("</". $_->tagname .">")
: ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X')
: "BLORP"
} @to_unget
)) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s
) {
# Whee, it fits the pattern
DEBUG and print STDERR "Seems to match =head1 NAME pattern.\n";
$title = '';
foreach my $t (reverse @to_unget) {
last if $t->type eq 'start' and $t->tagname eq 'Para';
$title = $t->text . $title if $t->type eq 'text';
}
undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
last;
} elsif ($pattern =~ m{<head(\d)>(.+)</head\d>$}
and !( $1 eq '1' and $2 eq 'NAME' )
) {
# Well, it fits a fallback pattern
DEBUG and print STDERR "Seems to match NAMEless pattern.\n";
$title = '';
foreach my $t (reverse @to_unget) {
last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s;
$title = $t->text . $title if $t->type eq 'text';
}
undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
last;
} else {
DEBUG and $pattern and print STDERR "Leading pattern: $pattern\n";
}
}
# Put it all back:
$self->unget_token(@to_unget);
if(DEBUG) {
if(defined $title) { print STDERR " Returning title <$title>\n" }
else { print STDERR "Returning title <>\n" }
}
return '' unless defined $title;
return $title;
}
PK Ǯ[sҩs�
�
Simple/TranscodeDumb.pmnu �[���
require 5;
## This module is to be use()'d only by Pod::Simple::Transcode
package Pod::Simple::TranscodeDumb;
use strict;
use vars qw($VERSION %Supported);
$VERSION = '3.35';
# This module basically pretends it knows how to transcode, except
# only for null-transcodings! We use this when Encode isn't
# available.
%Supported = (
'ascii' => 1,
'ascii-ctrl' => 1,
'iso-8859-1' => 1,
'cp1252' => 1,
'null' => 1,
'latin1' => 1,
'latin-1' => 1,
%Supported,
);
sub is_dumb {1}
sub is_smart {0}
sub all_encodings {
return sort keys %Supported;
}
sub encoding_is_available {
return exists $Supported{lc $_[1]};
}
sub encmodver {
return __PACKAGE__ . " v" .($VERSION || '?');
}
sub make_transcoder {
my ($e) = $_[1];
die "WHAT ENCODING!?!?" unless $e;
# No-op for all but CP1252.
return sub {;} if $e !~ /^cp-?1252$/i;
# Replace CP1252 nerbles with their ASCII equivalents.
return sub {
# Copied from Encode::ZapCP1252.
my %ascii_for = (
# http://en.wikipedia.org/wiki/Windows-1252
"\x80" => 'e', # EURO SIGN
"\x82" => ',', # SINGLE LOW-9 QUOTATION MARK
"\x83" => 'f', # LATIN SMALL LETTER F WITH HOOK
"\x84" => ',,', # DOUBLE LOW-9 QUOTATION MARK
"\x85" => '...', # HORIZONTAL ELLIPSIS
"\x86" => '+', # DAGGER
"\x87" => '++', # DOUBLE DAGGER
"\x88" => '^', # MODIFIER LETTER CIRCUMFLEX ACCENT
"\x89" => '%', # PER MILLE SIGN
"\x8a" => 'S', # LATIN CAPITAL LETTER S WITH CARON
"\x8b" => '<', # SINGLE LEFT-POINTING ANGLE QUOTATION MARK
"\x8c" => 'OE', # LATIN CAPITAL LIGATURE OE
"\x8e" => 'Z', # LATIN CAPITAL LETTER Z WITH CARON
"\x91" => "'", # LEFT SINGLE QUOTATION MARK
"\x92" => "'", # RIGHT SINGLE QUOTATION MARK
"\x93" => '"', # LEFT DOUBLE QUOTATION MARK
"\x94" => '"', # RIGHT DOUBLE QUOTATION MARK
"\x95" => '*', # BULLET
"\x96" => '-', # EN DASH
"\x97" => '--', # EM DASH
"\x98" => '~', # SMALL TILDE
"\x99" => '(tm)', # TRADE MARK SIGN
"\x9a" => 's', # LATIN SMALL LETTER S WITH CARON
"\x9b" => '>', # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
"\x9c" => 'oe', # LATIN SMALL LIGATURE OE
"\x9e" => 'z', # LATIN SMALL LETTER Z WITH CARON
"\x9f" => 'Y', # LATIN CAPITAL LETTER Y WITH DIAERESIS
);
s{([\x80-\x9f])}{$ascii_for{$1} || $1}emxsg for @_;
};
}
1;
PK Ǯ[�n]: : Simple/XMLOutStream.pmnu �[���
require 5;
package Pod::Simple::XMLOutStream;
use strict;
use Carp ();
use Pod::Simple ();
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
$VERSION = '3.35';
BEGIN {
@ISA = ('Pod::Simple');
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
}
$ATTR_PAD = "\n" unless defined $ATTR_PAD;
# Don't mess with this unless you know what you're doing.
$SORT_ATTRS = 0 unless defined $SORT_ATTRS;
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->keep_encoding_directive(1);
#$new->accept_codes('VerbatimFormatted');
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _handle_element_start {
# ($self, $element_name, $attr_hash_r)
my $fh = $_[0]{'output_fh'};
my($key, $value);
DEBUG and print STDERR "++ $_[1]\n";
print $fh "<", $_[1];
if($SORT_ATTRS) {
foreach my $key (sort keys %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_xml_escape($value = $_[2]{$key});
print $fh $ATTR_PAD, $key, '="', $value, '"';
}
}
} else { # faster
while(($key,$value) = each %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_xml_escape($value);
print $fh $ATTR_PAD, $key, '="', $value, '"';
}
}
}
print $fh ">";
return;
}
sub _handle_text {
DEBUG and print STDERR "== \"$_[1]\"\n";
if(length $_[1]) {
my $text = $_[1];
_xml_escape($text);
print {$_[0]{'output_fh'}} $text;
}
return;
}
sub _handle_element_end {
DEBUG and print STDERR "-- $_[1]\n";
print {$_[0]{'output_fh'}} "</", $_[1], ">";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _xml_escape {
foreach my $x (@_) {
# Escape things very cautiously:
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
}
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::XMLOutStream -- turn Pod into XML
=head1 SYNOPSIS
perl -MPod::Simple::XMLOutStream -e \
"exit Pod::Simple::XMLOutStream->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
Pod::Simple::XMLOutStream is a subclass of L<Pod::Simple> that parses
Pod and turns it into XML.
Pod::Simple::XMLOutStream inherits methods from
L<Pod::Simple>.
=head1 SEE ALSO
L<Pod::Simple::DumpAsXML> is rather like this class; see its
documentation for a discussion of the differences.
L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX>
L<Pod::Simple::Subclassing>
The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML>
=head1 ABOUT EXTENDING POD
TODO: An example or two of =extend, then point to Pod::Simple::Subclassing
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2004 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK Ȯ[IT�� � Simple/Checker.pmnu �[���
# A quite dimwitted pod2plaintext that need only know how to format whatever
# text comes out of Pod::BlackBox's _gen_errata
require 5;
package Pod::Simple::Checker;
use strict;
use Carp ();
use Pod::Simple::Methody ();
use Pod::Simple ();
use vars qw( @ISA $VERSION );
$VERSION = '3.35';
@ISA = ('Pod::Simple::Methody');
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
? \&Pod::Simple::DEBUG
: sub() {0}
}
use Text::Wrap 98.112902 (); # was 2001.0131, but I don't think we need that
$Text::Wrap::wrap = 'overflow';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub any_errata_seen { # read-only accessor
return $_[1]->{'Errata_seen'};
}
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->{'Thispara'} = '';
$new->{'Indent'} = 0;
$new->{'Indentstring'} = ' ';
$new->{'Errata_seen'} = 0;
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub handle_text { $_[0]{'Errata_seen'} and $_[0]{'Thispara'} .= $_[1] }
sub start_Para { $_[0]{'Thispara'} = '' }
sub start_head1 {
if($_[0]{'Errata_seen'}) {
$_[0]{'Thispara'} = '';
} else {
if($_[1]{'errata'}) { # start of errata!
$_[0]{'Errata_seen'} = 1;
$_[0]{'Thispara'} = $_[0]{'source_filename'} ?
"$_[0]{'source_filename'} -- " : ''
}
}
}
sub start_head2 { $_[0]{'Thispara'} = '' }
sub start_head3 { $_[0]{'Thispara'} = '' }
sub start_head4 { $_[0]{'Thispara'} = '' }
sub start_Verbatim { $_[0]{'Thispara'} = '' }
sub start_item_bullet { $_[0]{'Thispara'} = '* ' }
sub start_item_number { $_[0]{'Thispara'} = "$_[1]{'number'}. " }
sub start_item_text { $_[0]{'Thispara'} = '' }
sub start_over_bullet { ++$_[0]{'Indent'} }
sub start_over_number { ++$_[0]{'Indent'} }
sub start_over_text { ++$_[0]{'Indent'} }
sub start_over_block { ++$_[0]{'Indent'} }
sub end_over_bullet { --$_[0]{'Indent'} }
sub end_over_number { --$_[0]{'Indent'} }
sub end_over_text { --$_[0]{'Indent'} }
sub end_over_block { --$_[0]{'Indent'} }
# . . . . . Now the actual formatters:
sub end_head1 { $_[0]->emit_par(-4) }
sub end_head2 { $_[0]->emit_par(-3) }
sub end_head3 { $_[0]->emit_par(-2) }
sub end_head4 { $_[0]->emit_par(-1) }
sub end_Para { $_[0]->emit_par( 0) }
sub end_item_bullet { $_[0]->emit_par( 0) }
sub end_item_number { $_[0]->emit_par( 0) }
sub end_item_text { $_[0]->emit_par(-2) }
sub emit_par {
return unless $_[0]{'Errata_seen'};
my($self, $tweak_indent) = splice(@_,0,2);
my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) );
# Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
$out =~ s/$Pod::Simple::nbsp/ /g;
print {$self->{'output_fh'}} $out,
#"\n"
;
$self->{'Thispara'} = '';
return;
}
# . . . . . . . . . . And then off by its lonesome:
sub end_Verbatim {
return unless $_[0]{'Errata_seen'};
my $self = shift;
$self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g;
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
$self->{'Thispara'} =~ s/^/$i/mg;
print { $self->{'output_fh'} } '',
$self->{'Thispara'},
"\n\n"
;
$self->{'Thispara'} = '';
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::Checker -- check the Pod syntax of a document
=head1 SYNOPSIS
perl -MPod::Simple::Checker -e \
"exit Pod::Simple::Checker->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is for checking the syntactic validity of Pod.
It works by basically acting like a simple-minded version of
L<Pod::Simple::Text> that formats only the "Pod Errors" section
(if Pod::Simple even generates one for the given document).
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Checker>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK Ȯ[Զs?6� 6� Simple/HTML.pmnu �[��� require 5;
package Pod::Simple::HTML;
use strict;
use Pod::Simple::PullParser ();
use vars qw(
@ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION
$Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix
$Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex
$Doctype_decl $Content_decl
);
@ISA = ('Pod::Simple::PullParser');
$VERSION = '3.35';
BEGIN {
if(defined &DEBUG) { } # no-op
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
else { *DEBUG = sub () {0}; }
}
$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it.
# qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
# "http://www.w3.org/TR/html4/loose.dtd">\n};
$Content_decl ||=
q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >};
$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION;
$Computerese = "" unless defined $Computerese;
$LamePad = '' unless defined $LamePad;
$Linearization_Limit = 120 unless defined $Linearization_Limit;
# headings/items longer than that won't get an <a name="...">
$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?'
unless defined $Perldoc_URL_Prefix;
$Perldoc_URL_Postfix = ''
unless defined $Perldoc_URL_Postfix;
$Man_URL_Prefix = 'http://man.he.net/man';
$Man_URL_Postfix = '';
$Title_Prefix = '' unless defined $Title_Prefix;
$Title_Postfix = '' unless defined $Title_Postfix;
%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text
# 'item-text' stuff in the index doesn't quite work, and may
# not be a good idea anyhow.
__PACKAGE__->_accessorize(
'perldoc_url_prefix',
# In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
# to put before the "Foo%3a%3aBar".
# (for singleton mode only?)
'perldoc_url_postfix',
# what to put after "Foo%3a%3aBar" in the URL. Normally "".
'man_url_prefix',
# In turning L<crontab(5)> into http://whatever/man/1/crontab, what
# to put before the "1/crontab".
'man_url_postfix',
# what to put after the "1/crontab" in the URL. Normally "".
'batch_mode', # whether we're in batch mode
'batch_mode_current_level',
# When in batch mode, how deep the current module is: 1 for "LWP",
# 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
'title_prefix', 'title_postfix',
# What to put before and after the title in the head.
# Should already be &-escaped
'html_h_level',
'html_header_before_title',
'html_header_after_title',
'html_footer',
'top_anchor',
'index', # whether to add an index at the top of each page
# (actually it's a table-of-contents, but we'll call it an index,
# out of apparently longstanding habit)
'html_css', # URL of CSS file to point to
'html_javascript', # URL of Javascript file to point to
'force_title', # should already be &-escaped
'default_title', # should already be &-escaped
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my @_to_accept;
%Tagmap = (
'Verbatim' => "\n<pre$Computerese>",
'/Verbatim' => "</pre>\n",
'VerbatimFormatted' => "\n<pre$Computerese>",
'/VerbatimFormatted' => "</pre>\n",
'VerbatimB' => "<b>",
'/VerbatimB' => "</b>",
'VerbatimI' => "<i>",
'/VerbatimI' => "</i>",
'VerbatimBI' => "<b><i>",
'/VerbatimBI' => "</i></b>",
'Data' => "\n",
'/Data' => "\n",
'head1' => "\n<h1>", # And also stick in an <a name="...">
'head2' => "\n<h2>", # ''
'head3' => "\n<h3>", # ''
'head4' => "\n<h4>", # ''
'/head1' => "</a></h1>\n",
'/head2' => "</a></h2>\n",
'/head3' => "</a></h3>\n",
'/head4' => "</a></h4>\n",
'X' => "<!--\n\tINDEX: ",
'/X' => "\n-->",
changes(qw(
Para=p
B=b I=i
over-bullet=ul
over-number=ol
over-text=dl
over-block=blockquote
item-bullet=li
item-number=li
item-text=dt
)),
changes2(
map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
qw[
sample=samp
definition=dfn
keyboard=kbd
variable=var
citation=cite
abbreviation=abbr
acronym=acronym
subscript=sub
superscript=sup
big=big
small=small
underline=u
strikethrough=s
preformat=pre
teletype=tt
] # no point in providing a way to get <q>...</q>, I think
),
'/item-bullet' => "</li>$LamePad\n",
'/item-number' => "</li>$LamePad\n",
'/item-text' => "</a></dt>$LamePad\n",
'item-body' => "\n<dd>",
'/item-body' => "</dd>\n",
'B' => "<b>", '/B' => "</b>",
'I' => "<i>", '/I' => "</i>",
'F' => "<em$Computerese>", '/F' => "</em>",
'C' => "<code$Computerese>", '/C' => "</code>",
'L' => "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used!
'/L' => "</a>",
);
sub changes {
return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_"
} @_;
}
sub changes2 {
return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_"
} @_;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 }
# Just so we can run from the command line. No options.
# For that, use perldoc!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $new = shift->SUPER::new(@_);
#$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->accept_targets( 'html', 'HTML' );
$new->accept_codes('VerbatimFormatted');
$new->accept_codes(@_to_accept);
DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n";
$new->perldoc_url_prefix( $Perldoc_URL_Prefix );
$new->perldoc_url_postfix( $Perldoc_URL_Postfix );
$new->man_url_prefix( $Man_URL_Prefix );
$new->man_url_postfix( $Man_URL_Postfix );
$new->title_prefix( $Title_Prefix );
$new->title_postfix( $Title_Postfix );
$new->html_header_before_title(
qq[$Doctype_decl<html><head><title>]
);
$new->html_header_after_title( join "\n" =>
"</title>",
$Content_decl,
"</head>\n<body class='pod'>",
$new->version_tag_comment,
"<!-- start doc -->\n",
);
$new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
$new->top_anchor( "<a name='___top' class='dummyTopAnchor' ></a>\n" );
$new->{'Tagmap'} = {%Tagmap};
return $new;
}
sub __adjust_html_h_levels {
my ($self) = @_;
my $Tagmap = $self->{'Tagmap'};
my $add = $self->html_h_level;
return unless defined $add;
return if ($self->{'Adjusted_html_h_levels'}||0) == $add;
$add -= 1;
for (1 .. 4) {
$Tagmap->{"head$_"} =~ s/$_/$_ + $add/e;
$Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e;
}
}
sub batch_mode_page_object_init {
my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
DEBUG and print STDERR "Initting $self\n for $module\n",
" in $infile\n out $outfile\n depth $depth\n";
$self->batch_mode(1);
$self->batch_mode_current_level($depth);
return $self;
}
sub run {
my $self = $_[0];
return $self->do_middle if $self->bare_output;
return
$self->do_beginning && $self->do_middle && $self->do_end;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub do_beginning {
my $self = $_[0];
my $title;
if(defined $self->force_title) {
$title = $self->force_title;
DEBUG and print STDERR "Forcing title to be $title\n";
} else {
# Actually try looking for the title in the document:
$title = $self->get_short_title();
unless($self->content_seen) {
DEBUG and print STDERR "No content seen in search for title.\n";
return;
}
$self->{'Title'} = $title;
if(defined $title and $title =~ m/\S/) {
$title = $self->title_prefix . esc($title) . $self->title_postfix;
} else {
$title = $self->default_title;
$title = '' unless defined $title;
DEBUG and print STDERR "Title defaults to $title\n";
}
}
my $after = $self->html_header_after_title || '';
if($self->html_css) {
my $link =
$self->html_css =~ m/</
? $self->html_css # It's a big blob of markup, let's drop it in
: sprintf( # It's just a URL, so let's wrap it up
qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n],
$self->html_css,
);
$after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
}
$self->_add_top_anchor(\$after);
if($self->html_javascript) {
my $link =
$self->html_javascript =~ m/</
? $self->html_javascript # It's a big blob of markup, let's drop it in
: sprintf( # It's just a URL, so let's wrap it up
qq[<script type="text/javascript" src="%s"></script>\n],
$self->html_javascript,
);
$after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
}
print {$self->{'output_fh'}}
$self->html_header_before_title || '',
$title, # already escaped
$after,
;
DEBUG and print STDERR "Returning from do_beginning...\n";
return 1;
}
sub _add_top_anchor {
my($self, $text_r) = @_;
unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack
$$text_r .= $self->top_anchor || '';
}
return;
}
sub version_tag_comment {
my $self = shift;
return sprintf
"<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n",
esc(
ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
$], scalar(gmtime),
), $self->_modnote(),
;
}
sub _modnote {
my $class = ref($_[0]) || $_[0];
return join "\n " => grep m/\S/, split "\n",
qq{
If you want to change this HTML document, you probably shouldn't do that
by changing it directly. Instead, see about changing the calling options
to $class, and/or subclassing $class,
then reconverting this document from the Pod source.
When in doubt, email the author of $class for advice.
See 'perldoc $class' for more info.
};
}
sub do_end {
my $self = $_[0];
print {$self->{'output_fh'}} $self->html_footer || '';
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Normally this would just be a call to _do_middle_main_loop -- but we
# have to do some elaborate things to emit all the content and then
# summarize it and output it /before/ the content that it's a summary of.
sub do_middle {
my $self = $_[0];
return $self->_do_middle_main_loop unless $self->index;
if( $self->output_string ) {
# An efficiency hack
my $out = $self->output_string; #it's a reference to it
my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n";
$$out .= $sneakytag;
$self->_do_middle_main_loop;
$sneakytag = quotemeta($sneakytag);
my $index = $self->index_as_html();
if( $$out =~ s/$sneakytag/$index/s ) {
# Expected case
DEBUG and print STDERR "Inserted ", length($index), " bytes of index HTML into $out.\n";
} else {
DEBUG and print STDERR "Odd, couldn't find where to insert the index in the output!\n";
# I don't think this should ever happen.
}
return 1;
}
unless( $self->output_fh ) {
require Carp;
Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that.");
}
# If we get here, we're outputting to a FH. So we need to do some magic.
# Namely, divert all content to a string, which we output after the index.
my $fh = $self->output_fh;
my $content = '';
{
# Our horrible bait and switch:
$self->output_string( \$content );
$self->_do_middle_main_loop;
$self->abandon_output_string();
$self->output_fh($fh);
}
print $fh $self->index_as_html();
print $fh $content;
return 1;
}
###########################################################################
sub index_as_html {
my $self = $_[0];
# This is meant to be called AFTER the input document has been parsed!
my $points = $self->{'PSHTML_index_points'} || [];
@$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n];
# There's no point in having a 0-item or 1-item index, I dare say.
my(@out) = qq{\n<div class='indexgroup'>};
my $level = 0;
my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent);
foreach my $p (@$points, ['head0', '(end)']) {
($tagname, $text) = @$p;
$anchorname = $self->section_escape($text);
if( $tagname =~ m{^head(\d+)$} ) {
$target_level = 0 + $1;
} else { # must be some kinda list item
if($previous_tagname =~ m{^head\d+$} ) {
$target_level = $level + 1;
} else {
$target_level = $level; # no change needed
}
}
# Get to target_level by opening or closing ULs
while($level > $target_level)
{ --$level; push @out, (" " x $level) . "</ul>"; }
while($level < $target_level)
{ ++$level; push @out, (" " x ($level-1))
. "<ul class='indexList indexList$level'>"; }
$previous_tagname = $tagname;
next unless $level;
$indent = ' ' x $level;
push @out, sprintf
"%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>",
$indent, $level, esc($anchorname), esc($text)
;
}
push @out, "</div>\n";
return join "\n", @out;
}
###########################################################################
sub _do_middle_main_loop {
my $self = $_[0];
my $fh = $self->{'output_fh'};
my $tagmap = $self->{'Tagmap'};
$self->__adjust_html_h_levels;
my($token, $type, $tagname, $linkto, $linktype);
my @stack;
my $dont_wrap = 0;
while($token = $self->get_token) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if( ($type = $token->type) eq 'start' ) {
if(($tagname = $token->tagname) eq 'L') {
$linktype = $token->attr('type') || 'insane';
$linkto = $self->do_link($token);
if(defined $linkto and length $linkto) {
esc($linkto);
# (Yes, SGML-escaping applies on top of %-escaping!
# But it's rarely noticeable in practice.)
print $fh qq{<a href="$linkto" class="podlink$linktype"\n>};
} else {
print $fh "<a>"; # Yes, an 'a' element with no attributes!
}
} elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) {
print $fh $tagmap->{$tagname} || next;
my @to_unget;
while(1) {
push @to_unget, $self->get_token;
last if $to_unget[-1]->is_end
and $to_unget[-1]->tagname eq $tagname;
# TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens)
}
my $name = $self->linearize_tokens(@to_unget);
$name = $self->do_section($name, $token) if defined $name;
print $fh "<a ";
if ($tagname =~ m/^head\d$/s) {
print $fh "class='u'", $self->index
? " href='#___top' title='click to go to top of document'\n"
: "\n";
}
if(defined $name) {
my $esc = esc( $self->section_name_tidy( $name ) );
print $fh qq[name="$esc"];
DEBUG and print STDERR "Linearized ", scalar(@to_unget),
" tokens as \"$name\".\n";
push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
if $ToIndex{ $tagname };
# Obviously, this discards all formatting codes (saving
# just their content), but ahwell.
} else { # ludicrously long, so nevermind
DEBUG and print STDERR "Linearized ", scalar(@to_unget),
" tokens, but it was too long, so nevermind.\n";
}
print $fh "\n>";
$self->unget_token(@to_unget);
} elsif ($tagname eq 'Data') {
my $next = $self->get_token;
next unless defined $next;
unless( $next->type eq 'text' ) {
$self->unget_token($next);
next;
}
DEBUG and print STDERR " raw text ", $next->text, "\n";
# The parser sometimes preserves newlines and sometimes doesn't!
(my $text = $next->text) =~ s/\n\z//;
print $fh $text, "\n";
next;
} else {
if( $tagname =~ m/^over-/s ) {
push @stack, '';
} elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) {
print $fh $stack[-1];
$stack[-1] = '';
}
print $fh $tagmap->{$tagname} || next;
++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted"
or $tagname eq 'X';
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
} elsif( $type eq 'end' ) {
if( ($tagname = $token->tagname) =~ m/^over-/s ) {
if( my $end = pop @stack ) {
print $fh $end;
}
} elsif( $tagname =~ m/^item-/s and @stack) {
$stack[-1] = $tagmap->{"/$tagname"};
if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) {
$self->unget_token($next);
if( $next->type eq 'start' ) {
print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"};
$stack[-1] = $tagmap->{"/item-body"};
}
}
next;
}
print $fh $tagmap->{"/$tagname"} || next;
--$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X';
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
} elsif( $type eq 'text' ) {
esc($type = $token->text); # reuse $type, why not
$type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap;
print $fh $type;
}
}
return 1;
}
###########################################################################
#
sub do_section {
my($self, $name, $token) = @_;
return $name;
}
sub do_link {
my($self, $token) = @_;
my $type = $token->attr('type');
if(!defined $type) {
$self->whine("Typeless L!?", $token->attr('start_line'));
} elsif( $type eq 'pod') { return $self->do_pod_link($token);
} elsif( $type eq 'url') { return $self->do_url_link($token);
} elsif( $type eq 'man') { return $self->do_man_link($token);
} else {
$self->whine("L of unknown type $type!?", $token->attr('start_line'));
}
return 'FNORG'; # should never get called
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub do_url_link { return $_[1]->attr('to') }
sub do_man_link {
my ($self, $link) = @_;
my $to = $link->attr('to');
my $frag = $link->attr('section');
return undef unless defined $to and length $to; # should never happen
$frag = $self->section_escape($frag)
if defined $frag and length($frag .= ''); # (stringify)
DEBUG and print STDERR "Resolving \"$to/$frag\"\n\n";
return $self->resolve_man_page_link($to, $frag);
}
sub do_pod_link {
# And now things get really messy...
my($self, $link) = @_;
my $to = $link->attr('to');
my $section = $link->attr('section');
return undef unless( # should never happen
(defined $to and length $to) or
(defined $section and length $section)
);
$section = $self->section_escape($section)
if defined $section and length($section .= ''); # (stringify)
DEBUG and printf STDERR "Resolving \"%s\" \"%s\"...\n",
$to || "(nil)", $section || "(nil)";
{
# An early hack:
my $complete_url = $self->resolve_pod_link_by_table($to, $section);
if( $complete_url ) {
DEBUG > 1 and print STDERR "resolve_pod_link_by_table(T,S) gives ",
$complete_url, "\n (Returning that.)\n";
return $complete_url;
} else {
DEBUG > 4 and print STDERR " resolve_pod_link_by_table(T,S)",
" didn't return anything interesting.\n";
}
}
if(defined $to and length $to) {
# Give this routine first hack again
my $there = $self->resolve_pod_link_by_table($to);
if(defined $there and length $there) {
DEBUG > 1
and print STDERR "resolve_pod_link_by_table(T) gives $there\n";
} else {
$there =
$self->resolve_pod_page_link($to, $section);
# (I pass it the section value, but I don't see a
# particular reason it'd use it.)
DEBUG > 1 and print STDERR "resolve_pod_page_link gives ", $there || "(nil)", "\n";
unless( defined $there and length $there ) {
DEBUG and print STDERR "Can't resolve $to\n";
return undef;
}
# resolve_pod_page_link returning undef is how it
# can signal that it gives up on making a link
}
$to = $there;
}
#DEBUG and print STDERR "So far [", $to||'nil', "] [", $section||'nil', "]\n";
my $out = (defined $to and length $to) ? $to : '';
$out .= "#" . $section if defined $section and length $section;
unless(length $out) { # sanity check
DEBUG and printf STDERR "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
$to || "(nil)", $section || "(nil)";
return undef;
}
DEBUG and print STDERR "Resolved to $out\n";
return $out;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub section_escape {
my($self, $section) = @_;
return $self->section_url_escape(
$self->section_name_tidy($section)
);
}
sub section_name_tidy {
my($self, $section) = @_;
$section =~ s/^\s+//;
$section =~ s/\s+$//;
$section =~ tr/ /_/;
if ($] ge 5.006) {
$section =~ s/[[:cntrl:][:^ascii:]]//g; # drop crazy characters
} elsif ('A' eq chr(65)) { # But not on early EBCDIC
$section =~ tr/\x00-\x1F\x80-\x9F//d;
}
$section = $self->unicode_escape_url($section);
$section = '_' unless length $section;
return $section;
}
sub section_url_escape { shift->general_url_escape(@_) }
sub pagepath_url_escape { shift->general_url_escape(@_) }
sub manpage_url_escape { shift->general_url_escape(@_) }
sub general_url_escape {
my($self, $string) = @_;
$string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
# express Unicode things as urlencode(utf(orig)).
# A pretty conservative escaping, behoovey even for query components
# of a URL (see RFC 2396)
if ($] ge 5.007_003) {
$string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',utf8::native_to_unicode(ord($1)))/eg;
} else { # Is broken for non-ASCII platforms on early perls
$string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
}
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
return $string;
}
#--------------------------------------------------------------------------
#
# Oh look, a yawning portal to Hell! Let's play touch football right by it!
#
sub resolve_pod_page_link {
# resolve_pod_page_link must return a properly escaped URL
my $self = shift;
return $self->batch_mode()
? $self->resolve_pod_page_link_batch_mode(@_)
: $self->resolve_pod_page_link_singleton_mode(@_)
;
}
sub resolve_pod_page_link_singleton_mode {
my($self, $it) = @_;
return undef unless defined $it and length $it;
my $url = $self->pagepath_url_escape($it);
$url =~ s{::$}{}s; # probably never comes up anyway
$url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?
return undef unless length $url;
return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
}
sub resolve_pod_page_link_batch_mode {
my($self, $to) = @_;
DEBUG > 1 and print STDERR " During batch mode, resolving $to ...\n";
my @path = grep length($_), split m/::/s, $to, -1;
unless( @path ) { # sanity
DEBUG and print STDERR "Very odd! Splitting $to gives (nil)!\n";
return undef;
}
$self->batch_mode_rectify_path(\@path);
my $out = join('/', map $self->pagepath_url_escape($_), @path)
. $HTML_EXTENSION;
DEBUG > 1 and print STDERR " => $out\n";
return $out;
}
sub batch_mode_rectify_path {
my($self, $pathbits) = @_;
my $level = $self->batch_mode_current_level;
$level--; # how many levels up to go to get to the root
if($level < 1) {
unshift @$pathbits, '.'; # just to be pretty
} else {
unshift @$pathbits, ('..') x $level;
}
return;
}
sub resolve_man_page_link {
my ($self, $to, $frag) = @_;
my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
return undef unless defined $page and length $page;
$section ||= 1;
return $self->man_url_prefix . "$section/"
. $self->manpage_url_escape($page)
. $self->man_url_postfix;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub resolve_pod_link_by_table {
# A crazy hack to allow specifying custom L<foo> => URL mappings
return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut
my($self, $to, $section) = @_;
# TODO: add a method that actually populates podhtml_LOT from a file?
if(defined $section) {
$to = '' unless defined $to and length $to;
return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
} else {
return $self->{'podhtml_LOT'}{$to}; # quite possibly undef!
}
return;
}
###########################################################################
sub linearize_tokens { # self, tokens
my $self = shift;
my $out = '';
my $t;
while($t = shift @_) {
if(!ref $t or !UNIVERSAL::can($t, 'is_text')) {
$out .= $t; # a string, or some insane thing
} elsif($t->is_text) {
$out .= $t->text;
} elsif($t->is_start and $t->tag eq 'X') {
# Ignore until the end of this X<...> sequence:
my $x_open = 1;
while($x_open) {
next if( ($t = shift @_)->is_text );
if( $t->is_start and $t->tag eq 'X') { ++$x_open }
elsif($t->is_end and $t->tag eq 'X') { --$x_open }
}
}
}
return undef if length $out > $Linearization_Limit;
return $out;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub unicode_escape_url {
my($self, $string) = @_;
$string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg;
# Turn char 1234 into "(1234)"
return $string;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub esc { # a function.
if(defined wantarray) {
if(wantarray) {
@_ = splice @_; # break aliasing
} else {
my $x = shift;
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
}
return $x;
}
}
foreach my $x (@_) {
# Escape things very cautiously:
if (defined $x) {
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
}
}
# Leave out "- so that "--" won't make it thru in X-generated comments
# with text in them.
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
}
return @_;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
=head1 NAME
Pod::Simple::HTML - convert Pod to HTML
=head1 SYNOPSIS
perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod
=head1 DESCRIPTION
This class is for making an HTML rendering of a Pod document.
This is a subclass of L<Pod::Simple::PullParser> and inherits all its
methods (and options).
Note that if you want to do a batch conversion of a lot of Pod
documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>.
=head1 CALLING FROM THE COMMAND LINE
TODO
perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html
=head1 CALLING FROM PERL
=head2 Minimal code
use Pod::Simple::HTML;
my $p = Pod::Simple::HTML->new;
$p->output_string(\my $html);
$p->parse_file('path/to/Module/Name.pm');
open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
print $out $html;
=head2 More detailed example
use Pod::Simple::HTML;
Set the content type:
$Pod::Simple::HTML::Content_decl = q{<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >};
my $p = Pod::Simple::HTML->new;
Include a single javascript source:
$p->html_javascript('http://abc.com/a.js');
Or insert multiple javascript source in the header
(or for that matter include anything, thought this is not recommended)
$p->html_javascript('
<script type="text/javascript" src="http://abc.com/b.js"></script>
<script type="text/javascript" src="http://abc.com/c.js"></script>');
Include a single css source in the header:
$p->html_css('/style.css');
or insert multiple css sources:
$p->html_css('
<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="http://remote.server.com/jquery.css">
<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="/style.css">');
Tell the parser where should the output go. In this case it will be placed in the $html variable:
my $html;
$p->output_string(\$html);
Parse and process a file with pod in it:
$p->parse_file('path/to/Module/Name.pm');
=head1 METHODS
TODO
all (most?) accessorized methods
The following variables need to be set B<before> the call to the ->new constructor.
Set the string that is included before the opening <html> tag:
$Pod::Simple::HTML::Doctype_decl = qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">\n};
Set the content-type in the HTML head: (defaults to ISO-8859-1)
$Pod::Simple::HTML::Content_decl = q{<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >};
Set the value that will be embedded in the opening tags of F, C tags and verbatim text.
F maps to <em>, C maps to <code>, Verbatim text maps to <pre> (Computerese defaults to "")
$Pod::Simple::HTML::Computerese = ' class="some_class_name';
=head2 html_css
=head2 html_javascript
=head2 title_prefix
=head2 title_postfix
=head2 html_header_before_title
This includes everything before the <title> opening tag including the Document type
and including the opening <title> tag. The following call will set it to be a simple HTML
file:
$p->html_header_before_title('<html><head><title>');
=head2 top_anchor
By default Pod::Simple::HTML adds a dummy anchor at the top of the HTML.
You can change it by calling
$p->top_anchor('<a name="zz" >');
=head2 html_h_level
Normally =head1 will become <h1>, =head2 will become <h2> etc.
Using the html_h_level method will change these levels setting the h level
of =head1 tags:
$p->html_h_level(3);
Will make sure that =head1 will become <h3> and =head2 will become <h4> etc...
=head2 index
Set it to some true value if you want to have an index (in reality a table of contents)
to be added at the top of the generated HTML.
$p->index(1);
=head2 html_header_after_title
Includes the closing tag of </title> and through the rest of the head
till the opening of the body
$p->html_header_after_title('</title>...</head><body id="my_id">');
=head2 html_footer
The very end of the document:
$p->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
=head1 SUBCLASSING
Can use any of the methods described above but for further customization
one needs to override some of the methods:
package My::Pod;
use strict;
use warnings;
use base 'Pod::Simple::HTML';
# needs to return a URL string such
# http://some.other.com/page.html
# #anchor_in_the_same_file
# /internal/ref.html
sub do_pod_link {
# My::Pod object and Pod::Simple::PullParserStartToken object
my ($self, $link) = @_;
say $link->tagname; # will be L for links
say $link->attr('to'); #
say $link->attr('type'); # will be 'pod' always
say $link->attr('section');
# Links local to our web site
if ($link->tagname eq 'L' and $link->attr('type') eq 'pod') {
my $to = $link->attr('to');
if ($to =~ /^Padre::/) {
$to =~ s{::}{/}g;
return "/docs/Padre/$to.html";
}
}
# all other links are generated by the parent class
my $ret = $self->SUPER::do_pod_link($link);
return $ret;
}
1;
Meanwhile in script.pl:
use My::Pod;
my $p = My::Pod->new;
my $html;
$p->output_string(\$html);
$p->parse_file('path/to/Module/Name.pm');
open my $out, '>', 'out.html' or die;
print $out $html;
TODO
maybe override do_beginning do_end
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::HTMLBatch>
TODO: a corpus of sample Pod input and HTML output? Or common
idioms?
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2004 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 ACKNOWLEDGEMENTS
Thanks to L<Hurricane Electric|http://he.net/> for permission to use its
L<Linux man pages online|http://man.he.net/> site for man page links.
Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
site for Perl module links.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK Ȯ[�
Qi2 2 Simple/PullParserStartToken.pmnu �[���
require 5;
package Pod::Simple::PullParserStartToken;
use Pod::Simple::PullParserToken ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = ('Pod::Simple::PullParserToken');
$VERSION = '3.35';
sub new { # Class->new(tagname, optional_attrhash);
my $class = shift;
return bless ['start', @_], ref($class) || $class;
}
# Purely accessors:
sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
sub tag { shift->tagname(@_) }
sub is_tagname { $_[0][1] eq $_[1] }
sub is_tag { shift->is_tagname(@_) }
sub attr_hash { $_[0][2] ||= {} }
sub attr {
if(@_ == 2) { # Reading: $token->attr('attrname')
${$_[0][2] || return undef}{ $_[1] };
} elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval')
${$_[0][2] ||= {}}{ $_[1] } = $_[2];
} else {
require Carp;
Carp::croak(
'usage: $object->attr("val") or $object->attr("key", "newval")');
return undef;
}
}
1;
__END__
=head1 NAME
Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
(See L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser> object, you might
get an object of this class.
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
and adds these methods:
=over
=item $token->tagname
This returns the tagname for this start-token object.
For example, parsing a "=head1 ..." line will give you
a start-token with the tagname of "head1", token(s) for its
content, and then an end-token with the tagname of "head1".
=item $token->tagname(I<somestring>)
This changes the tagname for this start-token object.
You probably won't need
to do this.
=item $token->tag(...)
A shortcut for $token->tagname(...)
=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
These are shortcuts for C<< $token->tag() eq I<somestring> >>
=item $token->attr(I<attrname>)
This returns the value of the I<attrname> attribute for this start-token
object, or undef.
For example, parsing a LZ<><Foo/"Bar"> link will produce a start-token
with a "to" attribute with the value "Foo", a "type" attribute with the
value "pod", and a "section" attribute with the value "Bar".
=item $token->attr(I<attrname>, I<newvalue>)
This sets the I<attrname> attribute for this start-token object to
I<newvalue>. You probably won't need to do this.
=item $token->attr_hash
This returns the hashref that is the attribute set for this start-token.
This is useful if (for example) you want to ask what all the attributes
are -- you can just do C<< keys %{$token->attr_hash} >>
=back
You're unlikely to ever need to construct an object of this class for
yourself, but if you want to, call
C<<
Pod::Simple::PullParserStartToken->new( I<tagname>, I<attrhash> )
>>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[�E�V�
�
Simple/HTMLLegacy.pmnu �[���
require 5;
package Pod::Simple::HTMLLegacy;
use strict;
use vars qw($VERSION);
use Getopt::Long;
$VERSION = "5.01";
#--------------------------------------------------------------------------
#
# This class is meant to thinly emulate bad old Pod::Html
#
# TODO: some basic docs
sub pod2html {
my @args = (@_);
my( $verbose, $infile, $outfile, $title );
my $index = 1;
{
my($help);
my($netscape); # dummy
local @ARGV = @args;
GetOptions(
"help" => \$help,
"verbose!" => \$verbose,
"infile=s" => \$infile,
"outfile=s" => \$outfile,
"title=s" => \$title,
"index!" => \$index,
"netscape!" => \$netscape,
) or return bad_opts(@args);
bad_opts(@args) if @ARGV; # it should be all switches!
return help_message() if $help;
}
for($infile, $outfile) { $_ = undef unless defined and length }
if($verbose) {
warn sprintf "%s version %s\n", __PACKAGE__, $VERSION;
warn "OK, processed args [@args] ...\n";
warn sprintf
" Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n",
map defined($_) ? $_ : "(nil)",
$verbose, $index, $infile, $outfile, $title,
;
*Pod::Simple::HTML::DEBUG = sub(){1};
}
require Pod::Simple::HTML;
Pod::Simple::HTML->VERSION(3);
die "No such input file as $infile\n"
if defined $infile and ! -e $infile;
my $pod = Pod::Simple::HTML->new;
$pod->force_title($title) if defined $title;
$pod->index($index);
return $pod->parse_from_file($infile, $outfile);
}
#--------------------------------------------------------------------------
sub bad_opts { die _help_message(); }
sub help_message { print STDOUT _help_message() }
#--------------------------------------------------------------------------
sub _help_message {
join '',
"[", __PACKAGE__, " version ", $VERSION, qq~]
Usage: pod2html --help --infile=<name> --outfile=<name>
--verbose --index --noindex
Options:
--help - prints this message.
--[no]index - generate an index at the top of the resulting html
(default behavior).
--infile - filename for the pod to convert (input taken from stdin
by default).
--outfile - filename for the resulting html file (output sent to
stdout by default).
--title - title that will appear in resulting html file.
--[no]verbose - self-explanatory (off by default).
Note that pod2html is DEPRECATED, and this version implements only
some of the options known to older versions.
For more information, see 'perldoc pod2html'.
~;
}
1;
__END__
OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
PK ɮ[�<SD D Simple/PullParserEndToken.pmnu �[���
require 5;
package Pod::Simple::PullParserEndToken;
use Pod::Simple::PullParserToken ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = ('Pod::Simple::PullParserToken');
$VERSION = '3.35';
sub new { # Class->new(tagname);
my $class = shift;
return bless ['end', @_], ref($class) || $class;
}
# Purely accessors:
sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
sub tag { shift->tagname(@_) }
# shortcut:
sub is_tagname { $_[0][1] eq $_[1] }
sub is_tag { shift->is_tagname(@_) }
1;
__END__
=head1 NAME
Pod::Simple::PullParserEndToken -- end-tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
(See L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
get an object of this class.
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
and adds these methods:
=over
=item $token->tagname
This returns the tagname for this end-token object.
For example, parsing a "=head1 ..." line will give you
a start-token with the tagname of "head1", token(s) for its
content, and then an end-token with the tagname of "head1".
=item $token->tagname(I<somestring>)
This changes the tagname for this end-token object.
You probably won't need to do this.
=item $token->tag(...)
A shortcut for $token->tagname(...)
=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
These are shortcuts for C<< $token->tag() eq I<somestring> >>
=back
You're unlikely to ever need to construct an object of this class for
yourself, but if you want to, call
C<<
Pod::Simple::PullParserEndToken->new( I<tagname> )
>>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[��p �
�
Simple/Methody.pmnu �[���
require 5;
package Pod::Simple::Methody;
use strict;
use Pod::Simple ();
use vars qw(@ISA $VERSION);
$VERSION = '3.35';
@ISA = ('Pod::Simple');
# Yes, we could use named variables, but I want this to be impose
# as little an additional performance hit as possible.
sub _handle_element_start {
$_[1] =~ tr/-:./__/;
( $_[0]->can( 'start_' . $_[1] )
|| return
)->(
$_[0], $_[2]
);
}
sub _handle_text {
( $_[0]->can( 'handle_text' )
|| return
)->(
@_
);
}
sub _handle_element_end {
$_[1] =~ tr/-:./__/;
( $_[0]->can( 'end_' . $_[1] )
|| return
)->(
$_[0], $_[2]
);
}
1;
__END__
=head1 NAME
Pod::Simple::Methody -- turn Pod::Simple events into method calls
=head1 SYNOPSIS
require 5;
use strict;
package SomePodFormatter;
use base qw(Pod::Simple::Methody);
sub handle_text {
my($self, $text) = @_;
...
}
sub start_head1 {
my($self, $attrs) = @_;
...
}
sub end_head1 {
my($self) = @_;
...
}
...and start_/end_ methods for whatever other events you want to catch.
=head1 DESCRIPTION
This class is of
interest to people writing Pod formatters based on Pod::Simple.
This class (which is very small -- read the source) overrides
Pod::Simple's _handle_element_start, _handle_text, and
_handle_element_end methods so that parser events are turned into method
calls. (Otherwise, this is a subclass of L<Pod::Simple> and inherits all
its methods.)
You can use this class as the base class for a Pod formatter/processor.
=head1 METHOD CALLING
When Pod::Simple sees a "=head1 Hi there", for example, it basically does
this:
$parser->_handle_element_start( "head1", \%attributes );
$parser->_handle_text( "Hi there" );
$parser->_handle_element_end( "head1" );
But if you subclass Pod::Simple::Methody, it will instead do this
when it sees a "=head1 Hi there":
$parser->start_head1( \%attributes ) if $parser->can('start_head1');
$parser->handle_text( "Hi there" ) if $parser->can('handle_text');
$parser->end_head1() if $parser->can('end_head1');
If Pod::Simple sends an event where the element name has a dash,
period, or colon, the corresponding method name will have a underscore
in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz
and end_foo_bar_baz.
See the source for Pod::Simple::Text for an example of using this class.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[�7wͤ � Simple/PullParserToken.pmnu �[���
require 5;
package Pod::Simple::PullParserToken;
# Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token
@ISA = ();
$VERSION = '3.35';
use strict;
sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway
my $class = shift;
return bless [@_], ref($class) || $class;
}
sub type { $_[0][0] } # Can't change the type of an object
sub dump { Pod::Simple::pretty( [ @{ $_[0] } ] ) }
sub is_start { $_[0][0] eq 'start' }
sub is_end { $_[0][0] eq 'end' }
sub is_text { $_[0][0] eq 'text' }
1;
__END__
sub dump { '[' . _esc( @{ $_[0] } ) . ']' }
# JUNK:
sub _esc {
return '' unless @_;
my @out;
foreach my $in (@_) {
push @out, '"' . $in . '"';
$out[-1] =~ s/([^- \:\:\.\,\'\>\<\"\/\=\?\+\|\[\]\{\}\_a-zA-Z0-9_\`\~\!\#\%\^\&\*\(\)])/
sprintf( (ord($1) < 256) ? "\\x%02X" : "\\x{%X}", ord($1))
/eg;
}
return join ', ', @out;
}
__END__
=head1 NAME
Pod::Simple::PullParserToken -- tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
Given a $parser that's an object of class Pod::Simple::PullParser
(or a subclass)...
while(my $token = $parser->get_token) {
$DEBUG and print STDERR "Token: ", $token->dump, "\n";
if($token->is_start) {
...access $token->tagname, $token->attr, etc...
} elsif($token->is_text) {
...access $token->text, $token->text_r, etc...
} elsif($token->is_end) {
...access $token->tagname...
}
}
(Also see L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you should
get an object of a subclass of Pod::Simple::PullParserToken.
Subclasses will add methods, and will also inherit these methods:
=over
=item $token->type
This returns the type of the token. This will be either the string
"start", the string "text", or the string "end".
Once you know what the type of an object is, you then know what
subclass it belongs to, and therefore what methods it supports.
Yes, you could probably do the same thing with code like
$token->isa('Pod::Simple::PullParserEndToken'), but that's not so
pretty as using just $token->type, or even the following shortcuts:
=item $token->is_start
This is a shortcut for C<< $token->type() eq "start" >>
=item $token->is_text
This is a shortcut for C<< $token->type() eq "text" >>
=item $token->is_end
This is a shortcut for C<< $token->type() eq "end" >>
=item $token->dump
This returns a handy stringified value of this object. This
is useful for debugging, as in:
while(my $token = $parser->get_token) {
$DEBUG and print STDERR "Token: ", $token->dump, "\n";
...
}
=back
=head1 SEE ALSO
My subclasses:
L<Pod::Simple::PullParserStartToken>,
L<Pod::Simple::PullParserTextToken>, and
L<Pod::Simple::PullParserEndToken>.
L<Pod::Simple::PullParser> and L<Pod::Simple>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[��%� g g Simple/XHTML.pmnu �[��� =pod
=head1 NAME
Pod::Simple::XHTML -- format Pod as validating XHTML
=head1 SYNOPSIS
use Pod::Simple::XHTML;
my $parser = Pod::Simple::XHTML->new();
...
$parser->parse_file('path/to/file.pod');
=head1 DESCRIPTION
This class is a formatter that takes Pod and renders it as XHTML
validating HTML.
This is a subclass of L<Pod::Simple::Methody> and inherits all its
methods. The implementation is entirely different than
L<Pod::Simple::HTML>, but it largely preserves the same interface.
=head2 Minimal code
use Pod::Simple::XHTML;
my $psx = Pod::Simple::XHTML->new;
$psx->output_string(\my $html);
$psx->parse_file('path/to/Module/Name.pm');
open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
print $out $html;
You can also control the character encoding and entities. For example, if
you're sure that the POD is properly encoded (using the C<=encoding> command),
you can prevent high-bit characters from being encoded as HTML entities and
declare the output character set as UTF-8 before parsing, like so:
$psx->html_charset('UTF-8');
$psx->html_encode_chars(q{&<>'"});
=cut
package Pod::Simple::XHTML;
use strict;
use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
$VERSION = '3.35';
use Pod::Simple::Methody ();
@ISA = ('Pod::Simple::Methody');
BEGIN {
$HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
}
my %entities = (
q{>} => 'gt',
q{<} => 'lt',
q{'} => '#39',
q{"} => 'quot',
q{&} => 'amp',
);
sub encode_entities {
my $self = shift;
my $ents = $self->html_encode_chars;
return HTML::Entities::encode_entities( $_[0], $ents ) if $HAS_HTML_ENTITIES;
if (defined $ents) {
$ents =~ s,(?<!\\)([]/]),\\$1,g;
$ents =~ s,(?<!\\)\\\z,\\\\,;
} else {
$ents = join '', keys %entities;
}
my $str = $_[0];
$str =~ s/([$ents])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/ge;
return $str;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=head1 METHODS
Pod::Simple::XHTML offers a number of methods that modify the format of
the HTML output. Call these after creating the parser object, but before
the call to C<parse_file>:
my $parser = Pod::PseudoPod::HTML->new();
$parser->set_optional_param("value");
$parser->parse_file($file);
=head2 perldoc_url_prefix
In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
to put before the "Foo%3a%3aBar". The default value is
"http://search.cpan.org/perldoc?".
=head2 perldoc_url_postfix
What to put after "Foo%3a%3aBar" in the URL. This option is not set by
default.
=head2 man_url_prefix
In turning C<< L<crontab(5)> >> into http://whatever/man/1/crontab, what
to put before the "1/crontab". The default value is
"http://man.he.net/man".
=head2 man_url_postfix
What to put after "1/crontab" in the URL. This option is not set by default.
=head2 title_prefix, title_postfix
What to put before and after the title in the head. The values should
already be &-escaped.
=head2 html_css
$parser->html_css('path/to/style.css');
The URL or relative path of a CSS file to include. This option is not
set by default.
=head2 html_javascript
The URL or relative path of a JavaScript file to pull in. This option is
not set by default.
=head2 html_doctype
A document type tag for the file. This option is not set by default.
=head2 html_charset
The character set to declare in the Content-Type meta tag created by default
for C<html_header_tags>. Note that this option will be ignored if the value of
C<html_header_tags> is changed. Defaults to "ISO-8859-1".
=head2 html_header_tags
Additional arbitrary HTML tags for the header of the document. The
default value is just a content type header tag:
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
Add additional meta tags here, or blocks of inline CSS or JavaScript
(wrapped in the appropriate tags).
=head3 html_encode_chars
A string containing all characters that should be encoded as HTML entities,
specified using the regular expression character class syntax (what you find
within brackets in regular expressions). This value will be passed as the
second argument to the C<encode_entities> function of L<HTML::Entities>. If
L<HTML::Entities> is not installed, then any characters other than C<&<>"'>
will be encoded numerically.
=head2 html_h_level
This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For
example, if C<html_h_level> is set to 2, a head1 will produce an H2, a head2
will produce an H3, and so on.
=head2 default_title
Set a default title for the page if no title can be determined from the
content. The value of this string should already be &-escaped.
=head2 force_title
Force a title for the page (don't try to determine it from the content).
The value of this string should already be &-escaped.
=head2 html_header, html_footer
Set the HTML output at the beginning and end of each file. The default
header includes a title, a doctype tag (if C<html_doctype> is set), a
content tag (customized by C<html_header_tags>), a tag for a CSS file
(if C<html_css> is set), and a tag for a Javascript file (if
C<html_javascript> is set). The default footer simply closes the C<html>
and C<body> tags.
The options listed above customize parts of the default header, but
setting C<html_header> or C<html_footer> completely overrides the
built-in header or footer. These may be useful if you want to use
template tags instead of literal HTML headers and footers or are
integrating converted POD pages in a larger website.
If you want no headers or footers output in the HTML, set these options
to the empty string.
=head2 index
Whether to add a table-of-contents at the top of each page (called an
index for the sake of tradition).
=head2 anchor_items
Whether to anchor every definition C<=item> directive. This needs to be
enabled if you want to be able to link to specific C<=item> directives, which
are output as C<< <dt> >> elements. Disabled by default.
=head2 backlink
Whether to turn every =head1 directive into a link pointing to the top
of the page (specifically, the opening body tag).
=cut
__PACKAGE__->_accessorize(
'perldoc_url_prefix',
'perldoc_url_postfix',
'man_url_prefix',
'man_url_postfix',
'title_prefix', 'title_postfix',
'html_css',
'html_javascript',
'html_doctype',
'html_charset',
'html_encode_chars',
'html_h_level',
'title', # Used internally for the title extracted from the content
'default_title',
'force_title',
'html_header',
'html_footer',
'index',
'anchor_items',
'backlink',
'batch_mode', # whether we're in batch mode
'batch_mode_current_level',
# When in batch mode, how deep the current module is: 1 for "LWP",
# 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=head1 SUBCLASSING
If the standard options aren't enough, you may want to subclass
Pod::Simple::XHMTL. These are the most likely candidates for methods
you'll want to override when subclassing.
=cut
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->perldoc_url_prefix('http://search.cpan.org/perldoc?');
$new->man_url_prefix('http://man.he.net/man');
$new->html_charset('ISO-8859-1');
$new->nix_X_codes(1);
$new->{'scratch'} = '';
$new->{'to_index'} = [];
$new->{'output'} = [];
$new->{'saved'} = [];
$new->{'ids'} = { '_podtop_' => 1 }; # used in <body>
$new->{'in_li'} = [];
$new->{'__region_targets'} = [];
$new->{'__literal_targets'} = {};
$new->accept_targets_as_html( 'html', 'HTML' );
return $new;
}
sub html_header_tags {
my $self = shift;
return $self->{html_header_tags} = shift if @_;
return $self->{html_header_tags}
||= '<meta http-equiv="Content-Type" content="text/html; charset='
. $self->html_charset . '" />';
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=head2 handle_text
This method handles the body of text within any element: it's the body
of a paragraph, or everything between a "=begin" tag and the
corresponding "=end" tag, or the text within an L entity, etc. You would
want to override this if you are adding a custom element type that does
more than just display formatted text. Perhaps adding a way to generate
HTML tables from an extended version of POD.
So, let's say you want to add a custom element called 'foo'. In your
subclass's C<new> method, after calling C<SUPER::new> you'd call:
$new->accept_targets_as_text( 'foo' );
Then override the C<start_for> method in the subclass to check for when
"$flags->{'target'}" is equal to 'foo' and set a flag that marks that
you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
C<handle_text> method to check for the flag, and pass $text to your
custom subroutine to construct the HTML output for 'foo' elements,
something like:
sub handle_text {
my ($self, $text) = @_;
if ($self->{'in_foo'}) {
$self->{'scratch'} .= build_foo_html($text);
return;
}
$self->SUPER::handle_text($text);
}
=head2 handle_code
This method handles the body of text that is marked up to be code.
You might for instance override this to plug in a syntax highlighter.
The base implementation just escapes the text.
The callback methods C<start_code> and C<end_code> emits the C<code> tags
before and after C<handle_code> is invoked, so you might want to override these
together with C<handle_code> if this wrapping isn't suitable.
Note that the code might be broken into multiple segments if there are
nested formatting codes inside a C<< CE<lt>...> >> sequence. In between the
calls to C<handle_code> other markup tags might have been emitted in that
case. The same is true for verbatim sections if the C<codes_in_verbatim>
option is turned on.
=head2 accept_targets_as_html
This method behaves like C<accept_targets_as_text>, but also marks the region
as one whose content should be emitted literally, without HTML entity escaping
or wrapping in a C<div> element.
=cut
sub __in_literal_xhtml_region {
return unless @{ $_[0]{__region_targets} };
my $target = $_[0]{__region_targets}[-1];
return $_[0]{__literal_targets}{ $target };
}
sub accept_targets_as_html {
my ($self, @targets) = @_;
$self->accept_targets(@targets);
$self->{__literal_targets}{$_} = 1 for @targets;
}
sub handle_text {
# escape special characters in HTML (<, >, &, etc)
my $text = $_[0]->__in_literal_xhtml_region
? $_[1]
: $_[0]->encode_entities( $_[1] );
if ($_[0]{'in_code'} && @{$_[0]{'in_code'}}) {
# Intentionally use the raw text in $_[1], even if we're not in a
# literal xhtml region, since handle_code calls encode_entities.
$_[0]->handle_code( $_[1], $_[0]{'in_code'}[-1] );
} else {
if ($_[0]->{in_for}) {
my $newlines = $_[0]->__in_literal_xhtml_region ? "\n\n" : '';
if ($_[0]->{started_for}) {
if ($text =~ /\S/) {
delete $_[0]->{started_for};
$_[0]{'scratch'} .= $text . $newlines;
}
# Otherwise, append nothing until we have something to append.
} else {
# The parser sometimes preserves newlines and sometimes doesn't!
$text =~ s/\n\z//;
$_[0]{'scratch'} .= $text . $newlines;
}
} else {
# Just plain text.
$_[0]{'scratch'} .= $text;
}
}
$_[0]{htext} .= $text if $_[0]{'in_head'};
}
sub start_code {
$_[0]{'scratch'} .= '<code>';
}
sub end_code {
$_[0]{'scratch'} .= '</code>';
}
sub handle_code {
$_[0]{'scratch'} .= $_[0]->encode_entities( $_[1] );
}
sub start_Para {
$_[0]{'scratch'} .= '<p>';
}
sub start_Verbatim {
$_[0]{'scratch'} = '<pre>';
push(@{$_[0]{'in_code'}}, 'Verbatim');
$_[0]->start_code($_[0]{'in_code'}[-1]);
}
sub start_head1 { $_[0]{'in_head'} = 1; $_[0]{htext} = ''; }
sub start_head2 { $_[0]{'in_head'} = 2; $_[0]{htext} = ''; }
sub start_head3 { $_[0]{'in_head'} = 3; $_[0]{htext} = ''; }
sub start_head4 { $_[0]{'in_head'} = 4; $_[0]{htext} = ''; }
sub start_item_number {
$_[0]{'scratch'} = "</li>\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
$_[0]{'scratch'} .= '<li><p>';
push @{$_[0]{'in_li'}}, 1;
}
sub start_item_bullet {
$_[0]{'scratch'} = "</li>\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
$_[0]{'scratch'} .= '<li><p>';
push @{$_[0]{'in_li'}}, 1;
}
sub start_item_text {
# see end_item_text
}
sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
sub start_over_number { $_[0]{'scratch'} = '<ol>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
sub start_over_text {
$_[0]{'scratch'} = '<dl>';
$_[0]{'dl_level'}++;
$_[0]{'in_dd'} ||= [];
$_[0]->emit
}
sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit }
sub end_over_number {
$_[0]{'scratch'} = "</li>\n" if ( pop @{$_[0]{'in_li'}} );
$_[0]{'scratch'} .= '</ol>';
pop @{$_[0]{'in_li'}};
$_[0]->emit;
}
sub end_over_bullet {
$_[0]{'scratch'} = "</li>\n" if ( pop @{$_[0]{'in_li'}} );
$_[0]{'scratch'} .= '</ul>';
pop @{$_[0]{'in_li'}};
$_[0]->emit;
}
sub end_over_text {
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
$_[0]{'scratch'} = "</dd>\n";
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
}
$_[0]{'scratch'} .= '</dl>';
$_[0]{'dl_level'}--;
$_[0]->emit;
}
# . . . . . Now the actual formatters:
sub end_Para { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_Verbatim {
$_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
$_[0]{'scratch'} .= '</pre>';
$_[0]->emit;
}
sub _end_head {
my $h = delete $_[0]{in_head};
my $add = $_[0]->html_h_level;
$add = 1 unless defined $add;
$h += $add - 1;
my $id = $_[0]->idify($_[0]{htext});
my $text = $_[0]{scratch};
$_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
# backlinks enabled && =head1
? qq{<a href="#_podtop_"><h$h id="$id">$text</h$h></a>}
: qq{<h$h id="$id">$text</h$h>};
$_[0]->emit;
push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'htext'}];
}
sub end_head1 { shift->_end_head(@_); }
sub end_head2 { shift->_end_head(@_); }
sub end_head3 { shift->_end_head(@_); }
sub end_head4 { shift->_end_head(@_); }
sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_item_text {
# idify and anchor =item content if wanted
my $dt_id = $_[0]{'anchor_items'}
? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"'
: '';
# reset scratch
my $text = $_[0]{scratch};
$_[0]{'scratch'} = '';
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
$_[0]{'scratch'} = "</dd>\n";
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
}
$_[0]{'scratch'} .= qq{<dt$dt_id>$text</dt>\n<dd>};
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
$_[0]->emit;
}
# This handles =begin and =for blocks of all kinds.
sub start_for {
my ($self, $flags) = @_;
push @{ $self->{__region_targets} }, $flags->{target_matching};
$self->{started_for} = 1;
$self->{in_for} = 1;
unless ($self->__in_literal_xhtml_region) {
$self->{scratch} .= '<div';
$self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
$self->{scratch} .= ">\n\n";
}
}
sub end_for {
my ($self) = @_;
delete $self->{started_for};
delete $self->{in_for};
if ($self->__in_literal_xhtml_region) {
# Remove trailine newlines.
$self->{'scratch'} =~ s/\s+\z//s;
} else {
$self->{'scratch'} .= '</div>';
}
pop @{ $self->{__region_targets} };
$self->emit;
}
sub start_Document {
my ($self) = @_;
if (defined $self->html_header) {
$self->{'scratch'} .= $self->html_header;
$self->emit unless $self->html_header eq "";
} else {
my ($doctype, $title, $metatags, $bodyid);
$doctype = $self->html_doctype || '';
$title = $self->force_title || $self->title || $self->default_title || '';
$metatags = $self->html_header_tags || '';
if (my $css = $self->html_css) {
if ($css !~ /<link/) {
# this is required to be compatible with Pod::Simple::BatchHTML
$metatags .= '<link rel="stylesheet" href="'
. $self->encode_entities($css) . '" type="text/css" />';
} else {
$metatags .= $css;
}
}
if ($self->html_javascript) {
$metatags .= qq{\n<script type="text/javascript" src="} .
$self->html_javascript . '"></script>';
}
$bodyid = $self->backlink ? ' id="_podtop_"' : '';
$self->{'scratch'} .= <<"HTML";
$doctype
<html>
<head>
<title>$title</title>
$metatags
</head>
<body$bodyid>
HTML
$self->emit;
}
}
sub end_Document {
my ($self) = @_;
my $to_index = $self->{'to_index'};
if ($self->index && @{ $to_index } ) {
my @out;
my $level = 0;
my $indent = -1;
my $space = '';
my $id = ' id="index"';
for my $h (@{ $to_index }, [0]) {
my $target_level = $h->[0];
# Get to target_level by opening or closing ULs
if ($level == $target_level) {
$out[-1] .= '</li>';
} elsif ($level > $target_level) {
$out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/;
while ($level > $target_level) {
--$level;
push @out, (' ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul};
push @out, (' ' x --$indent) . '</ul>';
}
push @out, (' ' x --$indent) . '</li>' if $level;
} else {
while ($level < $target_level) {
++$level;
push @out, (' ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/;
push @out, (' ' x ++$indent) . "<ul$id>";
$id = '';
}
++$indent;
}
next unless $level;
$space = ' ' x $indent;
push @out, sprintf '%s<li><a href="#%s">%s</a>',
$space, $h->[1], $h->[2];
}
# Splice the index in between the HTML headers and the first element.
my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
}
if (defined $self->html_footer) {
$self->{'scratch'} .= $self->html_footer;
$self->emit unless $self->html_footer eq "";
} else {
$self->{'scratch'} .= "</body>\n</html>";
$self->emit;
}
if ($self->index) {
print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
@{$self->{'output'}} = ();
}
}
# Handling code tags
sub start_B { $_[0]{'scratch'} .= '<b>' }
sub end_B { $_[0]{'scratch'} .= '</b>' }
sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); }
sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); }
sub start_F { $_[0]{'scratch'} .= '<i>' }
sub end_F { $_[0]{'scratch'} .= '</i>' }
sub start_I { $_[0]{'scratch'} .= '<i>' }
sub end_I { $_[0]{'scratch'} .= '</i>' }
sub start_L {
my ($self, $flags) = @_;
my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
my $url = $self->encode_entities(
$type eq 'url' ? $to
: $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
: $type eq 'man' ? $self->resolve_man_page_link($to, $section)
: undef
);
# If it's an unknown type, use an attribute-less <a> like HTML.pm.
$self->{'scratch'} .= '<a' . ($url ? ' href="'. $url . '">' : '>');
}
sub end_L { $_[0]{'scratch'} .= '</a>' }
sub start_S { $_[0]{'scratch'} .= '<span style="white-space: nowrap;">' }
sub end_S { $_[0]{'scratch'} .= '</span>' }
sub emit {
my($self) = @_;
if ($self->index) {
push @{ $self->{'output'} }, $self->{'scratch'};
} else {
print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
}
$self->{'scratch'} = '';
return;
}
=head2 resolve_pod_page_link
my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
my $url = $pod->resolve_pod_page_link('perlpodspec');
my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
Resolves a POD link target (typically a module or POD file name) and section
name to a URL. The resulting link will be returned for the above examples as:
http://search.cpan.org/perldoc?Net::Ping#INSTALL
http://search.cpan.org/perldoc?perlpodspec
#SYNOPSIS
Note that when there is only a section argument the URL will simply be a link
to a section in the current document.
=cut
sub resolve_pod_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to || defined $section;
if (defined $section) {
$section = '#' . $self->idify($self->encode_entities($section), 1);
return $section unless defined $to;
} else {
$section = ''
}
return ($self->perldoc_url_prefix || '')
. $self->encode_entities($to) . $section
. ($self->perldoc_url_postfix || '');
}
=head2 resolve_man_page_link
my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
my $url = $pod->resolve_man_page_link('crontab');
Resolves a man page link target and numeric section to a URL. The resulting
link will be returned for the above examples as:
http://man.he.net/man5/crontab
http://man.he.net/man1/crontab
Note that the first argument is required. The section number will be parsed
from it, and if it's missing will default to 1. The second argument is
currently ignored, as L<man.he.net|http://man.he.net> does not currently
include linkable IDs or anchor names in its pages. Subclass to link to a
different man page HTTP server.
=cut
sub resolve_man_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to;
my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
return undef unless $page;
return ($self->man_url_prefix || '')
. ($part || 1) . "/" . $self->encode_entities($page)
. ($self->man_url_postfix || '');
}
=head2 idify
my $id = $pod->idify($text);
my $hash = $pod->idify($text, 1);
This method turns an arbitrary string into a valid XHTML ID attribute value.
The rules enforced, following
L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are:
=over
=item *
The id must start with a letter (a-z or A-Z)
=item *
All subsequent characters can be letters, numbers (0-9), hyphens (-),
underscores (_), colons (:), and periods (.).
=item *
The final character can't be a hyphen, colon, or period. URLs ending with these
characters, while allowed by XHTML, can be awkward to extract from plain text.
=item *
Each id must be unique within the document.
=back
In addition, the returned value will be unique within the context of the
Pod::Simple::XHTML object unless a second argument is passed a true value. ID
attributes should always be unique within a single XHTML document, but pass
the true value if you are creating not an ID but a URL hash to point to
an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>.
=cut
sub idify {
my ($self, $t, $not_unique) = @_;
for ($t) {
s/<[^>]+>//g; # Strip HTML.
s/&[^;]+;//g; # Strip entities.
s/^\s+//; s/\s+$//; # Strip white space.
s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
s/^[^a-zA-Z]+//; # First char must be a letter.
s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
s/[-:.]+$//; # Strip trailing punctuation.
}
return $t if $not_unique;
my $i = '';
$i++ while $self->{ids}{"$t$i"}++;
return "$t$i";
}
=head2 batch_mode_page_object_init
$pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
Called by L<Pod::Simple::HTMLBatch> so that the class has a chance to
initialize the converter. Internally it sets the C<batch_mode> property to
true and sets C<batch_mode_current_level()>, but Pod::Simple::XHTML does not
currently use those features. Subclasses might, though.
=cut
sub batch_mode_page_object_init {
my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
$self->batch_mode(1);
$self->batch_mode_current_level($depth);
return $self;
}
sub html_header_after_title {
}
1;
__END__
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2003-2005 Allison Randal.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 ACKNOWLEDGEMENTS
Thanks to L<Hurricane Electric|http://he.net/> for permission to use its
L<Linux man pages online|http://man.he.net/> site for man page links.
Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
site for Perl module links.
=head1 AUTHOR
Pod::Simpele::XHTML was created by Allison Randal <allison@perl.org>.
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[ B��� � Simple/TextContent.pmnu �[���
require 5;
package Pod::Simple::TextContent;
use strict;
use Carp ();
use Pod::Simple ();
use vars qw( @ISA $VERSION );
$VERSION = '3.35';
@ISA = ('Pod::Simple');
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->nix_X_codes(1);
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _handle_element_start {
print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
return;
}
sub _handle_text {
$_[1] =~ s/$Pod::Simple::shy//g;
$_[1] =~ s/$Pod::Simple::nbsp/ /g;
print {$_[0]{'output_fh'}} $_[1];
return;
}
sub _handle_element_end {
print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::TextContent -- get the text content of Pod
=head1 SYNOPSIS
TODO
perl -MPod::Simple::TextContent -e \
"exit Pod::Simple::TextContent->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is that parses Pod and dumps just the text content. It is
mainly meant for use by the Pod::Simple test suite, but you may find
some other use for it.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[E�L� � Simple/Text.pmnu �[���
require 5;
package Pod::Simple::Text;
use strict;
use Carp ();
use Pod::Simple::Methody ();
use Pod::Simple ();
use vars qw( @ISA $VERSION $FREAKYMODE);
$VERSION = '3.35';
@ISA = ('Pod::Simple::Methody');
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
? \&Pod::Simple::DEBUG
: sub() {0}
}
use Text::Wrap 98.112902 ();
$Text::Wrap::huge = 'overflow';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->accept_target_as_text(qw( text plaintext plain ));
$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->{'Thispara'} = '';
$new->{'Indent'} = 0;
$new->{'Indentstring'} = ' ';
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub handle_text { $_[0]{'Thispara'} .= $_[1] }
sub start_Para { $_[0]{'Thispara'} = '' }
sub start_head1 { $_[0]{'Thispara'} = '' }
sub start_head2 { $_[0]{'Thispara'} = '' }
sub start_head3 { $_[0]{'Thispara'} = '' }
sub start_head4 { $_[0]{'Thispara'} = '' }
sub start_Verbatim { $_[0]{'Thispara'} = '' }
sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' }
sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " }
sub start_item_text { $_[0]{'Thispara'} = '' }
sub start_over_bullet { ++$_[0]{'Indent'} }
sub start_over_number { ++$_[0]{'Indent'} }
sub start_over_text { ++$_[0]{'Indent'} }
sub start_over_block { ++$_[0]{'Indent'} }
sub end_over_bullet { --$_[0]{'Indent'} }
sub end_over_number { --$_[0]{'Indent'} }
sub end_over_text { --$_[0]{'Indent'} }
sub end_over_block { --$_[0]{'Indent'} }
# . . . . . Now the actual formatters:
sub end_head1 { $_[0]->emit_par(-4) }
sub end_head2 { $_[0]->emit_par(-3) }
sub end_head3 { $_[0]->emit_par(-2) }
sub end_head4 { $_[0]->emit_par(-1) }
sub end_Para { $_[0]->emit_par( 0) }
sub end_item_bullet { $_[0]->emit_par( 0) }
sub end_item_number { $_[0]->emit_par( 0) }
sub end_item_text { $_[0]->emit_par(-2) }
sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' }
sub end_L {
if (my $link = delete $_[0]{'Link'}) {
# Append the URL to the output unless it's already present.
$_[0]{'Thispara'} .= " <$link->{to}>"
unless $_[0]{'Thispara'} =~ /\b\Q$link->{to}/;
}
}
sub emit_par {
my($self, $tweak_indent) = splice(@_,0,2);
my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) );
# Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
$out =~ s/$Pod::Simple::nbsp/ /g;
print {$self->{'output_fh'}} $out, "\n";
$self->{'Thispara'} = '';
return;
}
# . . . . . . . . . . And then off by its lonesome:
sub end_Verbatim {
my $self = shift;
$self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g;
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
#my $i = ' ' x (4 + $self->{'Indent'});
$self->{'Thispara'} =~ s/^/$i/mg;
print { $self->{'output_fh'} } '',
$self->{'Thispara'},
"\n\n"
;
$self->{'Thispara'} = '';
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::Text -- format Pod as plaintext
=head1 SYNOPSIS
perl -MPod::Simple::Text -e \
"exit Pod::Simple::Text->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is a formatter that takes Pod and renders it as
wrapped plaintext.
Its wrapping is done by L<Text::Wrap>, so you can change
C<$Text::Wrap::columns> as you like.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::TextContent>, L<Pod::Text>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[���М М Simple/HTMLBatch.pmnu �[���
require 5;
package Pod::Simple::HTMLBatch;
use strict;
use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION
$CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA
);
$VERSION = '3.35';
@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML!
# TODO: nocontents stylesheets. Strike some of the color variations?
use Pod::Simple::HTML ();
BEGIN {*esc = \&Pod::Simple::HTML::esc }
use File::Spec ();
use Pod::Simple::Search;
$SEARCH_CLASS ||= 'Pod::Simple::Search';
BEGIN {
if(defined &DEBUG) { } # no-op
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
else { *DEBUG = sub () {0}; }
}
$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
# flag to occasionally sleep for $SLEEPY - 1 seconds.
$HTML_RENDER_CLASS ||= "Pod::Simple::HTML";
#
# Methods beginning with "_" are particularly internal and possibly ugly.
#
Pod::Simple::_accessorize( __PACKAGE__,
'verbose', # how verbose to be during batch conversion
'html_render_class', # what class to use to render
'search_class', # what to use to search for POD documents
'contents_file', # If set, should be the name of a file (in current directory)
# to write the list of all modules to
'index', # will set $htmlpage->index(...) to this (true or false)
'progress', # progress object
'contents_page_start', 'contents_page_end',
'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad',
'no_contents_links', # set to true to suppress automatic adding of << links.
'_contents',
);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Just so we can run from the command line more easily
sub go {
@ARGV == 2 or die sprintf(
"Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n",
__PACKAGE__, __PACKAGE__,
);
if(defined($ARGV[1]) and length($ARGV[1])) {
my $d = $ARGV[1];
-e $d or die "I see no output directory named \"$d\"\nAborting";
-d $d or die "But \"$d\" isn't a directory!\nAborting";
-w $d or die "Directory \"$d\" isn't writeable!\nAborting";
}
__PACKAGE__->batch_convert(@ARGV);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub new {
my $new = bless {}, ref($_[0]) || $_[0];
$new->html_render_class($HTML_RENDER_CLASS);
$new->search_class($SEARCH_CLASS);
$new->verbose(1 + DEBUG);
$new->_contents([]);
$new->index(1);
$new-> _css_wad([]); $new->css_flurry(1);
$new->_javascript_wad([]); $new->javascript_flurry(1);
$new->contents_file(
'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION)
);
$new->contents_page_start( join "\n", grep $_,
$Pod::Simple::HTML::Doctype_decl,
"<html><head>",
"<title>Perl Documentation</title>",
$Pod::Simple::HTML::Content_decl,
"</head>",
"\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n"
); # override if you need a different title
$new->contents_page_end( sprintf(
"\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n",
esc(
ref($new),
eval {$new->VERSION} || $VERSION,
$], scalar(gmtime), scalar(localtime),
)));
return $new;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub muse {
my $self = shift;
if($self->verbose) {
print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n";
}
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub batch_convert {
my($self, $dirs, $outdir) = @_;
$self ||= __PACKAGE__; # tolerate being called as an optionless function
$self = $self->new unless ref $self; # tolerate being used as a class method
if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) {
$dirs = '';
} elsif(ref $dirs) {
# OK, it's an explicit set of dirs to scan, specified as an arrayref.
} else {
# OK, it's an explicit set of dirs to scan, specified as a
# string like "/thing:/also:/whatever/perl" (":"-delim, as usual)
# or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!)
require Config;
my $ps = quotemeta( $Config::Config{'path_sep'} || ":" );
$dirs = [ grep length($_), split qr/$ps/, $dirs ];
}
$outdir = $self->filespecsys->curdir
unless defined $outdir and length $outdir;
$self->_batch_convert_main($dirs, $outdir);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _batch_convert_main {
my($self, $dirs, $outdir) = @_;
# $dirs is either false, or an arrayref.
# $outdir is a pathspec.
$self->{'_batch_start_time'} ||= time();
$self->muse( "= ", scalar(localtime) );
$self->muse( "Starting batch conversion to \"$outdir\"" );
my $progress = $self->progress;
if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) {
require Pod::Simple::Progress;
$progress = Pod::Simple::Progress->new(
($self->verbose < 2) ? () # Default omission-delay
: ($self->verbose == 2) ? 1 # Reduce the omission-delay
: 0 # Eliminate the omission-delay
);
$self->progress($progress);
}
if($dirs) {
$self->muse(scalar(@$dirs), " dirs to scan: @$dirs");
} else {
$self->muse("Scanning \@INC. This could take a minute or two.");
}
my $mod2path = $self->find_all_pods($dirs ? $dirs : ());
$self->muse("Done scanning.");
my $total = keys %$mod2path;
unless($total) {
$self->muse("No pod found. Aborting batch conversion.\n");
return $self;
}
$progress and $progress->goal($total);
$self->muse("Now converting pod files to HTML.",
($total > 25) ? " This will take a while more." : ()
);
$self->_spray_css( $outdir );
$self->_spray_javascript( $outdir );
$self->_do_all_batch_conversions($mod2path, $outdir);
$progress and $progress->done(sprintf (
"Done converting %d files.", $self->{"__batch_conv_page_count"}
));
return $self->_batch_convert_finish($outdir);
return $self;
}
sub _do_all_batch_conversions {
my($self, $mod2path, $outdir) = @_;
$self->{"__batch_conv_page_count"} = 0;
foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) {
$self->_do_one_batch_conversion($module, $mod2path, $outdir);
sleep($SLEEPY - 1) if $SLEEPY;
}
return;
}
sub _batch_convert_finish {
my($self, $outdir) = @_;
$self->write_contents_file($outdir);
$self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done.");
$self->muse( "= ", scalar(localtime) );
$self->progress and $self->progress->done("All done!");
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _do_one_batch_conversion {
my($self, $module, $mod2path, $outdir, $outfile) = @_;
my $retval;
my $total = scalar keys %$mod2path;
my $infile = $mod2path->{$module};
my @namelets = grep m/\S/, split "::", $module;
# this can stick around in the contents LoL
my $depth = scalar @namelets;
die "Contentless thingie?! $module $infile" unless @namelets; #sanity
$outfile ||= do {
my @n = @namelets;
$n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION;
$self->filespecsys->catfile( $outdir, @n );
};
my $progress = $self->progress;
my $page = $self->html_render_class->new;
if(DEBUG > 5) {
$self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ",
ref($page), " render ($depth) $module => $outfile");
} elsif(DEBUG > 2) {
$self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile")
}
# Give each class a chance to init the converter:
$page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
if $page->can('batch_mode_page_object_init');
# Init for the index (TOC), too.
$self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
if $self->can('batch_mode_page_object_init');
# Now get busy...
$self->makepath($outdir => \@namelets);
$progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module");
if( $retval = $page->parse_from_file($infile, $outfile) ) {
++ $self->{"__batch_conv_page_count"} ;
$self->note_for_contents_file( \@namelets, $infile, $outfile );
} else {
$self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false.");
}
$page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth)
if $page->can('batch_mode_page_object_kill');
# The following isn't a typo. Note that it switches $self and $page.
$self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth)
if $self->can('batch_mode_page_object_kill');
DEBUG > 4 and printf STDERR "%s %sb < $infile %s %sb\n",
$outfile, -s $outfile, $infile, -s $infile
;
undef($page);
return $retval;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' }
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub note_for_contents_file {
my($self, $namelets, $infile, $outfile) = @_;
# I think the infile and outfile parts are never used. -- SMB
# But it's handy to have them around for debugging.
if( $self->contents_file ) {
my $c = $self->_contents();
push @$c,
[ join("::", @$namelets), $infile, $outfile, $namelets ]
# 0 1 2 3
;
DEBUG > 3 and print STDERR "Noting @$c[-1]\n";
}
return;
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub write_contents_file {
my($self, $outdir) = @_;
my $outfile = $self->_contents_filespec($outdir) || return;
$self->muse("Preparing list of modules for ToC");
my($toplevel, # maps toplevelbit => [all submodules]
$toplevel_form_freq, # ends up being 'foo' => 'Foo'
) = $self->_prep_contents_breakdown;
my $Contents = eval { $self->_wopen($outfile) };
if( $Contents ) {
$self->muse( "Writing contents file $outfile" );
} else {
warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all";
return;
}
$self->_write_contents_start( $Contents, $outfile, );
$self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq );
$self->_write_contents_end( $Contents, $outfile, );
return $outfile;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _write_contents_start {
my($self, $Contents, $outfile) = @_;
my $starter = $self->contents_page_start || '';
{
my $css_wad = $self->_css_wad_to_markup(1);
if( $css_wad ) {
$starter =~ s{(</head>)}{\n$css_wad\n$1}i; # otherwise nevermind
}
my $javascript_wad = $self->_javascript_wad_to_markup(1);
if( $javascript_wad ) {
$starter =~ s{(</head>)}{\n$javascript_wad\n$1}i; # otherwise nevermind
}
}
unless(print $Contents $starter, "<dl class='superindex'>\n" ) {
warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
close($Contents);
return 0;
}
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _write_contents_middle {
my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_;
foreach my $t (sort keys %$toplevel2submodules) {
my @downlines = sort {$a->[-1] cmp $b->[-1]}
@{ $toplevel2submodules->{$t} };
printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n],
esc( $t, $toplevel_form_freq->{$t} )
;
my($path, $name);
foreach my $e (@downlines) {
$name = $e->[0];
$path = join( "/", '.', esc( @{$e->[3]} ) )
. ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION);
print $Contents qq{ <a href="$path">}, esc($name), "</a> \n";
}
print $Contents "</dd>\n\n";
}
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _write_contents_end {
my($self, $Contents, $outfile) = @_;
unless(
print $Contents "</dl>\n",
$self->contents_page_end || '',
) {
warn "Couldn't write to $outfile: $!";
}
close($Contents) or warn "Couldn't close $outfile: $!";
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _prep_contents_breakdown {
my($self) = @_;
my $contents = $self->_contents;
my %toplevel; # maps lctoplevelbit => [all submodules]
my %toplevel_form_freq; # ends up being 'foo' => 'Foo'
# (mapping anycase forms to most freq form)
foreach my $entry (@$contents) {
my $toplevel =
$entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs'
# group all the perlwhatever docs together
: $entry->[3][0] # normal case
;
++$toplevel_form_freq{ lc $toplevel }{ $toplevel };
push @{ $toplevel{ lc $toplevel } }, $entry;
push @$entry, lc($entry->[0]); # add a sort-order key to the end
}
foreach my $toplevel (sort keys %toplevel) {
my $fgroup = $toplevel_form_freq{$toplevel};
$toplevel_form_freq{$toplevel} =
(
sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b }
keys %$fgroup
# This hash is extremely unlikely to have more than 4 members, so this
# sort isn't so very wasteful
)[0];
}
return(\%toplevel, \%toplevel_form_freq) if wantarray;
return \%toplevel;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _contents_filespec {
my($self, $outdir) = @_;
my $outfile = $self->contents_file;
return unless $outfile;
return $self->filespecsys->catfile( $outdir, $outfile );
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub makepath {
my($self, $outdir, $namelets) = @_;
return unless @$namelets > 1;
for my $i (0 .. ($#$namelets - 1)) {
my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] );
if(-e $dir) {
die "$dir exists but not as a directory!?" unless -d $dir;
next;
}
DEBUG > 3 and print STDERR " Making $dir\n";
mkdir $dir, 0777
or die "Can't mkdir $dir: $!\nAborting"
;
}
return;
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub batch_mode_page_object_init {
my $self = shift;
my($page, $module, $infile, $outfile, $depth) = @_;
# TODO: any further options to percolate onto this new object here?
$page->default_title($module);
$page->index( $self->index );
$page->html_css( $self-> _css_wad_to_markup($depth) );
$page->html_javascript( $self->_javascript_wad_to_markup($depth) );
$self->add_header_backlink($page, $module, $infile, $outfile, $depth);
$self->add_footer_backlink($page, $module, $infile, $outfile, $depth);
return $self;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub add_header_backlink {
my $self = shift;
return if $self->no_contents_links;
my($page, $module, $infile, $outfile, $depth) = @_;
$page->html_header_after_title( join '',
$page->html_header_after_title || '',
qq[<p class="backlinktop"><b><a name="___top" href="],
$self->url_up_to_contents($depth),
qq[" accesskey="1" title="All Documents"><<</a></b></p>\n],
)
if $self->contents_file
;
return;
}
sub add_footer_backlink {
my $self = shift;
return if $self->no_contents_links;
my($page, $module, $infile, $outfile, $depth) = @_;
$page->html_footer( join '',
qq[<p class="backlinkbottom"><b><a name="___bottom" href="],
$self->url_up_to_contents($depth),
qq[" title="All Documents"><<</a></b></p>\n],
$page->html_footer || '',
)
if $self->contents_file
;
return;
}
sub url_up_to_contents {
my($self, $depth) = @_;
--$depth;
return join '/', ('..') x $depth, esc($self->contents_file);
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub find_all_pods {
my($self, $dirs) = @_;
# You can override find_all_pods in a subclass if you want to
# do extra filtering or whatnot. But for the moment, we just
# pass to modnames2paths:
return $self->modnames2paths($dirs);
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub modnames2paths { # return a hashref mapping modulenames => paths
my($self, $dirs) = @_;
my $m2p;
{
my $search = $self->search_class->new;
DEBUG and print STDERR "Searching via $search\n";
$search->verbose(1) if DEBUG > 10;
$search->progress( $self->progress->copy->goal(0) ) if $self->progress;
$search->shadows(0); # don't bother noting shadowed files
$search->inc( $dirs ? 0 : 1 );
$search->survey( $dirs ? @$dirs : () );
$m2p = $search->name2path;
die "What, no name2path?!" unless $m2p;
}
$self->muse("That's odd... no modules found!") unless keys %$m2p;
if( DEBUG > 4 ) {
print STDERR "Modules found (name => path):\n";
foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) {
print STDERR " $m $$m2p{$m}\n";
}
print STDERR "(total ", scalar(keys %$m2p), ")\n\n";
} elsif( DEBUG ) {
print STDERR "Found ", scalar(keys %$m2p), " modules.\n";
}
$self->muse( "Found ", scalar(keys %$m2p), " modules." );
# return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref
return $m2p;
}
#===========================================================================
sub _wopen {
# this is abstracted out so that the daemon class can override it
my($self, $outpath) = @_;
require Symbol;
my $out_fh = Symbol::gensym();
DEBUG > 5 and print STDERR "Write-opening to $outpath\n";
return $out_fh if open($out_fh, "> $outpath");
require Carp;
Carp::croak("Can't write-open $outpath: $!");
}
#==========================================================================
sub add_css {
my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_;
return unless $url;
unless($name) {
# cook up a reasonable name based on the URL
$name = $url;
if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) {
$name = $1;
$name =~ s/\.css//i;
}
}
$media ||= 'all';
$content_type ||= 'text/css';
my $bunch = [$url, $name, $content_type, $media, $_code];
if($is_default) { unshift @{ $self->_css_wad }, $bunch }
else { push @{ $self->_css_wad }, $bunch }
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _spray_css {
my($self, $outdir) = @_;
return unless $self->css_flurry();
$self->_gen_css_wad();
my $lol = $self->_css_wad;
foreach my $chunk (@$lol) {
my $url = $chunk->[0];
my $outfile;
if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) {
$outfile = $self->filespecsys->catfile( $outdir, "$1" );
DEBUG > 5 and print STDERR "Noting $$chunk[0] as a file I'll create.\n";
} else {
DEBUG > 5 and print STDERR "OK, noting $$chunk[0] as an external CSS.\n";
# Requires no further attention.
next;
}
#$self->muse( "Writing autogenerated CSS file $outfile" );
my $Cssout = $self->_wopen($outfile);
print $Cssout ${$chunk->[-1]}
or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
close($Cssout);
DEBUG > 5 and print STDERR "Wrote $outfile\n";
}
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _css_wad_to_markup {
my($self, $depth) = @_;
my @css = @{ $self->_css_wad || return '' };
return '' unless @css;
my $rel = 'stylesheet';
my $out = '';
--$depth;
my $uplink = $depth ? ('../' x $depth) : '';
foreach my $chunk (@css) {
next unless $chunk and @$chunk;
my( $url1, $url2, $title, $type, $media) = (
$self->_maybe_uplink( $chunk->[0], $uplink ),
esc(grep !ref($_), @$chunk)
);
$out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n};
$rel = 'alternate stylesheet'; # alternates = all non-first iterations
}
return $out;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _maybe_uplink {
# if the given URL looks relative, return the given uplink string --
# otherwise return emptystring
my($self, $url, $uplink) = @_;
($url =~ m{^\./} or $url !~ m{[/\:]} )
? $uplink
: ''
# qualify it, if/as needed
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _gen_css_wad {
my $self = $_[0];
my $css_template = $self->_css_template;
foreach my $variation (
# Commented out for sake of concision:
#
# 011n=black_with_red_on_white
# 001n=black_with_yellow_on_white
# 101n=black_with_green_on_white
# 110=white_with_yellow_on_black
# 010=white_with_green_on_black
# 011=white_with_blue_on_black
# 100=white_with_red_on_black
'110n=blkbluw', # black_with_blue_on_white
'010n=blkmagw', # black_with_magenta_on_white
'100n=blkcynw', # black_with_cyan_on_white
'101=whtprpk', # white_with_purple_on_black
'001=whtnavk', # white_with_navy_blue_on_black
'010a=grygrnk', # grey_with_green_on_black
'010b=whtgrng', # white_with_green_on_grey
'101an=blkgrng', # black_with_green_on_grey
'101bn=grygrnw', # grey_with_green_on_white
) {
my $outname = $variation;
my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3)
if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s;
@swap = () if '010' eq join '', @swap; # 010 is a swop-no-op!
my $this_css =
"/* This file is autogenerated. Do not edit. $variation */\n\n"
. $css_template;
# Only look at three-digitty colors, for now at least.
if( $flipmode =~ m/n/ ) {
$this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg;
$this_css =~ s/\bthin\b/medium/g;
}
$this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b>
< join '', '#', ($1,$2,$3)[@swap] >eg if @swap;
if( $flipmode =~ m/a/)
{ $this_css =~ s/#fff\b/#999/gi } # black -> dark grey
elsif($flipmode =~ m/b/)
{ $this_css =~ s/#000\b/#666/gi } # white -> light grey
my $name = $outname;
$name =~ tr/-_/ /;
$self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
}
# Now a few indexless variations:
foreach my $variation (
'blkbluw', # black_with_blue_on_white
'whtpurk', # white_with_purple_on_black
'whtgrng', # white_with_green_on_grey
'grygrnw', # grey_with_green_on_white
) {
my $outname = $variation;
my $this_css = join "\n",
"/* This file is autogenerated. Do not edit. $outname */\n",
"\@import url(\"./_$variation.css\");",
".indexgroup { display: none; }",
"\n",
;
my $name = $outname;
$name =~ tr/-_/ /;
$self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
}
return;
}
sub _color_negate {
my $x = lc $_[0];
$x =~ tr[0123456789abcdef]
[fedcba9876543210];
return $x;
}
#===========================================================================
sub add_javascript {
my($self, $url, $content_type, $_code) = @_;
return unless $url;
push @{ $self->_javascript_wad }, [
$url, $content_type || 'text/javascript', $_code
];
return;
}
sub _spray_javascript {
my($self, $outdir) = @_;
return unless $self->javascript_flurry();
$self->_gen_javascript_wad();
my $lol = $self->_javascript_wad;
foreach my $script (@$lol) {
my $url = $script->[0];
my $outfile;
if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) {
$outfile = $self->filespecsys->catfile( $outdir, "$1" );
DEBUG > 5 and print STDERR "Noting $$script[0] as a file I'll create.\n";
} else {
DEBUG > 5 and print STDERR "OK, noting $$script[0] as an external JavaScript.\n";
next;
}
#$self->muse( "Writing JavaScript file $outfile" );
my $Jsout = $self->_wopen($outfile);
print $Jsout ${$script->[-1]}
or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
close($Jsout);
DEBUG > 5 and print STDERR "Wrote $outfile\n";
}
return;
}
sub _gen_javascript_wad {
my $self = $_[0];
my $js_code = $self->_javascript || return;
$self->add_javascript( "_podly.js", 0, \$js_code);
return;
}
sub _javascript_wad_to_markup {
my($self, $depth) = @_;
my @scripts = @{ $self->_javascript_wad || return '' };
return '' unless @scripts;
my $out = '';
--$depth;
my $uplink = $depth ? ('../' x $depth) : '';
foreach my $s (@scripts) {
next unless $s and @$s;
my( $url1, $url2, $type, $media) = (
$self->_maybe_uplink( $s->[0], $uplink ),
esc(grep !ref($_), @$s)
);
$out .= qq{<script type="$type" src="$url1$url2"></script>\n};
}
return $out;
}
#===========================================================================
sub _css_template { return $CSS }
sub _javascript { return $JAVASCRIPT }
$CSS = <<'EOCSS';
/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */
@media all { .hide { display: none; } }
@media print {
.noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none }
* {
border-color: black !important;
color: black !important;
background-color: transparent !important;
background-image: none !important;
}
dl.superindex > dd {
word-spacing: .6em;
}
}
@media aural, braille, embossed {
div.indexgroup { display: none; } /* Too noisy, don't you think? */
dl.superindex > dt:before { content: "Group "; }
dl.superindex > dt:after { content: " contains:"; }
.backlinktop a:before { content: "Back to contents"; }
.backlinkbottom a:before { content: "Back to contents"; }
}
@media aural {
dl.superindex > dt { pause-before: 600ms; }
}
@media screen, tty, tv, projection {
.noscreen { display: none; }
a:link { color: #7070ff; text-decoration: underline; }
a:visited { color: #e030ff; text-decoration: underline; }
a:active { color: #800000; text-decoration: underline; }
body.contentspage a { text-decoration: none; }
a.u { color: #fff !important; text-decoration: none; }
body.pod {
margin: 0 5px;
color: #fff;
background-color: #000;
}
body.pod h1, body.pod h2, body.pod h3, body.pod h4 {
font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
font-weight: normal;
margin-top: 1.2em;
margin-bottom: .1em;
border-top: thin solid transparent;
/* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */
}
body.pod h1 { border-top-color: #0a0; }
body.pod h2 { border-top-color: #080; }
body.pod h3 { border-top-color: #040; }
body.pod h4 { border-top-color: #010; }
p.backlinktop + h1 { border-top: none; margin-top: 0em; }
p.backlinktop + h2 { border-top: none; margin-top: 0em; }
p.backlinktop + h3 { border-top: none; margin-top: 0em; }
p.backlinktop + h4 { border-top: none; margin-top: 0em; }
body.pod dt {
font-size: 105%; /* just a wee bit more than normal */
}
.indexgroup { font-size: 80%; }
.backlinktop, .backlinkbottom {
margin-left: -5px;
margin-right: -5px;
background-color: #040;
border-top: thin solid #050;
border-bottom: thin solid #050;
}
.backlinktop a, .backlinkbottom a {
text-decoration: none;
color: #080;
background-color: #000;
border: thin solid #0d0;
}
.backlinkbottom { margin-bottom: 0; padding-bottom: 0; }
.backlinktop { margin-top: 0; padding-top: 0; }
body.contentspage {
color: #fff;
background-color: #000;
}
body.contentspage h1 {
color: #0d0;
margin-left: 1em;
margin-right: 1em;
text-indent: -.9em;
font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
font-weight: normal;
border-top: thin solid #fff;
border-bottom: thin solid #fff;
text-align: center;
}
dl.superindex > dt {
font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
font-weight: normal;
font-size: 90%;
margin-top: .45em;
/* margin-bottom: -.15em; */
}
dl.superindex > dd {
word-spacing: .6em; /* most important rule here! */
}
dl.superindex > a:link {
text-decoration: none;
color: #fff;
}
.contentsfooty {
border-top: thin solid #999;
font-size: 90%;
}
}
/* The End */
EOCSS
#==========================================================================
$JAVASCRIPT = <<'EOJAVASCRIPT';
// From http://www.alistapart.com/articles/alternate/
function setActiveStyleSheet(title) {
var i, a, main;
for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) {
a.disabled = true;
if(a.getAttribute("title") == title) a.disabled = false;
}
}
}
function getActiveStyleSheet() {
var i, a;
for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
if( a.getAttribute("rel").indexOf("style") != -1
&& a.getAttribute("title")
&& !a.disabled
) return a.getAttribute("title");
}
return null;
}
function getPreferredStyleSheet() {
var i, a;
for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
if( a.getAttribute("rel").indexOf("style") != -1
&& a.getAttribute("rel").indexOf("alt") == -1
&& a.getAttribute("title")
) return a.getAttribute("title");
}
return null;
}
function createCookie(name,value,days) {
if (days) {
var date = new Date();
date.setTime(date.getTime()+(days*24*60*60*1000));
var expires = "; expires="+date.toGMTString();
}
else expires = "";
document.cookie = name+"="+value+expires+"; path=/";
}
function readCookie(name) {
var nameEQ = name + "=";
var ca = document.cookie.split(';');
for(var i=0 ; i < ca.length ; i++) {
var c = ca[i];
while (c.charAt(0)==' ') c = c.substring(1,c.length);
if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
}
return null;
}
window.onload = function(e) {
var cookie = readCookie("style");
var title = cookie ? cookie : getPreferredStyleSheet();
setActiveStyleSheet(title);
}
window.onunload = function(e) {
var title = getActiveStyleSheet();
createCookie("style", title, 365);
}
var cookie = readCookie("style");
var title = cookie ? cookie : getPreferredStyleSheet();
setActiveStyleSheet(title);
// The End
EOJAVASCRIPT
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1;
__END__
=head1 NAME
Pod::Simple::HTMLBatch - convert several Pod files to several HTML files
=head1 SYNOPSIS
perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out
=head1 DESCRIPTION
This module is used for running batch-conversions of a lot of HTML
documents
This class is NOT a subclass of Pod::Simple::HTML
(nor of bad old Pod::Html) -- although it uses
Pod::Simple::HTML for doing the conversion of each document.
The normal use of this class is like so:
use Pod::Simple::HTMLBatch;
my $batchconv = Pod::Simple::HTMLBatch->new;
$batchconv->some_option( some_value );
$batchconv->some_other_option( some_other_value );
$batchconv->batch_convert( \@search_dirs, $output_dir );
=head2 FROM THE COMMAND LINE
Note that this class also provides
(but does not export) the function Pod::Simple::HTMLBatch::go.
This is basically just a shortcut for C<<
Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>.
It's meant to be handy for calling from the command line.
However, the shortcut requires that you specify exactly two command-line
arguments, C<indirs> and C<outdir>.
Example:
% mkdir out_html
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
(to convert the pod from Perl's @INC
files under the directory ./out_html)
(Note that the command line there contains a literal atsign-I-N-C. This
is handled as a special case by batch_convert, in order to save you having
to enter the odd-looking "" as the first command-line parameter when you
mean "just use whatever's in @INC".)
Example:
% mkdir ../seekrut
% chmod og-rx ../seekrut
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../seekrut
(to convert the pod under the current dir into HTML
files under the directory ./seekrut)
Example:
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs .
(to convert all pod from happydocs into the current directory)
=head1 MAIN METHODS
=over
=item $batchconv = Pod::Simple::HTMLBatch->new;
This TODO
=item $batchconv->batch_convert( I<indirs>, I<outdir> );
this TODO
=item $batchconv->batch_convert( undef , ...);
=item $batchconv->batch_convert( q{@INC}, ...);
These two values for I<indirs> specify that the normal Perl @INC
=item $batchconv->batch_convert( \@dirs , ...);
This specifies that the input directories are the items in
the arrayref C<\@dirs>.
=item $batchconv->batch_convert( "somedir" , ...);
This specifies that the director "somedir" is the input.
(This can be an absolute or relative path, it doesn't matter.)
A common value you might want would be just "." for the current
directory:
$batchconv->batch_convert( "." , ...);
=item $batchconv->batch_convert( 'somedir:someother:also' , ...);
This specifies that you want the dirs "somedir", "someother", and "also"
scanned, just as if you'd passed the arrayref
C<[qw( somedir someother also)]>. Note that a ":"-separator is normal
under Unix, but Under MSWin, you'll need C<'somedir;someother;also'>
instead, since the pathsep on MSWin is ";" instead of ":". (And
I<that> is because ":" often comes up in paths, like
C<"c:/perl/lib">.)
(Exactly what separator character should be used, is gotten from
C<$Config::Config{'path_sep'}>, via the L<Config> module.)
=item $batchconv->batch_convert( ... , undef );
This specifies that you want the HTML output to go into the current
directory.
(Note that a missing or undefined value means a different thing in
the first slot than in the second. That's so that C<batch_convert()>
with no arguments (or undef arguments) means "go from @INC, into
the current directory.)
=item $batchconv->batch_convert( ... , 'somedir' );
This specifies that you want the HTML output to go into the
directory 'somedir'.
(This can be an absolute or relative path, it doesn't matter.)
=back
Note that you can also call C<batch_convert> as a class method,
like so:
Pod::Simple::HTMLBatch->batch_convert( ... );
That is just short for this:
Pod::Simple::HTMLBatch-> new-> batch_convert(...);
That is, it runs a conversion with default options, for
whatever inputdirs and output dir you specify.
=head2 ACCESSOR METHODS
The following are all accessor methods -- that is, they don't do anything
on their own, but just alter the contents of the conversion object,
which comprises the options for this particular batch conversion.
We show the "put" form of the accessors below (i.e., the syntax you use
for setting the accessor to a specific value). But you can also
call each method with no parameters to get its current value. For
example, C<< $self->contents_file() >> returns the current value of
the contents_file attribute.
=over
=item $batchconv->verbose( I<nonnegative_integer> );
This controls how verbose to be during batch conversion, as far as
notes to STDOUT (or whatever is C<select>'d) about how the conversion
is going. If 0, no progress information is printed.
If 1 (the default value), some progress information is printed.
Higher values print more information.
=item $batchconv->index( I<true-or-false> );
This controls whether or not each HTML page is liable to have a little
table of contents at the top (which we call an "index" for historical
reasons). This is true by default.
=item $batchconv->contents_file( I<filename> );
If set, should be the name of a file (in the output directory)
to write the HTML index to. The default value is "index.html".
If you set this to a false value, no contents file will be written.
=item $batchconv->contents_page_start( I<HTML_string> );
This specifies what string should be put at the beginning of
the contents page.
The default is a string more or less like this:
<html>
<head><title>Perl Documentation</title></head>
<body class='contentspage'>
<h1>Perl Documentation</h1>
=item $batchconv->contents_page_end( I<HTML_string> );
This specifies what string should be put at the end of the contents page.
The default is a string more or less like this:
<p class='contentsfooty'>Generated by
Pod::Simple::HTMLBatch v3.01 under Perl v5.008
<br >At Fri May 14 22:26:42 2004 GMT,
which is Fri May 14 14:26:42 2004 local time.</p>
=item $batchconv->add_css( $url );
TODO
=item $batchconv->add_javascript( $url );
TODO
=item $batchconv->css_flurry( I<true-or-false> );
If true (the default value), we autogenerate some CSS files in the
output directory, and set our HTML files to use those.
TODO: continue
=item $batchconv->javascript_flurry( I<true-or-false> );
If true (the default value), we autogenerate a JavaScript in the
output directory, and set our HTML files to use it. Currently,
the JavaScript is used only to get the browser to remember what
stylesheet it prefers.
TODO: continue
=item $batchconv->no_contents_links( I<true-or-false> );
TODO
=item $batchconv->html_render_class( I<classname> );
This sets what class is used for rendering the files.
The default is "Pod::Simple::HTML". If you set it to something else,
it should probably be a subclass of Pod::Simple::HTML, and you should
C<require> or C<use> that class so that's it's loaded before
Pod::Simple::HTMLBatch tries loading it.
=item $batchconv->search_class( I<classname> );
This sets what class is used for searching for the files.
The default is "Pod::Simple::Search". If you set it to something else,
it should probably be a subclass of Pod::Simple::Search, and you should
C<require> or C<use> that class so that's it's loaded before
Pod::Simple::HTMLBatch tries loading it.
=back
=head1 NOTES ON CUSTOMIZATION
TODO
call add_css($someurl) to add stylesheet as alternate
call add_css($someurl,1) to add as primary stylesheet
call add_javascript
subclass Pod::Simple::HTML and set $batchconv->html_render_class to
that classname
and maybe override
$page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
or maybe override
$batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
subclass Pod::Simple::Search and set $batchconv->search_class to
that classname
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[�tbP Simple/SimpleTree.pmnu �[���
require 5;
package Pod::Simple::SimpleTree;
use strict;
use Carp ();
use Pod::Simple ();
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
$VERSION = '3.35';
BEGIN {
@ISA = ('Pod::Simple');
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
}
__PACKAGE__->_accessorize(
'root', # root of the tree
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _handle_element_start { # self, tagname, attrhash
DEBUG > 2 and print STDERR "Handling $_[1] start-event\n";
my $x = [$_[1], $_[2]];
if($_[0]{'_currpos'}) {
push @{ $_[0]{'_currpos'}[0] }, $x; # insert in parent's child-list
unshift @{ $_[0]{'_currpos'} }, $x; # prefix to stack
} else {
DEBUG and print STDERR " And oo, it gets to be root!\n";
$_[0]{'_currpos'} = [ $_[0]{'root'} = $x ];
# first event! set to stack, and set as root.
}
DEBUG > 3 and print STDERR "Stack is now: ",
join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
return;
}
sub _handle_element_end { # self, tagname
DEBUG > 2 and print STDERR "Handling $_[1] end-event\n";
shift @{$_[0]{'_currpos'}};
DEBUG > 3 and print STDERR "Stack is now: ",
join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
return;
}
sub _handle_text { # self, text
DEBUG > 2 and print STDERR "Handling $_[1] text-event\n";
push @{ $_[0]{'_currpos'}[0] }, $_[1];
return;
}
# A bit of evil from the black box... please avert your eyes, kind souls.
sub _traverse_treelet_bit {
DEBUG > 2 and print STDERR "Handling $_[1] paragraph event\n";
my $self = shift;
push @{ $self->{'_currpos'}[0] }, [@_];
return;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
=head1 NAME
Pod::Simple::SimpleTree -- parse Pod into a simple parse tree
=head1 SYNOPSIS
% cat ptest.pod
=head1 PIE
I like B<pie>!
% perl -MPod::Simple::SimpleTree -MData::Dumper -e \
"print Dumper(Pod::Simple::SimpleTree->new->parse_file(shift)->root)" \
ptest.pod
$VAR1 = [
'Document',
{ 'start_line' => 1 },
[
'head1',
{ 'start_line' => 1 },
'PIE'
],
[
'Para',
{ 'start_line' => 3 },
'I like ',
[
'B',
{},
'pie'
],
'!'
]
];
=head1 DESCRIPTION
This class is of interest to people writing a Pod processor/formatter.
This class takes Pod and parses it, returning a parse tree made just
of arrayrefs, and hashrefs, and strings.
This is a subclass of L<Pod::Simple> and inherits all its methods.
This class is inspired by XML::Parser's "Tree" parsing-style, although
it doesn't use exactly the same LoL format.
=head1 METHODS
At the end of the parse, call C<< $parser->root >> to get the
tree's top node.
=head1 Tree Contents
Every element node in the parse tree is represented by an arrayref of
the form: C<[ I<elementname>, \%attributes, I<...subnodes...> ]>.
See the example tree dump in the Synopsis, above.
Every text node in the tree is represented by a simple (non-ref)
string scalar. So you can test C<ref($node)> to see whether you have
an element node or just a text node.
The top node in the tree is C<[ 'Document', \%attributes,
I<...subnodes...> ]>
=head1 SEE ALSO
L<Pod::Simple>
L<perllol>
L<The "Tree" subsubsection in XML::Parser|XML::Parser/"Tree">
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[z/�� � Simple/BlackBox.pmnu �[��� package Pod::Simple::BlackBox;
#
# "What's in the box?" "Pain."
#
###########################################################################
#
# This is where all the scary things happen: parsing lines into
# paragraphs; and then into directives, verbatims, and then also
# turning formatting sequences into treelets.
#
# Are you really sure you want to read this code?
#
#-----------------------------------------------------------------------------
#
# The basic work of this module Pod::Simple::BlackBox is doing the dirty work
# of parsing Pod into treelets (generally one per non-verbatim paragraph), and
# to call the proper callbacks on the treelets.
#
# Every node in a treelet is a ['name', {attrhash}, ...children...]
use integer; # vroom!
use strict;
use Carp ();
use vars qw($VERSION );
$VERSION = '3.35';
#use constant DEBUG => 7;
BEGIN {
require Pod::Simple;
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG
}
# Matches a character iff the character will have a different meaning
# if we choose CP1252 vs UTF-8 if there is no =encoding line.
# This is broken for early Perls on non-ASCII platforms.
my $non_ascii_re = eval "qr/[[:^ascii:]]/";
$non_ascii_re = qr/[\x80-\xFF]/ if ! defined $non_ascii_re;
my $utf8_bom;
if (($] ge 5.007_003)) {
$utf8_bom = "\x{FEFF}";
utf8::encode($utf8_bom);
} else {
$utf8_bom = "\xEF\xBB\xBF"; # No EBCDIC BOM detection for early Perls.
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub parse_line { shift->parse_lines(@_) } # alias
# - - - Turn back now! Run away! - - -
sub parse_lines { # Usage: $parser->parse_lines(@lines)
# an undef means end-of-stream
my $self = shift;
my $code_handler = $self->{'code_handler'};
my $cut_handler = $self->{'cut_handler'};
my $wl_handler = $self->{'whiteline_handler'};
$self->{'line_count'} ||= 0;
my $scratch;
DEBUG > 4 and
print STDERR "# Parsing starting at line ", $self->{'line_count'}, ".\n";
DEBUG > 5 and
print STDERR "# About to parse lines: ",
join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n";
my $paras = ($self->{'paras'} ||= []);
# paragraph buffer. Because we need to defer processing of =over
# directives and verbatim paragraphs. We call _ponder_paragraph_buffer
# to process this.
$self->{'pod_para_count'} ||= 0;
my $line;
foreach my $source_line (@_) {
if( $self->{'source_dead'} ) {
DEBUG > 4 and print STDERR "# Source is dead.\n";
last;
}
unless( defined $source_line ) {
DEBUG > 4 and print STDERR "# Undef-line seen.\n";
push @$paras, ['~end', {'start_line' => $self->{'line_count'}}];
push @$paras, $paras->[-1], $paras->[-1];
# So that it definitely fills the buffer.
$self->{'source_dead'} = 1;
$self->_ponder_paragraph_buffer;
next;
}
if( $self->{'line_count'}++ ) {
($line = $source_line) =~ tr/\n\r//d;
# If we don't have two vars, we'll end up with that there
# tr/// modding the (potentially read-only) original source line!
} else {
DEBUG > 2 and print STDERR "First line: [$source_line]\n";
if( ($line = $source_line) =~ s/^$utf8_bom//s ) {
DEBUG and print STDERR "UTF-8 BOM seen. Faking a '=encoding utf8'.\n";
$self->_handle_encoding_line( "=encoding utf8" );
delete $self->{'_processed_encoding'};
$line =~ tr/\n\r//d;
} elsif( $line =~ s/^\xFE\xFF//s ) {
DEBUG and print STDERR "Big-endian UTF-16 BOM seen. Aborting parsing.\n";
$self->scream(
$self->{'line_count'},
"UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
);
splice @_;
push @_, undef;
next;
# TODO: implement somehow?
} elsif( $line =~ s/^\xFF\xFE//s ) {
DEBUG and print STDERR "Little-endian UTF-16 BOM seen. Aborting parsing.\n";
$self->scream(
$self->{'line_count'},
"UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
);
splice @_;
push @_, undef;
next;
# TODO: implement somehow?
} else {
DEBUG > 2 and print STDERR "First line is BOM-less.\n";
($line = $source_line) =~ tr/\n\r//d;
}
}
if(!$self->{'parse_characters'} && !$self->{'encoding'}
&& ($self->{'in_pod'} || $line =~ /^=/s)
&& $line =~ /$non_ascii_re/
) {
my $encoding;
# No =encoding line, and we are at the first line in the input that
# contains a non-ascii byte, that is one whose meaning varies depending
# on whether the file is encoded in UTF-8 or CP1252, which are the two
# possibilities permitted by the pod spec. (ASCII is assumed if the
# file only contains ASCII bytes.) In order to process this line, we
# need to figure out what encoding we will use for the file.
#
# Strictly speaking ISO 8859-1 (Latin 1) refers to the code points
# 160-255, but it is used here, as it often colloquially is, to refer to
# the complete set of code points 0-255, including ASCII (0-127), the C1
# controls (128-159), and strict Latin 1 (160-255).
#
# CP1252 is effectively a superset of Latin 1, because it differs only
# from colloquial 8859-1 in the C1 controls, which are very unlikely to
# actually be present in 8859-1 files, so can be used for other purposes
# without conflict. CP 1252 uses most of them for graphic characters.
#
# Note that all ASCII-range bytes represent their corresponding code
# points in CP1252 and UTF-8. In ASCII platform UTF-8 all other code
# points require multiple (non-ASCII) bytes to represent. (A separate
# paragraph for EBCDIC is below.) The multi-byte representation is
# quite structured. If we find an isolated byte that requires multiple
# bytes to represent in UTF-8, we know that the encoding is not UTF-8.
# If we find a sequence of bytes that violates the UTF-8 structure, we
# also can presume the encoding isn't UTF-8, and hence must be 1252.
#
# But there are ambiguous cases where we could guess wrong. If so, the
# user will end up having to supply an =encoding line. We use all
# readily available information to improve our chances of guessing
# right. The odds of something not being UTF-8, but still passing a
# UTF-8 validity test go down very rapidly with increasing length of the
# sequence. Therefore we look at all the maximal length non-ascii
# sequences on the line. If any of the sequences can't be UTF-8, we
# quit there and choose CP1252. If all could be UTF-8, we guess UTF-8.
#
# On EBCDIC platforms, the situation is somewhat different. In
# UTF-EBCDIC, not only do ASCII-range bytes represent their code points,
# but so do the bytes that are for the C1 controls. Recall that these
# correspond to the unused portion of 8859-1 that 1252 mostly takes
# over. That means that there are fewer code points that are
# represented by multi-bytes. But, note that the these controls are
# very unlikely to be in pod text. So if we encounter one of them, it
# means that it is quite likely CP1252 and not UTF-8. The net result is
# the same code below is used for both platforms.
while ($line =~ m/($non_ascii_re+)/g) {
my $non_ascii_seq = $1;
if (length $non_ascii_seq == 1) {
$encoding = 'CP1252';
goto guessed;
} elsif ($] ge 5.007_003) {
# On Perls that have this function, we can see if the sequence is
# valid UTF-8 or not.
my $is_utf8;
{
no warnings 'utf8';
$is_utf8 = utf8::decode($non_ascii_seq);
}
if (! $is_utf8) {
$encoding = 'CP1252';
goto guessed;
}
} elsif (ord("A") == 65) { # An early Perl, ASCII platform
# Without utf8::decode, it's a lot harder to do a rigorous check
# (though some early releases had a different function that
# accomplished the same thing). Since these are ancient Perls, not
# likely to be in use today, we take the easy way out, and look at
# just the first two bytes of the sequence to see if they are the
# start of a UTF-8 character. In ASCII UTF-8, continuation bytes
# must be between 0x80 and 0xBF. Start bytes can range from 0xC2
# through 0xFF, but anything above 0xF4 is not Unicode, and hence
# extremely unlikely to be in a pod.
if ($non_ascii_seq !~ /^[\xC2-\xF4][\x80-\xBF]/) {
$encoding = 'CP1252';
goto guessed;
}
# We don't bother doing anything special for EBCDIC on early Perls.
# If there is a solitary variant, CP1252 will be chosen; otherwise
# UTF-8.
}
} # End of loop through all variant sequences on the line
# All sequences in the line could be UTF-8. Guess that.
$encoding = 'UTF-8';
guessed:
$self->_handle_encoding_line( "=encoding $encoding" );
delete $self->{'_processed_encoding'};
$self->{'_transcoder'} && $self->{'_transcoder'}->($line);
my ($word) = $line =~ /(\S*$non_ascii_re\S*)/;
$self->whine(
$self->{'line_count'},
"Non-ASCII character seen before =encoding in '$word'. Assuming $encoding"
);
}
DEBUG > 5 and print STDERR "# Parsing line: [$line]\n";
if(!$self->{'in_pod'}) {
if($line =~ m/^=([a-zA-Z][a-zA-Z0-9]*)(?:\s|$)/s) {
if($1 eq 'cut') {
$self->scream(
$self->{'line_count'},
"=cut found outside a pod block. Skipping to next block."
);
## Before there were errata sections in the world, it was
## least-pessimal to abort processing the file. But now we can
## just barrel on thru (but still not start a pod block).
#splice @_;
#push @_, undef;
next;
} else {
$self->{'in_pod'} = $self->{'start_of_pod_block'}
= $self->{'last_was_blank'} = 1;
# And fall thru to the pod-mode block further down
}
} else {
DEBUG > 5 and print STDERR "# It's a code-line.\n";
$code_handler->(map $_, $line, $self->{'line_count'}, $self)
if $code_handler;
# Note: this may cause code to be processed out of order relative
# to pods, but in order relative to cuts.
# Note also that we haven't yet applied the transcoding to $line
# by time we call $code_handler!
if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) {
# That RE is from perlsyn, section "Plain Old Comments (Not!)",
#$fname = $2 if defined $2;
#DEBUG > 1 and defined $2 and print STDERR "# Setting fname to \"$fname\"\n";
DEBUG > 1 and print STDERR "# Setting nextline to $1\n";
$self->{'line_count'} = $1 - 1;
}
next;
}
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
# Else we're in pod mode:
# Apply any necessary transcoding:
$self->{'_transcoder'} && $self->{'_transcoder'}->($line);
# HERE WE CATCH =encoding EARLY!
if( $line =~ m/^=encoding\s+\S+\s*$/s ) {
next if $self->parse_characters; # Ignore this line
$line = $self->_handle_encoding_line( $line );
}
if($line =~ m/^=cut/s) {
# here ends the pod block, and therefore the previous pod para
DEBUG > 1 and print STDERR "Noting =cut at line ${$self}{'line_count'}\n";
$self->{'in_pod'} = 0;
# ++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
$cut_handler->(map $_, $line, $self->{'line_count'}, $self)
if $cut_handler;
# TODO: add to docs: Note: this may cause cuts to be processed out
# of order relative to pods, but in order relative to code.
} elsif($line =~ m/^(\s*)$/s) { # it's a blank line
if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line
$wl_handler->(map $_, $line, $self->{'line_count'}, $self)
if $wl_handler;
}
if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
DEBUG > 1 and print STDERR "Saving blank line at line ${$self}{'line_count'}\n";
push @{$paras->[-1]}, $line;
} # otherwise it's not interesting
if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) {
DEBUG > 1 and print STDERR "Noting para ends with blank line at ${$self}{'line_count'}\n";
}
$self->{'last_was_blank'} = 1;
} elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para...
if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) {
# THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS
my $new = [$1, {'start_line' => $self->{'line_count'}}, $2];
# Note that in "=head1 foo", the WS is lost.
# Example: ['=head1', {'start_line' => 123}, ' foo']
++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
push @$paras, $new; # the new incipient paragraph
DEBUG > 1 and print STDERR "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n";
} elsif($line =~ m/^\s/s) {
if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
DEBUG > 1 and print STDERR "Resuming verbatim para at line ${$self}{'line_count'}\n";
push @{$paras->[-1]}, $line;
} else {
++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
DEBUG > 1 and print STDERR "Starting verbatim para at line ${$self}{'line_count'}\n";
push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line];
}
} else {
++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
push @$paras, ['~Para', {'start_line' => $self->{'line_count'}}, $line];
DEBUG > 1 and print STDERR "Starting plain para at line ${$self}{'line_count'}\n";
}
$self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
} else {
# It's a non-blank line /continuing/ the current para
if(@$paras) {
DEBUG > 2 and print STDERR "Line ${$self}{'line_count'} continues current paragraph\n";
push @{$paras->[-1]}, $line;
} else {
# Unexpected case!
die "Continuing a paragraph but \@\$paras is empty?";
}
$self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
}
} # ends the big while loop
DEBUG > 1 and print STDERR (pretty(@$paras), "\n");
return $self;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_encoding_line {
my($self, $line) = @_;
return if $self->parse_characters;
# The point of this routine is to set $self->{'_transcoder'} as indicated.
return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s;
DEBUG > 1 and print STDERR "Found an encoding line \"=encoding $1\"\n";
my $e = $1;
my $orig = $e;
push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig";
my $enc_error;
# Cf. perldoc Encode and perldoc Encode::Supported
require Pod::Simple::Transcode;
if( $self->{'encoding'} ) {
my $norm_current = $self->{'encoding'};
my $norm_e = $e;
foreach my $that ($norm_current, $norm_e) {
$that = lc($that);
$that =~ s/[-_]//g;
}
if($norm_current eq $norm_e) {
DEBUG > 1 and print STDERR "The '=encoding $orig' line is ",
"redundant. ($norm_current eq $norm_e). Ignoring.\n";
$enc_error = '';
# But that doesn't necessarily mean that the earlier one went okay
} else {
$enc_error = "Encoding is already set to " . $self->{'encoding'};
DEBUG > 1 and print STDERR $enc_error;
}
} elsif (
# OK, let's turn on the encoding
do {
DEBUG > 1 and print STDERR " Setting encoding to $e\n";
$self->{'encoding'} = $e;
1;
}
and $e eq 'HACKRAW'
) {
DEBUG and print STDERR " Putting in HACKRAW (no-op) encoding mode.\n";
} elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) {
die($enc_error = "WHAT? _transcoder is already set?!")
if $self->{'_transcoder'}; # should never happen
require Pod::Simple::Transcode;
$self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e);
eval {
my @x = ('', "abc", "123");
$self->{'_transcoder'}->(@x);
};
$@ && die( $enc_error =
"Really unexpected error setting up encoding $e: $@\nAborting"
);
$self->{'detected_encoding'} = $e;
} else {
my @supported = Pod::Simple::Transcode::->all_encodings;
# Note unsupported, and complain
DEBUG and print STDERR " Encoding [$e] is unsupported.",
"\nSupporteds: @supported\n";
my $suggestion = '';
# Look for a near match:
my $norm = lc($e);
$norm =~ tr[-_][]d;
my $n;
foreach my $enc (@supported) {
$n = lc($enc);
$n =~ tr[-_][]d;
next unless $n eq $norm;
$suggestion = " (Maybe \"$e\" should be \"$enc\"?)";
last;
}
my $encmodver = Pod::Simple::Transcode::->encmodver;
$enc_error = join '' =>
"This document probably does not appear as it should, because its ",
"\"=encoding $e\" line calls for an unsupported encoding.",
$suggestion, " [$encmodver\'s supported encodings are: @supported]"
;
$self->scream( $self->{'line_count'}, $enc_error );
}
push @{ $self->{'encoding_command_statuses'} }, $enc_error;
if (defined($self->{'_processed_encoding'})) {
# Double declaration.
$self->scream( $self->{'line_count'}, 'Cannot have multiple =encoding directives');
}
$self->{'_processed_encoding'} = $orig;
return $line;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _handle_encoding_second_level {
# By time this is called, the encoding (if well formed) will already
# have been acted one.
my($self, $para) = @_;
my @x = @$para;
my $content = join ' ', splice @x, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
DEBUG > 2 and print STDERR "Ogling encoding directive: =encoding $content\n";
if (defined($self->{'_processed_encoding'})) {
#if($content ne $self->{'_processed_encoding'}) {
# Could it happen?
#}
delete $self->{'_processed_encoding'};
# It's already been handled. Check for errors.
if(! $self->{'encoding_command_statuses'} ) {
DEBUG > 2 and print STDERR " CRAZY ERROR: It wasn't really handled?!\n";
} elsif( $self->{'encoding_command_statuses'}[-1] ) {
$self->whine( $para->[1]{'start_line'},
sprintf "Couldn't do %s: %s",
$self->{'encoding_command_reqs' }[-1],
$self->{'encoding_command_statuses'}[-1],
);
} else {
DEBUG > 2 and print STDERR " (Yup, it was successfully handled already.)\n";
}
} else {
# Otherwise it's a syntax error
$self->whine( $para->[1]{'start_line'},
"Invalid =encoding syntax: $content"
);
}
return;
}
#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`
{
my $m = -321; # magic line number
sub _gen_errata {
my $self = $_[0];
# Return 0 or more fake-o paragraphs explaining the accumulated
# errors on this document.
return() unless $self->{'errata'} and keys %{$self->{'errata'}};
my @out;
foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) {
push @out,
['=item', {'start_line' => $m}, "Around line $line:"],
map( ['~Para', {'start_line' => $m, '~cooked' => 1},
#['~Top', {'start_line' => $m},
$_
#]
],
@{$self->{'errata'}{$line}}
)
;
}
# TODO: report of unknown entities? unrenderable characters?
unshift @out,
['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'],
['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1},
"Hey! ",
['B', {},
'The above document had some coding errors, which are explained below:'
]
],
['=over', {'start_line' => $m, 'errata' => 1}, ''],
;
push @out,
['=back', {'start_line' => $m, 'errata' => 1}, ''],
;
DEBUG and print STDERR "\n<<\n", pretty(\@out), "\n>>\n\n";
return @out;
}
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
##############################################################################
##
## stop reading now stop reading now stop reading now stop reading now stop
##
## HERE IT BECOMES REALLY SCARY
##
## stop reading now stop reading now stop reading now stop reading now stop
##
##############################################################################
sub _ponder_paragraph_buffer {
# Para-token types as found in the buffer.
# ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end,
# =over, =back, =item
# and the null =pod (to be complained about if over one line)
#
# "~data" paragraphs are something we generate at this level, depending on
# a currently open =over region
# Events fired: Begin and end for:
# directivename (like head1 .. head4), item, extend,
# for (from =begin...=end, =for),
# over-bullet, over-number, over-text, over-block,
# item-bullet, item-number, item-text,
# Document,
# Data, Para, Verbatim
# B, C, longdirname (TODO -- wha?), etc. for all directives
#
my $self = $_[0];
my $paras;
return unless @{$paras = $self->{'paras'}};
my $curr_open = ($self->{'curr_open'} ||= []);
my $scratch;
DEBUG > 10 and print STDERR "# Paragraph buffer: <<", pretty($paras), ">>\n";
# We have something in our buffer. So apparently the document has started.
unless($self->{'doc_has_started'}) {
$self->{'doc_has_started'} = 1;
my $starting_contentless;
$starting_contentless =
(
!@$curr_open
and @$paras and ! grep $_->[0] ne '~end', @$paras
# i.e., if the paras is all ~ends
)
;
DEBUG and print STDERR "# Starting ",
$starting_contentless ? 'contentless' : 'contentful',
" document\n"
;
$self->_handle_element_start(
($scratch = 'Document'),
{
'start_line' => $paras->[0][1]{'start_line'},
$starting_contentless ? ( 'contentless' => 1 ) : (),
},
);
}
my($para, $para_type);
while(@$paras) {
last if @$paras == 1 and
( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim'
or $paras->[0][0] eq '=item' )
;
# Those're the three kinds of paragraphs that require lookahead.
# Actually, an "=item Foo" inside an <over type=text> region
# and any =item inside an <over type=block> region (rare)
# don't require any lookahead, but all others (bullets
# and numbers) do.
# TODO: whinge about many kinds of directives in non-resolving =for regions?
# TODO: many? like what? =head1 etc?
$para = shift @$paras;
$para_type = $para->[0];
DEBUG > 1 and print STDERR "Pondering a $para_type paragraph, given the stack: (",
$self->_dump_curr_open(), ")\n";
if($para_type eq '=for') {
next if $self->_ponder_for($para,$curr_open,$paras);
} elsif($para_type eq '=begin') {
next if $self->_ponder_begin($para,$curr_open,$paras);
} elsif($para_type eq '=end') {
next if $self->_ponder_end($para,$curr_open,$paras);
} elsif($para_type eq '~end') { # The virtual end-document signal
next if $self->_ponder_doc_end($para,$curr_open,$paras);
}
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
#~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
if(grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and
print STDERR "Skipping $para_type paragraph because in ignore mode.\n";
next;
}
#~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
if($para_type eq '=pod') {
$self->_ponder_pod($para,$curr_open,$paras);
} elsif($para_type eq '=over') {
next if $self->_ponder_over($para,$curr_open,$paras);
} elsif($para_type eq '=back') {
next if $self->_ponder_back($para,$curr_open,$paras);
} else {
# All non-magical codes!!!
# Here we start using $para_type for our own twisted purposes, to
# mean how it should get treated, not as what the element name
# should be.
DEBUG > 1 and print STDERR "Pondering non-magical $para_type\n";
my $i;
# Enforce some =headN discipline
if($para_type =~ m/^=head\d$/s
and ! $self->{'accept_heads_anywhere'}
and @$curr_open
and $curr_open->[-1][0] eq '=over'
) {
DEBUG > 2 and print STDERR "'=$para_type' inside an '=over'!\n";
$self->whine(
$para->[1]{'start_line'},
"You forgot a '=back' before '$para_type'"
);
unshift @$paras, ['=back', {}, ''], $para; # close the =over
next;
}
if($para_type eq '=item') {
my $over;
unless(@$curr_open and
$over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
$self->whine(
$para->[1]{'start_line'},
"'=item' outside of any '=over'"
);
unshift @$paras,
['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
$para
;
next;
}
my $over_type = $over->[1]{'~type'};
if(!$over_type) {
# Shouldn't happen1
die "Typeless over in stack, starting at line "
. $over->[1]{'start_line'};
} elsif($over_type eq 'block') {
unless($curr_open->[-1][1]{'~bitched_about'}) {
$curr_open->[-1][1]{'~bitched_about'} = 1;
$self->whine(
$curr_open->[-1][1]{'start_line'},
"You can't have =items (as at line "
. $para->[1]{'start_line'}
. ") unless the first thing after the =over is an =item"
);
}
# Just turn it into a paragraph and reconsider it
$para->[0] = '~Para';
unshift @$paras, $para;
next;
} elsif($over_type eq 'text') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'text') {
# Nothing special needs doing for 'text'
} elsif($item_type eq 'number' or $item_type eq 'bullet') {
$self->whine(
$para->[1]{'start_line'},
"Expected text after =item, not a $item_type"
);
# Undo our clobbering:
push @$para, $para->[1]{'~orig_content'};
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} else {
die "Unhandled item type $item_type"; # should never happen
}
# =item-text thingies don't need any assimilation, it seems.
} elsif($over_type eq 'number') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n";
my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
if($item_type eq 'bullet') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
push @$para, $para->[1]{'~orig_content'};
# restore the bullet, blocking the assimilation of next para
} elsif($item_type eq 'text') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
# Text content will still be there and will block next ~Para
} elsif($item_type ne 'number') {
die "Unknown item type $item_type"; # should never happen
} elsif($expected_value == $para->[1]{'number'}) {
DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n";
} else {
DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'},
" instead of the expected value of $expected_value\n";
$self->whine(
$para->[1]{'start_line'},
"You have '=item " . $para->[1]{'number'} .
"' instead of the expected '=item $expected_value'"
);
$para->[1]{'number'} = $expected_value; # correcting!!
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} elsif($over_type eq 'bullet') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'bullet') {
# as expected!
if( $para->[1]{'~_freaky_para_hack'} ) {
DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n";
push @$para, delete $para->[1]{'~_freaky_para_hack'};
}
} elsif($item_type eq 'number') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
push @$para, $para->[1]{'~orig_content'};
# and block assimilation of the next paragraph
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} elsif($item_type eq 'text') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
# But doesn't need processing. But it'll block assimilation
# of the next para.
} else {
die "Unhandled item type $item_type"; # should never happen
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} else {
die "Unhandled =over type \"$over_type\"?";
# Shouldn't happen!
}
$para_type = 'Plain';
$para->[0] .= '-' . $over_type;
# Whew. Now fall thru and process it.
} elsif($para_type eq '=extend') {
# Well, might as well implement it here.
$self->_ponder_extend($para);
next; # and skip
} elsif($para_type eq '=encoding') {
# Not actually acted on here, but we catch errors here.
$self->_handle_encoding_second_level($para);
next unless $self->keep_encoding_directive;
$para_type = 'Plain';
} elsif($para_type eq '~Verbatim') {
$para->[0] = 'Verbatim';
$para_type = '?Verbatim';
} elsif($para_type eq '~Para') {
$para->[0] = 'Para';
$para_type = '?Plain';
} elsif($para_type eq 'Data') {
$para->[0] = 'Data';
$para_type = '?Data';
} elsif( $para_type =~ s/^=//s
and defined( $para_type = $self->{'accept_directives'}{$para_type} )
) {
DEBUG > 1 and print STDERR " Pondering known directive ${$para}[0] as $para_type\n";
} else {
# An unknown directive!
DEBUG > 1 and printf STDERR "Unhandled directive %s (Handled: %s)\n",
$para->[0], join(' ', sort keys %{$self->{'accept_directives'}} )
;
$self->whine(
$para->[1]{'start_line'},
"Unknown directive: $para->[0]"
);
# And maybe treat it as text instead of just letting it go?
next;
}
if($para_type =~ s/^\?//s) {
if(! @$curr_open) { # usual case
DEBUG and print STDERR "Treating $para_type paragraph as such because stack is empty.\n";
} else {
my @fors = grep $_->[0] eq '=for', @$curr_open;
DEBUG > 1 and print STDERR "Containing fors: ",
join(',', map $_->[1]{'target'}, @fors), "\n";
if(! @fors) {
DEBUG and print STDERR "Treating $para_type paragraph as such because stack has no =for's\n";
#} elsif(grep $_->[1]{'~resolve'}, @fors) {
#} elsif(not grep !$_->[1]{'~resolve'}, @fors) {
} elsif( $fors[-1][1]{'~resolve'} ) {
# Look to the immediately containing for
if($para_type eq 'Data') {
DEBUG and print STDERR "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
$para->[0] = 'Para';
$para_type = 'Plain';
} else {
DEBUG and print STDERR "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
}
} else {
DEBUG and print STDERR "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n";
$para->[0] = $para_type = 'Data';
}
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if($para_type eq 'Plain') {
$self->_ponder_Plain($para);
} elsif($para_type eq 'Verbatim') {
$self->_ponder_Verbatim($para);
} elsif($para_type eq 'Data') {
$self->_ponder_Data($para);
} else {
die "\$para type is $para_type -- how did that happen?";
# Shouldn't happen.
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
$para->[0] =~ s/^[~=]//s;
DEBUG and print STDERR "\n", pretty($para), "\n";
# traverse the treelet (which might well be just one string scalar)
$self->{'content_seen'} ||= 1;
$self->_traverse_treelet_bit(@$para);
}
}
return;
}
###########################################################################
# The sub-ponderers...
sub _ponder_for {
my ($self,$para,$curr_open,$paras) = @_;
# Fake it out as a begin/end
my $target;
if(grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and print STDERR "Ignoring ignorable =for\n";
return 1;
}
for(my $i = 2; $i < @$para; ++$i) {
if($para->[$i] =~ s/^\s*(\S+)\s*//s) {
$target = $1;
last;
}
}
unless(defined $target) {
$self->whine(
$para->[1]{'start_line'},
"=for without a target?"
);
return 1;
}
DEBUG > 1 and
print STDERR "Faking out a =for $target as a =begin $target / =end $target\n";
$para->[0] = 'Data';
unshift @$paras,
['=begin',
{'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
$target,
],
$para,
['=end',
{'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
$target,
],
;
return 1;
}
sub _ponder_begin {
my ($self,$para,$curr_open,$paras) = @_;
my $content = join ' ', splice @$para, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
unless(length($content)) {
$self->whine(
$para->[1]{'start_line'},
"=begin without a target?"
);
DEBUG and print STDERR "Ignoring targetless =begin\n";
return 1;
}
my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/;
$para->[1]{'title'} = $title if ($title);
$para->[1]{'target'} = $target; # without any ':'
$content = $target; # strip off the title
$content =~ s/^:!/!:/s;
my $neg; # whether this is a negation-match
$neg = 1 if $content =~ s/^!//s;
my $to_resolve; # whether to process formatting codes
$to_resolve = 1 if $content =~ s/^://s;
my $dont_ignore; # whether this target matches us
foreach my $target_name (
split(',', $content, -1),
$neg ? () : '*'
) {
DEBUG > 2 and
print STDERR " Considering whether =begin $content matches $target_name\n";
next unless $self->{'accept_targets'}{$target_name};
DEBUG > 2 and
print STDERR " It DOES match the acceptable target $target_name!\n";
$to_resolve = 1
if $self->{'accept_targets'}{$target_name} eq 'force_resolve';
$dont_ignore = 1;
$para->[1]{'target_matching'} = $target_name;
last; # stop looking at other target names
}
if($neg) {
if( $dont_ignore ) {
$dont_ignore = '';
delete $para->[1]{'target_matching'};
DEBUG > 2 and print STDERR " But the leading ! means that this is a NON-match!\n";
} else {
$dont_ignore = 1;
$para->[1]{'target_matching'} = '!';
DEBUG > 2 and print STDERR " But the leading ! means that this IS a match!\n";
}
}
$para->[0] = '=for'; # Just what we happen to call these, internally
$para->[1]{'~really'} ||= '=begin';
$para->[1]{'~ignore'} = (! $dont_ignore) || 0;
$para->[1]{'~resolve'} = $to_resolve || 0;
DEBUG > 1 and print STDERR " Making note to ", $dont_ignore ? 'not ' : '',
"ignore contents of this region\n";
DEBUG > 1 and $dont_ignore and print STDERR " Making note to treat contents as ",
($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
DEBUG > 1 and print STDERR " (Stack now: ", $self->_dump_curr_open(), ")\n";
push @$curr_open, $para;
if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n";
} else {
$self->{'content_seen'} ||= 1;
$self->_handle_element_start((my $scratch='for'), $para->[1]);
}
return 1;
}
sub _ponder_end {
my ($self,$para,$curr_open,$paras) = @_;
my $content = join ' ', splice @$para, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
DEBUG and print STDERR "Ogling '=end $content' directive\n";
unless(length($content)) {
$self->whine(
$para->[1]{'start_line'},
"'=end' without a target?" . (
( @$curr_open and $curr_open->[-1][0] eq '=for' )
? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' )
: ''
)
);
DEBUG and print STDERR "Ignoring targetless =end\n";
return 1;
}
unless($content =~ m/^\S+$/) { # i.e., unless it's one word
$self->whine(
$para->[1]{'start_line'},
"'=end $content' is invalid. (Stack: "
. $self->_dump_curr_open() . ')'
);
DEBUG and print STDERR "Ignoring mistargetted =end $content\n";
return 1;
}
unless(@$curr_open and $curr_open->[-1][0] eq '=for') {
$self->whine(
$para->[1]{'start_line'},
"=end $content without matching =begin. (Stack: "
. $self->_dump_curr_open() . ')'
);
DEBUG and print STDERR "Ignoring mistargetted =end $content\n";
return 1;
}
unless($content eq $curr_open->[-1][1]{'target'}) {
$self->whine(
$para->[1]{'start_line'},
"=end $content doesn't match =begin "
. $curr_open->[-1][1]{'target'}
. ". (Stack: "
. $self->_dump_curr_open() . ')'
);
DEBUG and print STDERR "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n";
return 1;
}
# Else it's okay to close...
if(grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and print STDERR "Not firing any event for this =end $content because in an ignored region\n";
# And that may be because of this to-be-closed =for region, or some
# other one, but it doesn't matter.
} else {
$curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'};
# what's that for?
$self->{'content_seen'} ||= 1;
$self->_handle_element_end( my $scratch = 'for', $para->[1]);
}
DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
pop @$curr_open;
return 1;
}
sub _ponder_doc_end {
my ($self,$para,$curr_open,$paras) = @_;
if(@$curr_open) { # Deal with things left open
DEBUG and print STDERR "Stack is nonempty at end-document: (",
$self->_dump_curr_open(), ")\n";
DEBUG > 9 and print STDERR "Stack: ", pretty($curr_open), "\n";
unshift @$paras, $self->_closers_for_all_curr_open;
# Make sure there is exactly one ~end in the parastack, at the end:
@$paras = grep $_->[0] ne '~end', @$paras;
push @$paras, $para, $para;
# We need two -- once for the next cycle where we
# generate errata, and then another to be at the end
# when that loop back around to process the errata.
return 1;
} else {
DEBUG and print STDERR "Okay, stack is empty now.\n";
}
# Try generating errata section, if applicable
unless($self->{'~tried_gen_errata'}) {
$self->{'~tried_gen_errata'} = 1;
my @extras = $self->_gen_errata();
if(@extras) {
unshift @$paras, @extras;
DEBUG and print STDERR "Generated errata... relooping...\n";
return 1; # I.e., loop around again to process these fake-o paragraphs
}
}
splice @$paras; # Well, that's that for this paragraph buffer.
DEBUG and print STDERR "Throwing end-document event.\n";
$self->_handle_element_end( my $scratch = 'Document' );
return 1; # Hasta la byebye
}
sub _ponder_pod {
my ($self,$para,$curr_open,$paras) = @_;
$self->whine(
$para->[1]{'start_line'},
"=pod directives shouldn't be over one line long! Ignoring all "
. (@$para - 2) . " lines of content"
) if @$para > 3;
# Content ignored unless 'pod_handler' is set
if (my $pod_handler = $self->{'pod_handler'}) {
my ($line_num, $line) = map $_, $para->[1]{'start_line'}, $para->[2];
$line = $line eq '' ? "=pod" : "=pod $line"; # imitate cut_handler output
$pod_handler->($line, $line_num, $self);
}
# The surrounding methods set content_seen, so let us remain consistent.
# I do not know why it was not here before -- should it not be here?
# $self->{'content_seen'} ||= 1;
return;
}
sub _ponder_over {
my ($self,$para,$curr_open,$paras) = @_;
return 1 unless @$paras;
my $list_type;
if($paras->[0][0] eq '=item') { # most common case
$list_type = $self->_get_initial_item_type($paras->[0]);
} elsif($paras->[0][0] eq '=back') {
# Ignore empty lists by default
if ($self->{'parse_empty_lists'}) {
$list_type = 'empty';
} else {
shift @$paras;
return 1;
}
} elsif($paras->[0][0] eq '~end') {
$self->whine(
$para->[1]{'start_line'},
"=over is the last thing in the document?!"
);
return 1; # But feh, ignore it.
} else {
$list_type = 'block';
}
$para->[1]{'~type'} = $list_type;
push @$curr_open, $para;
# yes, we reuse the paragraph as a stack item
my $content = join ' ', splice @$para, 2;
my $overness;
if($content =~ m/^\s*$/s) {
$para->[1]{'indent'} = 4;
} elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) {
no integer;
$para->[1]{'indent'} = $1;
if($1 == 0) {
$self->whine(
$para->[1]{'start_line'},
"Can't have a 0 in =over $content"
);
$para->[1]{'indent'} = 4;
}
} else {
$self->whine(
$para->[1]{'start_line'},
"=over should be: '=over' or '=over positive_number'"
);
$para->[1]{'indent'} = 4;
}
DEBUG > 1 and print STDERR "=over found of type $list_type\n";
$self->{'content_seen'} ||= 1;
$self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
return;
}
sub _ponder_back {
my ($self,$para,$curr_open,$paras) = @_;
# TODO: fire off </item-number> or </item-bullet> or </item-text> ??
my $content = join ' ', splice @$para, 2;
if($content =~ m/\S/) {
$self->whine(
$para->[1]{'start_line'},
"=back doesn't take any parameters, but you said =back $content"
);
}
if(@$curr_open and $curr_open->[-1][0] eq '=over') {
DEBUG > 1 and print STDERR "=back happily closes matching =over\n";
# Expected case: we're closing the most recently opened thing
#my $over = pop @$curr_open;
$self->{'content_seen'} ||= 1;
$self->_handle_element_end( my $scratch =
'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1]
);
} else {
DEBUG > 1 and print STDERR "=back found without a matching =over. Stack: (",
join(', ', map $_->[0], @$curr_open), ").\n";
$self->whine(
$para->[1]{'start_line'},
'=back without =over'
);
return 1; # and ignore it
}
}
sub _ponder_item {
my ($self,$para,$curr_open,$paras) = @_;
my $over;
unless(@$curr_open and
$over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
$self->whine(
$para->[1]{'start_line'},
"'=item' outside of any '=over'"
);
unshift @$paras,
['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
$para
;
return 1;
}
my $over_type = $over->[1]{'~type'};
if(!$over_type) {
# Shouldn't happen1
die "Typeless over in stack, starting at line "
. $over->[1]{'start_line'};
} elsif($over_type eq 'block') {
unless($curr_open->[-1][1]{'~bitched_about'}) {
$curr_open->[-1][1]{'~bitched_about'} = 1;
$self->whine(
$curr_open->[-1][1]{'start_line'},
"You can't have =items (as at line "
. $para->[1]{'start_line'}
. ") unless the first thing after the =over is an =item"
);
}
# Just turn it into a paragraph and reconsider it
$para->[0] = '~Para';
unshift @$paras, $para;
return 1;
} elsif($over_type eq 'text') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'text') {
# Nothing special needs doing for 'text'
} elsif($item_type eq 'number' or $item_type eq 'bullet') {
$self->whine(
$para->[1]{'start_line'},
"Expected text after =item, not a $item_type"
);
# Undo our clobbering:
push @$para, $para->[1]{'~orig_content'};
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} else {
die "Unhandled item type $item_type"; # should never happen
}
# =item-text thingies don't need any assimilation, it seems.
} elsif($over_type eq 'number') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n";
my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
if($item_type eq 'bullet') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
push @$para, $para->[1]{'~orig_content'};
# restore the bullet, blocking the assimilation of next para
} elsif($item_type eq 'text') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
# Text content will still be there and will block next ~Para
} elsif($item_type ne 'number') {
die "Unknown item type $item_type"; # should never happen
} elsif($expected_value == $para->[1]{'number'}) {
DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n";
} else {
DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'},
" instead of the expected value of $expected_value\n";
$self->whine(
$para->[1]{'start_line'},
"You have '=item " . $para->[1]{'number'} .
"' instead of the expected '=item $expected_value'"
);
$para->[1]{'number'} = $expected_value; # correcting!!
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} elsif($over_type eq 'bullet') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'bullet') {
# as expected!
if( $para->[1]{'~_freaky_para_hack'} ) {
DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n";
push @$para, delete $para->[1]{'~_freaky_para_hack'};
}
} elsif($item_type eq 'number') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
push @$para, $para->[1]{'~orig_content'};
# and block assimilation of the next paragraph
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} elsif($item_type eq 'text') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
# But doesn't need processing. But it'll block assimilation
# of the next para.
} else {
die "Unhandled item type $item_type"; # should never happen
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} else {
die "Unhandled =over type \"$over_type\"?";
# Shouldn't happen!
}
$para->[0] .= '-' . $over_type;
return;
}
sub _ponder_Plain {
my ($self,$para) = @_;
DEBUG and print STDERR " giving plain treatment...\n";
unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
or $para->[1]{'~cooked'}
) {
push @$para,
@{$self->_make_treelet(
join("\n", splice(@$para, 2)),
$para->[1]{'start_line'}
)};
}
# Empty paragraphs don't need a treelet for any reason I can see.
# And precooked paragraphs already have a treelet.
return;
}
sub _ponder_Verbatim {
my ($self,$para) = @_;
DEBUG and print STDERR " giving verbatim treatment...\n";
$para->[1]{'xml:space'} = 'preserve';
my $indent = $self->strip_verbatim_indent;
if ($indent && ref $indent eq 'CODE') {
my @shifted = (shift @{$para}, shift @{$para});
$indent = $indent->($para);
unshift @{$para}, @shifted;
}
for(my $i = 2; $i < @$para; $i++) {
foreach my $line ($para->[$i]) { # just for aliasing
# Strip indentation.
$line =~ s/^\Q$indent// if $indent
&& !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted});
while( $line =~
# Sort of adapted from Text::Tabs -- yes, it's hardwired in that
# tabs are at every EIGHTH column. For portability, it has to be
# one setting everywhere, and 8th wins.
s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
) {}
# TODO: whinge about (or otherwise treat) unindented or overlong lines
}
}
# Now the VerbatimFormatted hoodoo...
if( $self->{'accept_codes'} and
$self->{'accept_codes'}{'VerbatimFormatted'}
) {
while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
# Kill any number of terminal newlines
$self->_verbatim_format($para);
} elsif ($self->{'codes_in_verbatim'}) {
push @$para,
@{$self->_make_treelet(
join("\n", splice(@$para, 2)),
$para->[1]{'start_line'}, $para->[1]{'xml:space'}
)};
$para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
} else {
push @$para, join "\n", splice(@$para, 2) if @$para > 3;
$para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
}
return;
}
sub _ponder_Data {
my ($self,$para) = @_;
DEBUG and print STDERR " giving data treatment...\n";
$para->[1]{'xml:space'} = 'preserve';
push @$para, join "\n", splice(@$para, 2) if @$para > 3;
return;
}
###########################################################################
sub _traverse_treelet_bit { # for use only by the routine above
my($self, $name) = splice @_,0,2;
my $scratch;
$self->_handle_element_start(($scratch=$name), shift @_);
while (@_) {
my $x = shift;
if (ref($x)) {
&_traverse_treelet_bit($self, @$x);
} else {
$x .= shift while @_ && !ref($_[0]);
$self->_handle_text($x);
}
}
$self->_handle_element_end($scratch=$name);
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _closers_for_all_curr_open {
my $self = $_[0];
my @closers;
foreach my $still_open (@{ $self->{'curr_open'} || return }) {
my @copy = @$still_open;
$copy[1] = {%{ $copy[1] }};
#$copy[1]{'start_line'} = -1;
if($copy[0] eq '=for') {
$copy[0] = '=end';
} elsif($copy[0] eq '=over') {
$self->whine(
$still_open->[1]{start_line} ,
"=over without closing =back"
);
$copy[0] = '=back';
} else {
die "I don't know how to auto-close an open $copy[0] region";
}
unless( @copy > 2 ) {
push @copy, $copy[1]{'target'};
$copy[-1] = '' unless defined $copy[-1];
# since =over's don't have targets
}
$copy[1]{'fake-closer'} = 1;
DEBUG and print STDERR "Queuing up fake-o event: ", pretty(\@copy), "\n";
unshift @closers, \@copy;
}
return @closers;
}
#--------------------------------------------------------------------------
sub _verbatim_format {
my($it, $p) = @_;
my $formatting;
for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
DEBUG and print STDERR "_verbatim_format appends a newline to $i: $p->[$i]\n";
$p->[$i] .= "\n";
# Unlike with simple Verbatim blocks, we don't end up just doing
# a join("\n", ...) on the contents, so we have to append a
# newline to ever line, and then nix the last one later.
}
if( DEBUG > 4 ) {
print STDERR "<<\n";
for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
print STDERR "_verbatim_format $i: $p->[$i]";
}
print STDERR ">>\n";
}
for(my $i = $#$p; $i > 2; $i--) {
# work backwards over the lines, except the first (#2)
#next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s
# and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
# look at a formatty line preceding a nonformatty one
DEBUG > 5 and print STDERR "Scrutinizing line $i: $$p[$i]\n";
if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) {
DEBUG > 5 and print STDERR " It's a formatty line. ",
"Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
DEBUG > 5 and print STDERR " Previous line is formatty! Skipping this one.\n";
next;
} else {
DEBUG > 5 and print STDERR " Previous line is non-formatty! Yay!\n";
}
} else {
DEBUG > 5 and print STDERR " It's not a formatty line. Ignoring\n";
next;
}
# A formatty line has to have #: in the first two columns, and uses
# "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
# Example:
# What do you want? i like pie. [or whatever]
# #:^^^^^^^^^^^^^^^^^ /////////////
DEBUG > 4 and print STDERR "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
$formatting = ' ' . $1;
$formatting =~ s/\s+$//s; # nix trailing whitespace
unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
splice @$p,$i,1; # remove this line
$i--; # don't consider next line
next;
}
if( length($formatting) >= length($p->[$i-1]) ) {
$formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
} else {
$formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
}
# Make $formatting and the previous line be exactly the same length,
# with $formatting having a " " as the last character.
DEBUG > 4 and print STDERR "Formatting <$formatting> on <", $p->[$i-1], ">\n";
my @new_line;
while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
#print STDERR "Format matches $1\n";
if($2) {
#print STDERR "SKIPPING <$2>\n";
push @new_line,
substr($p->[$i-1], pos($formatting)-length($1), length($1));
} else {
#print STDERR "SNARING $+\n";
push @new_line, [
(
$3 ? 'VerbatimB' :
$4 ? 'VerbatimI' :
$5 ? 'VerbatimBI' : die("Should never get called")
), {},
substr($p->[$i-1], pos($formatting)-length($1), length($1))
];
#print STDERR "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n";
}
}
my @nixed =
splice @$p, $i-1, 2, @new_line; # replace myself and the next line
DEBUG > 10 and print STDERR "Nixed count: ", scalar(@nixed), "\n";
DEBUG > 6 and print STDERR "New version of the above line is these tokens (",
scalar(@new_line), "):",
map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n";
$i--; # So the next line we scrutinize is the line before the one
# that we just went and formatted
}
$p->[0] = 'VerbatimFormatted';
# Collapse adjacent text nodes, just for kicks.
for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last
if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) {
DEBUG > 5 and print STDERR "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n";
$p->[$i] .= splice @$p, $i+1, 1; # merge
--$i; # and back up
}
}
# Now look for the last text token, and remove the terminal newline
for( my $i = $#$p; $i >= 2; $i-- ) {
# work backwards over the tokens, even the first
if( !ref($p->[$i]) ) {
if($p->[$i] =~ s/\n$//s) {
DEBUG > 5 and print STDERR "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
} else {
DEBUG > 5 and print STDERR
"No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n";
}
last; # we only want the next one
}
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _treelet_from_formatting_codes {
# Given a paragraph, returns a treelet. Full of scary tokenizing code.
# Like [ '~Top', {'start_line' => $start_line},
# "I like ",
# [ 'B', {}, "pie" ],
# "!"
# ]
my($self, $para, $start_line, $preserve_space) = @_;
my $treelet = ['~Top', {'start_line' => $start_line},];
unless ($preserve_space || $self->{'preserve_whitespace'}) {
$para =~ s/\s+/ /g; # collapse and trim all whitespace first.
$para =~ s/ $//;
$para =~ s/^ //;
}
# Only apparent problem the above code is that N<< >> turns into
# N<< >>. But then, word wrapping does that too! So don't do that!
my @stack;
my @lineage = ($treelet);
my $raw = ''; # raw content of L<> fcode before splitting/processing
# XXX 'raw' is not 100% accurate: all surrounding whitespace is condensed
# into just 1 ' '. Is this the regex's doing or 'raw's?
my $inL = 0;
DEBUG > 4 and print STDERR "Paragraph:\n$para\n\n";
# Here begins our frightening tokenizer RE. The following regex matches
# text in four main parts:
#
# * Start-codes. The first alternative matches C< or C<<, the latter
# followed by some whitespace. $1 will hold the entire start code
# (including any space following a multiple-angle-bracket delimiter),
# and $2 will hold only the additional brackets past the first in a
# multiple-bracket delimiter. length($2) + 1 will be the number of
# closing brackets we have to find.
#
# * Closing brackets. Match some amount of whitespace followed by
# multiple close brackets. The logic to see if this closes anything
# is down below. Note that in order to parse C<< >> correctly, we
# have to use look-behind (?<=\s\s), since the match of the starting
# code will have consumed the whitespace.
#
# * A single closing bracket, to close a simple code like C<>.
#
# * Something that isn't a start or end code. We have to be careful
# about accepting whitespace, since perlpodspec says that any whitespace
# before a multiple-bracket closing delimiter should be ignored.
#
while($para =~
m/\G
(?:
# Match starting codes, including the whitespace following a
# multiple-delimiter start code. $1 gets the whole start code and
# $2 gets all but one of the <s in the multiple-bracket case.
([A-Z]<(?:(<+)\s+)?)
|
# Match multiple-bracket end codes. $3 gets the whitespace that
# should be discarded before an end bracket but kept in other cases
# and $4 gets the end brackets themselves.
(\s+|(?<=\s\s))(>{2,})
|
(\s?>) # $5: simple end-codes
|
( # $6: stuff containing no start-codes or end-codes
(?:
[^A-Z\s>]
|
(?:
[A-Z](?!<)
)
|
# whitespace is ok, but we don't want to eat the whitespace before
# a multiple-bracket end code.
# NOTE: we may still have problems with e.g. S<< >>
(?:
\s(?!\s*>{2,})
)
)+
)
)
/xgo
) {
DEBUG > 4 and print STDERR "\nParagraphic tokenstack = (@stack)\n";
if(defined $1) {
if(defined $2) {
DEBUG > 3 and print STDERR "Found complex start-text code \"$1\"\n";
push @stack, length($2) + 1;
# length of the necessary complex end-code string
} else {
DEBUG > 3 and print STDERR "Found simple start-text code \"$1\"\n";
push @stack, 0; # signal that we're looking for simple
}
push @lineage, [ substr($1,0,1), {}, ]; # new node object
push @{ $lineage[-2] }, $lineage[-1];
if ('L' eq substr($1,0,1)) {
$raw = $inL ? $raw.$1 : ''; # reset raw content accumulator
$inL = 1;
} else {
$raw .= $1 if $inL;
}
} elsif(defined $4) {
DEBUG > 3 and print STDERR "Found apparent complex end-text code \"$3$4\"\n";
# This is where it gets messy...
if(! @stack) {
# We saw " >>>>" but needed nothing. This is ALL just stuff then.
DEBUG > 4 and print STDERR " But it's really just stuff.\n";
push @{ $lineage[-1] }, $3, $4;
next;
} elsif(!$stack[-1]) {
# We saw " >>>>" but needed only ">". Back pos up.
DEBUG > 4 and print STDERR " And that's more than we needed to close simple.\n";
push @{ $lineage[-1] }, $3; # That was a for-real space, too.
pos($para) = pos($para) - length($4) + 1;
} elsif($stack[-1] == length($4)) {
# We found " >>>>", and it was exactly what we needed. Commonest case.
DEBUG > 4 and print STDERR " And that's exactly what we needed to close complex.\n";
} elsif($stack[-1] < length($4)) {
# We saw " >>>>" but needed only " >>". Back pos up.
DEBUG > 4 and print STDERR " And that's more than we needed to close complex.\n";
pos($para) = pos($para) - length($4) + $stack[-1];
} else {
# We saw " >>>>" but needed " >>>>>>". So this is all just stuff!
DEBUG > 4 and print STDERR " But it's really just stuff, because we needed more.\n";
push @{ $lineage[-1] }, $3, $4;
next;
}
#print STDERR "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
# Keep the element from being childless
pop @stack;
pop @lineage;
unless (@stack) { # not in an L if there are no open fcodes
$inL = 0;
if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
$lineage[-1][-1][1]{'raw'} = $raw
}
}
$raw .= $3.$4 if $inL;
} elsif(defined $5) {
DEBUG > 3 and print STDERR "Found apparent simple end-text code \"$5\"\n";
if(@stack and ! $stack[-1]) {
# We're indeed expecting a simple end-code
DEBUG > 4 and print STDERR " It's indeed an end-code.\n";
if(length($5) == 2) { # There was a space there: " >"
push @{ $lineage[-1] }, ' ';
} elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element
push @{ $lineage[-1] }, ''; # keep it from being really childless
}
pop @stack;
pop @lineage;
} else {
DEBUG > 4 and print STDERR " It's just stuff.\n";
push @{ $lineage[-1] }, $5;
}
unless (@stack) { # not in an L if there are no open fcodes
$inL = 0;
if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
$lineage[-1][-1][1]{'raw'} = $raw
}
}
$raw .= $5 if $inL;
} elsif(defined $6) {
DEBUG > 3 and print STDERR "Found stuff \"$6\"\n";
push @{ $lineage[-1] }, $6;
$raw .= $6 if $inL;
# XXX does not capture multiplace whitespaces -- 'raw' ends up with
# at most 1 leading/trailing whitespace, why not all of it?
} else {
# should never ever ever ever happen
DEBUG and print STDERR "AYYAYAAAAA at line ", __LINE__, "\n";
die "SPORK 512512!";
}
}
if(@stack) { # Uhoh, some sequences weren't closed.
my $x= "...";
while(@stack) {
push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
# Hmmmmm!
my $code = (pop @lineage)->[0];
my $ender_length = pop @stack;
if($ender_length) {
--$ender_length;
$x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length);
} else {
$x = $code . "<$x>";
}
}
DEBUG > 1 and print STDERR "Unterminated $x sequence\n";
$self->whine($start_line,
"Unterminated $x sequence",
);
}
return $treelet;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub text_content_of_treelet { # method: $parser->text_content_of_treelet($lol)
return stringify_lol($_[1]);
}
sub stringify_lol { # function: stringify_lol($lol)
my $string_form = '';
_stringify_lol( $_[0] => \$string_form );
return $string_form;
}
sub _stringify_lol { # the real recursor
my($lol, $to) = @_;
for(my $i = 2; $i < @$lol; ++$i) {
if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) {
_stringify_lol( $lol->[$i], $to); # recurse!
} else {
$$to .= $lol->[$i];
}
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _dump_curr_open { # return a string representation of the stack
my $curr_open = $_[0]{'curr_open'};
return '[empty]' unless @$curr_open;
return join '; ',
map {;
($_->[0] eq '=for')
? ( ($_->[1]{'~really'} || '=over')
. ' ' . $_->[1]{'target'})
: $_->[0]
}
@$curr_open
;
}
###########################################################################
my %pretty_form = (
"\a" => '\a', # ding!
"\b" => '\b', # BS
"\e" => '\e', # ESC
"\f" => '\f', # FF
"\t" => '\t', # tab
"\cm" => '\cm',
"\cj" => '\cj',
"\n" => '\n', # probably overrides one of either \cm or \cj
'"' => '\"',
'\\' => '\\\\',
'$' => '\\$',
'@' => '\\@',
'%' => '\\%',
'#' => '\\#',
);
sub pretty { # adopted from Class::Classless
# Not the most brilliant routine, but passable.
# Don't give it a cyclic data structure!
my @stuff = @_; # copy
my $x;
my $out =
# join ",\n" .
join ", ",
map {;
if(!defined($_)) {
"undef";
} elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') {
$x = "[ " . pretty(@$_) . " ]" ;
$x;
} elsif(ref($_) eq 'SCALAR') {
$x = "\\" . pretty($$_) ;
$x;
} elsif(ref($_) eq 'HASH') {
my $hr = $_;
$x = "{" . join(", ",
map(pretty($_) . '=>' . pretty($hr->{$_}),
sort keys %$hr ) ) . "}" ;
$x;
} elsif(!length($_)) { q{''} # empty string
} elsif(
$_ eq '0' # very common case
or(
m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s
and $_ ne '-0' # the strange case that RE lets thru
)
) { $_;
} else {
# Yes, explicitly name every character desired. There are shorcuts one
# could make, but I (Karl Williamson) was afraid that some Perl
# releases would have bugs in some of them. For example [A-Z] works
# even on EBCDIC platforms to match exactly the 26 uppercase English
# letters, but I don't know if it has always worked without bugs. It
# seemed safest just to list the characters.
# s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
s<([^ !#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])>
<$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
#<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
qq{"$_"};
}
} @stuff;
# $out =~ s/\n */ /g if length($out) < 75;
return $out;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# A rather unsubtle method of blowing away all the state information
# from a parser object so it can be reused. Provided as a utility for
# backward compatibility in Pod::Man, etc. but not recommended for
# general use.
sub reinit {
my $self = shift;
foreach (qw(source_dead source_filename doc_has_started
start_of_pod_block content_seen last_was_blank paras curr_open
line_count pod_para_count in_pod ~tried_gen_errata all_errata errata errors_seen
Title)) {
delete $self->{$_};
}
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
PK ɮ[���n Simple/Debug.pmnu �[��� require 5;
package Pod::Simple::Debug;
use strict;
use vars qw($VERSION );
$VERSION = '3.35';
sub import {
my($value,$variable);
if(@_ == 2) {
$value = $_[1];
} elsif(@_ == 3) {
($variable, $value) = @_[1,2];
($variable, $value) = ($value, $variable)
if defined $value and ref($value) eq 'SCALAR'
and not(defined $variable and ref($variable) eq 'SCALAR')
; # tolerate getting it backwards
unless( defined $variable and ref($variable) eq 'SCALAR') {
require Carp;
Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
}
} else {
require Carp;
Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
}
if( defined &Pod::Simple::DEBUG ) {
require Carp;
Carp::croak("It's too late to call Pod::Simple::Debug -- "
. "Pod::Simple has already loaded\nAborting");
}
$value = 0 unless defined $value;
unless($value =~ m/^-?\d+$/) {
require Carp;
Carp::croak( "$value isn't a numeric value."
. "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor"
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
}
if( defined $variable ) {
# make a not-really-constant
*Pod::Simple::DEBUG = sub () { $$variable } ;
$$variable = $value;
print STDERR "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n";
} else {
*Pod::Simple::DEBUG = eval " sub () { $value } ";
print STDERR "# Starting Pod::Simple::DEBUG = $value\n";
}
require Pod::Simple;
return;
}
1;
__END__
=head1 NAME
Pod::Simple::Debug -- put Pod::Simple into trace/debug mode
=head1 SYNOPSIS
use Pod::Simple::Debug (5); # or some integer
Or:
my $debuglevel;
use Pod::Simple::Debug (\$debuglevel, 0);
...some stuff that uses Pod::Simple to do stuff, but which
you don't want debug output from...
$debug_level = 4;
...some stuff that uses Pod::Simple to do stuff, but which
you DO want debug output from...
$debug_level = 0;
=head1 DESCRIPTION
This is an internal module for controlling the debug level (a.k.a. trace
level) of Pod::Simple. This is of interest only to Pod::Simple
developers.
=head1 CAVEATS
Note that you should load this module I<before> loading Pod::Simple (or
any Pod::Simple-based class). If you try loading Pod::Simple::Debug
after &Pod::Simple::DEBUG is already defined, Pod::Simple::Debug will
throw a fatal error to the effect that
"It's too late to call Pod::Simple::Debug".
Note that the C<use Pod::Simple::Debug (\$x, I<somenum>)> mode will make
Pod::Simple (et al) run rather slower, since &Pod::Simple::DEBUG won't
be a constant sub anymore, and so Pod::Simple (et al) won't compile with
constant-folding.
=head1 GUTS
Doing this:
use Pod::Simple::Debug (5); # or some integer
is basically equivalent to:
BEGIN { sub Pod::Simple::DEBUG () {5} } # or some integer
use Pod::Simple ();
And this:
use Pod::Simple::Debug (\$debug_level,0); # or some integer
is basically equivalent to this:
my $debug_level;
BEGIN { $debug_level = 0 }
BEGIN { sub Pod::Simple::DEBUG () { $debug_level }
use Pod::Simple ();
=head1 SEE ALSO
L<Pod::Simple>
The article "Constants in Perl", in I<The Perl Journal> issue
21. See L<http://interglacial.com/tpj/21/>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[�ɏ�#
#
Simple/PullParserTextToken.pmnu �[���
require 5;
package Pod::Simple::PullParserTextToken;
use Pod::Simple::PullParserToken ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = ('Pod::Simple::PullParserToken');
$VERSION = '3.35';
sub new { # Class->new(text);
my $class = shift;
return bless ['text', @_], ref($class) || $class;
}
# Purely accessors:
sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
sub text_r { \ $_[0][1] }
1;
__END__
=head1 NAME
Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
(See L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
get an object of this class.
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
and adds these methods:
=over
=item $token->text
This returns the text that this token holds. For example, parsing
CZ<><foo> will return a C start-token, a text-token, and a C end-token. And
if you want to get the "foo" out of the text-token, call C<< $token->text >>
=item $token->text(I<somestring>)
This changes the string that this token holds. You probably won't need
to do this.
=item $token->text_r()
This returns a scalar reference to the string that this token holds.
This can be useful if you don't want to memory-copy the potentially
large text value (well, as large as a paragraph or a verbatim block)
as calling $token->text would do.
Or, if you want to alter the value, you can even do things like this:
for ( ${ $token->text_r } ) { # Aliases it with $_ !!
s/ The / the /g; # just for example
if( 'A' eq chr(65) ) { # (if in an ASCII world)
tr/\xA0/ /;
tr/\xAD//d;
}
...or however you want to alter the value...
(Note that starting with Perl v5.8, you can use, e.g.,
my $nbsp = chr utf8::unicode_to_native(0xA0);
s/$nbsp/ /g;
to handle the above regardless if it's an ASCII world or not)
}
=back
You're unlikely to ever need to construct an object of this class for
yourself, but if you want to, call
C<<
Pod::Simple::PullParserTextToken->new( I<text> )
>>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[�Y>$� $� Simple/Search.pmnu �[��� require 5.005;
package Pod::Simple::Search;
use strict;
use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
$VERSION = '3.35'; ## Current version of this package
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
use Carp ();
$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
# flag to occasionally sleep for $SLEEPY - 1 seconds.
$MAX_VERSION_WITHIN ||= 60;
my $IS_CASE_INSENSITIVE = -e uc __FILE__ && -e lc __FILE__;
#############################################################################
#use diagnostics;
use File::Spec ();
use File::Basename qw( basename dirname );
use Config ();
use Cwd qw( cwd );
#==========================================================================
__PACKAGE__->_accessorize( # Make my dumb accessor methods
'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob',
'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse',
'ciseen'
);
#==========================================================================
sub new {
my $class = shift;
my $self = bless {}, ref($class) || $class;
$self->init;
return $self;
}
sub init {
my $self = shift;
$self->inc(1);
$self->recurse(1);
$self->verbose(DEBUG);
return $self;
}
#--------------------------------------------------------------------------
sub survey {
my($self, @search_dirs) = @_;
$self = $self->new unless ref $self; # tolerate being a class method
$self->_expand_inc( \@search_dirs );
$self->{'_scan_count'} = 0;
$self->{'_dirs_visited'} = {};
$self->path2name( {} );
$self->name2path( {} );
$self->ciseen( {} );
$self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
my $cwd = cwd();
my $verbose = $self->verbose;
local $_; # don't clobber the caller's $_ !
foreach my $try (@search_dirs) {
unless( File::Spec->file_name_is_absolute($try) ) {
# make path absolute
$try = File::Spec->catfile( $cwd ,$try);
}
# simplify path
$try = File::Spec->canonpath($try);
my $start_in;
my $modname_prefix;
if($self->{'dir_prefix'}) {
$start_in = File::Spec->catdir(
$try,
grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
);
$modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
$verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
"giving $start_in (= @$modname_prefix)\n";
} else {
$start_in = $try;
}
if( $self->{'_dirs_visited'}{$start_in} ) {
$verbose and print "Directory '$start_in' already seen, skipping.\n";
next;
} else {
$self->{'_dirs_visited'}{$start_in} = 1;
}
unless(-e $start_in) {
$verbose and print "Skipping non-existent $start_in\n";
next;
}
my $closure = $self->_make_search_callback;
if(-d $start_in) {
# Normal case:
$verbose and print "Beginning excursion under $start_in\n";
$self->_recurse_dir( $start_in, $closure, $modname_prefix );
$verbose and print "Back from excursion under $start_in\n\n";
} elsif(-f _) {
# A excursion consisting of just one file!
$_ = basename($start_in);
$verbose and print "Pondering $start_in ($_)\n";
$closure->($start_in, $_, 0, []);
} else {
$verbose and print "Skipping mysterious $start_in\n";
}
}
$self->progress and $self->progress->done(
"Noted $$self{'_scan_count'} Pod files total");
$self->ciseen( {} );
return unless defined wantarray; # void
return $self->name2path unless wantarray; # scalar
return $self->name2path, $self->path2name; # list
}
#==========================================================================
sub _make_search_callback {
my $self = $_[0];
# Put the options in variables, for easy access
my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,
$path2name, $name2path, $recurse, $ciseen) =
map scalar($self->$_()),
qw(laborious verbose shadows limit_re callback progress
path2name name2path recurse ciseen);
my ($seen, $remember, $files_for);
if ($IS_CASE_INSENSITIVE) {
$seen = sub { $ciseen->{ lc $_[0] } };
$remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; };
$files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } };
} else {
$seen = sub { $name2path->{ $_[0] } };
$remember = sub { $name2path->{ $_[0] } = $_[1] };
$files_for = sub { my $n = $_[0]; grep { $path2name->{$_} eq $n } %{ $path2name } };
}
my($file, $shortname, $isdir, $modname_bits);
return sub {
($file, $shortname, $isdir, $modname_bits) = @_;
if($isdir) { # this never gets called on the startdir itself, just subdirs
unless( $recurse ) {
$verbose and print "Not recursing into '$file' as per requested.\n";
return 'PRUNE';
}
if( $self->{'_dirs_visited'}{$file} ) {
$verbose and print "Directory '$file' already seen, skipping.\n";
return 'PRUNE';
}
print "Looking in dir $file\n" if $verbose;
unless ($laborious) { # $laborious overrides pruning
if( m/^(\d+\.[\d_]{3,})\z/s
and do { my $x = $1; $x =~ tr/_//d; $x != $] }
) {
$verbose and print "Perl $] version mismatch on $_, skipping.\n";
return 'PRUNE';
}
if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
$verbose and print "$_ is a well-named module subdir. Looking....\n";
} else {
$verbose and print "$_ is a fishy directory name. Skipping.\n";
return 'PRUNE';
}
} # end unless $laborious
$self->{'_dirs_visited'}{$file} = 1;
return; # (not pruning);
}
# Make sure it's a file even worth even considering
if($laborious) {
unless(
m/\.(pod|pm|plx?)\z/i || -x _ and -T _
# Note that the cheapest operation (the RE) is run first.
) {
$verbose > 1 and print " Brushing off uninteresting $file\n";
return;
}
} else {
unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
$verbose > 1 and print " Brushing off oddly-named $file\n";
return;
}
}
$verbose and print "Considering item $file\n";
my $name = $self->_path2modname( $file, $shortname, $modname_bits );
$verbose > 0.01 and print " Nominating $file as $name\n";
if($limit_re and $name !~ m/$limit_re/i) {
$verbose and print "Shunning $name as not matching $limit_re\n";
return;
}
if( !$shadows and $seen->($name) ) {
$verbose and print "Not worth considering $file ",
"-- already saw $name as ",
join(' ', $files_for->($name)), "\n";
return;
}
# Put off until as late as possible the expense of
# actually reading the file:
$progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
return unless $self->contains_pod( $file );
++ $self->{'_scan_count'};
# Or finally take note of it:
if ( my $prev = $seen->($name) ) {
$verbose and print
"Duplicate POD found (shadowing?): $name ($file)\n",
" Already seen in ", join(' ', $files_for->($name)), "\n";
} else {
$remember->($name, $file); # Noting just the first occurrence
}
$verbose and print " Noting $name = $file\n";
if( $callback ) {
local $_ = $_; # insulate from changes, just in case
$callback->($file, $name);
}
$path2name->{$file} = $name;
return;
}
}
#==========================================================================
sub _path2modname {
my($self, $file, $shortname, $modname_bits) = @_;
# this code simplifies the POD name for Perl modules:
# * remove "site_perl"
# * remove e.g. "i586-linux" (from 'archname')
# * remove e.g. 5.00503
# * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
# * dig into the file for case-preserved name if not already mixed case
my @m = @$modname_bits;
my $x;
my $verbose = $self->verbose;
# Shaving off leading naughty-bits
while(@m
and defined($x = lc( $m[0] ))
and( $x eq 'site_perl'
or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s )
or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum
or $x eq lc( $Config::Config{'archname'} )
)) { shift @m }
my $name = join '::', @m, $shortname;
$self->_simplify_base($name);
# On VMS, case-preserved document names can't be constructed from
# filenames, so try to extract them from the "=head1 NAME" tag in the
# file instead.
if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
my $in_pod = 0;
my $in_name = 0;
my $line;
while ($line = <PODFILE>) {
chomp $line;
$in_pod = 1 if ($line =~ m/^=\w/);
$in_pod = 0 if ($line =~ m/^=cut/);
next unless $in_pod; # skip non-pod text
next if ($line =~ m/^\s*\z/); # and blank lines
next if ($in_pod && ($line =~ m/^X</)); # and commands
if ($in_name) {
if ($line =~ m/(\w+::)?(\w+)/) {
# substitute case-preserved version of name
my $podname = $2;
my $prefix = $1 || '';
$verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
$verbose and print "Attempting case restore of '$name' from '$podname'\n";
$name =~ s/$podname/$podname/i;
}
last;
}
}
$in_name = 1 if ($line =~ m/^=head1 NAME/);
}
close PODFILE;
}
return $name;
}
#==========================================================================
sub _recurse_dir {
my($self, $startdir, $callback, $modname_bits) = @_;
my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
my $verbose = $self->verbose;
my $here_string = File::Spec->curdir;
my $up_string = File::Spec->updir;
$modname_bits ||= [];
my $recursor;
$recursor = sub {
my($dir_long, $dir_bare) = @_;
if( @$modname_bits >= 10 ) {
$verbose and print "Too deep! [@$modname_bits]\n";
return;
}
unless(-d $dir_long) {
$verbose > 2 and print "But it's not a dir! $dir_long\n";
return;
}
unless( opendir(INDIR, $dir_long) ) {
$verbose > 2 and print "Can't opendir $dir_long : $!\n";
closedir(INDIR);
return
}
# Load all items; put no extension before .pod before .pm before .plx?.
my @items = map { $_->[0] }
sort { $a->[1] cmp $b->[1] || $b->[2] cmp $a->[2] }
map {
(my $t = $_) =~ s/[.]p(m|lx?|od)\z//;
[$_, $t, lc($1 || 'z') ]
} readdir(INDIR);
closedir(INDIR);
push @$modname_bits, $dir_bare unless $dir_bare eq '';
my $i_full;
foreach my $i (@items) {
next if $i eq $here_string or $i eq $up_string or $i eq '';
$i_full = File::Spec->catfile( $dir_long, $i );
if(!-r $i_full) {
$verbose and print "Skipping unreadable $i_full\n";
} elsif(-f $i_full) {
$_ = $i;
$callback->( $i_full, $i, 0, $modname_bits );
} elsif(-d _) {
$i =~ s/\.DIR\z//i if $^O eq 'VMS';
$_ = $i;
my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
if($rv eq 'PRUNE') {
$verbose > 1 and print "OK, pruning";
} else {
# Otherwise, recurse into it
$recursor->( File::Spec->catdir($dir_long, $i) , $i);
}
} else {
$verbose > 1 and print "Skipping oddity $i_full\n";
}
}
pop @$modname_bits;
return;
};;
local $_;
$recursor->($startdir, '');
undef $recursor; # allow it to be GC'd
return;
}
#==========================================================================
sub run {
# A function, useful in one-liners
my $self = __PACKAGE__->new;
$self->limit_glob($ARGV[0]) if @ARGV;
$self->callback( sub {
my($file, $name) = @_;
my $version = '';
# Yes, I know we won't catch the version in like a File/Thing.pm
# if we see File/Thing.pod first. That's just the way the
# cookie crumbles. -- SMB
if($file =~ m/\.pod$/i) {
# Don't bother looking for $VERSION in .pod files
DEBUG and print "Not looking for \$VERSION in .pod $file\n";
} elsif( !open(INPOD, $file) ) {
DEBUG and print "Couldn't open $file: $!\n";
close(INPOD);
} else {
# Sane case: file is readable
my $lines = 0;
while(<INPOD>) {
last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
DEBUG and print "Found version line (#$lines): $_";
s/\s*\#.*//s;
s/\;\s*$//s;
s/\s+$//s;
s/\t+/ /s; # nix tabs
# Optimize the most common cases:
$_ = "v$1"
if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
# like in $VERSION = "3.14159";
or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
# like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
;
# Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
$_ = sprintf("v%d.%s",
map {s/_//g; $_}
$1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
if m{\$Name:\s*([^\$]+)\$}s
;
$version = $_;
DEBUG and print "Noting $version as version\n";
last;
}
}
close(INPOD);
}
print "$name\t$version\t$file\n";
return;
# End of callback!
});
$self->survey;
}
#==========================================================================
sub simplify_name {
my($self, $str) = @_;
# Remove all path components
# XXX Why not just use basename()? -- SMB
if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
else { $str =~ s{^.*/+}{}s }
$self->_simplify_base($str);
return $str;
}
#==========================================================================
sub _simplify_base { # Internal method only
# strip Perl's own extensions
$_[1] =~ s/\.(pod|pm|plx?)\z//i;
# strip meaningless extensions on Win32 and OS/2
$_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
# strip meaningless extensions on VMS
$_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
return;
}
#==========================================================================
sub _expand_inc {
my($self, $search_dirs) = @_;
return unless $self->{'inc'};
my %seen = map { File::Spec->rel2abs($_) => 1 } @{ $search_dirs };
if ($^O eq 'MacOS') {
push @$search_dirs,
grep { !$seen{ File::Spec->rel2abs($_) }++ } $self->_mac_whammy(@INC);
# Any other OSs need custom handling here?
} else {
push @$search_dirs,
grep { !$seen{ File::Spec->rel2abs($_) }++ } @INC;
}
$self->{'laborious'} = 0; # Since inc said to use INC
return;
}
#==========================================================================
sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
my @them;
(undef,@them) = @_;
for $_ (@them) {
if ( $_ eq '.' ) {
$_ = ':';
} elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
$_ = ':'. $_;
} else {
$_ =~ s|^\./|:|;
}
}
return @them;
}
#==========================================================================
sub _limit_glob_to_limit_re {
my $self = $_[0];
my $limit_glob = $self->{'limit_glob'} || return;
my $limit_re = '^' . quotemeta($limit_glob) . '$';
$limit_re =~ s/\\\?/./g; # glob "?" => "."
$limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?"
$limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
$self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
# A common optimization:
if(!exists($self->{'dir_prefix'})
and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*"
# Optimize for sane and common cases (but not things like "*::File")
) {
$self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
$self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
}
return $limit_re;
}
#==========================================================================
# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu>
sub _actual_filenames {
my $dir = shift;
my $fn = lc shift;
opendir my $dh, $dir or return;
return map { File::Spec->catdir($dir, $_) }
grep { lc $_ eq $fn } readdir $dh;
}
sub find {
my($self, $pod, @search_dirs) = @_;
$self = $self->new unless ref $self; # tolerate being a class method
# Check usage
Carp::carp 'Usage: \$self->find($podname, ...)'
unless defined $pod and length $pod;
my $verbose = $self->verbose;
# Split on :: and then join the name together using File::Spec
my @parts = split /::/, $pod;
$verbose and print "Chomping {$pod} => {@parts}\n";
#@search_dirs = File::Spec->curdir unless @search_dirs;
$self->_expand_inc(\@search_dirs);
# Add location of binaries such as pod2text:
push @search_dirs, $Config::Config{'scriptdir'} if $self->inc;
my %seen_dir;
while (my $dir = shift @search_dirs ) {
next unless defined $dir and length $dir;
next if $seen_dir{$dir};
$seen_dir{$dir} = 1;
unless(-d $dir) {
print "Directory $dir does not exist\n" if $verbose;
}
print "Looking in directory $dir\n" if $verbose;
my $fullname = File::Spec->catfile( $dir, @parts );
print "Filename is now $fullname\n" if $verbose;
foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions
my $fullext = $fullname . $ext;
if ( -f $fullext and $self->contains_pod($fullext) ) {
print "FOUND: $fullext\n" if $verbose;
if (@parts > 1 && lc $parts[0] eq 'pod' && $IS_CASE_INSENSITIVE && $ext eq '.pod') {
# Well, this file could be for a program (perldoc) but we actually
# want a module (Pod::Perldoc). So see if there is a .pm with the
# proper casing.
my $subdir = dirname $fullext;
unless (grep { $fullext eq $_ } _actual_filenames $subdir, "$parts[-1].pod") {
print "# Looking for alternate spelling in $subdir\n" if $verbose;
# Try the .pm file.
my $pm = $fullname . '.pm';
if ( -f $pm and $self->contains_pod($pm) ) {
# Prefer the .pm if its case matches.
if (grep { $pm eq $_ } _actual_filenames $subdir, "$parts[-1].pm") {
print "FOUND: $fullext\n" if $verbose;
return $pm;
}
}
}
}
return $fullext;
}
}
# Case-insensitively Look for ./pod directories and slip them in.
for my $subdir ( _actual_filenames($dir, 'pod') ) {
if (-d $subdir) {
$verbose and print "Noticing $subdir and looking there...\n";
unshift @search_dirs, $subdir;
}
}
}
return undef;
}
#==========================================================================
sub contains_pod {
my($self, $file) = @_;
my $verbose = $self->{'verbose'};
# check for one line of POD
$verbose > 1 and print " Scanning $file for pod...\n";
unless( open(MAYBEPOD,"<$file") ) {
print "Error: $file is unreadable: $!\n";
return undef;
}
sleep($SLEEPY - 1) if $SLEEPY;
# avoid totally hogging the processor on OSs with poor process control
local $_;
while( <MAYBEPOD> ) {
if(m/^=(head\d|pod|over|item)\b/s) {
close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
chomp;
$verbose > 1 and print " Found some pod ($_) in $file\n";
return 1;
}
}
close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
$verbose > 1 and print " No POD in $file, skipping.\n";
return 0;
}
#==========================================================================
sub _accessorize { # A simple-minded method-maker
shift;
no strict 'refs';
foreach my $attrname (@_) {
*{caller() . '::' . $attrname} = sub {
use strict;
$Carp::CarpLevel = 1, Carp::croak(
"Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
) unless (@_ == 1 or @_ == 2) and ref $_[0];
# Read access:
return $_[0]->{$attrname} if @_ == 1;
# Write access:
$_[0]->{$attrname} = $_[1];
return $_[0]; # RETURNS MYSELF!
};
}
# Ya know, they say accessories make the ensemble!
return;
}
#==========================================================================
sub _state_as_string {
my $self = $_[0];
return '' unless ref $self;
my @out = "{\n # State of $self ...\n";
foreach my $k (sort keys %$self) {
push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n";
}
push @out, "}\n";
my $x = join '', @out;
$x =~ s/^/#/mg;
return $x;
}
sub _esc {
my $in = $_[0];
return 'undef' unless defined $in;
$in =~
s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
<'\\x'.(unpack("H2",$1))>eg;
return qq{"$in"};
}
#==========================================================================
run() unless caller; # run if "perl whatever/Search.pm"
1;
#==========================================================================
__END__
=head1 NAME
Pod::Simple::Search - find POD documents in directory trees
=head1 SYNOPSIS
use Pod::Simple::Search;
my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey;
print "Looky see what I found: ",
join(' ', sort keys %$name2path), "\n";
print "LWPUA docs = ",
Pod::Simple::Search->new->find('LWP::UserAgent') || "?",
"\n";
=head1 DESCRIPTION
B<Pod::Simple::Search> is a class that you use for running searches
for Pod files. An object of this class has several attributes
(mostly options for controlling search options), and some methods
for searching based on those attributes.
The way to use this class is to make a new object of this class,
set any options, and then call one of the search options
(probably C<survey> or C<find>). The sections below discuss the
syntaxes for doing all that.
=head1 CONSTRUCTOR
This class provides the one constructor, called C<new>.
It takes no parameters:
use Pod::Simple::Search;
my $search = Pod::Simple::Search->new;
=head1 ACCESSORS
This class defines several methods for setting (and, occasionally,
reading) the contents of an object. With two exceptions (discussed at
the end of this section), these attributes are just for controlling the
way searches are carried out.
Note that each of these return C<$self> when you call them as
C<< $self->I<whatever(value)> >>. That's so that you can chain
together set-attribute calls like this:
my $name2path =
Pod::Simple::Search->new
-> inc(0) -> verbose(1) -> callback(\&blab)
->survey(@there);
...which works exactly as if you'd done this:
my $search = Pod::Simple::Search->new;
$search->inc(0);
$search->verbose(1);
$search->callback(\&blab);
my $name2path = $search->survey(@there);
=over
=item $search->inc( I<true-or-false> );
This attribute, if set to a true value, means that searches should
implicitly add perl's I<@INC> paths. This
automatically considers paths specified in the C<PERL5LIB> environment
as this is prepended to I<@INC> by the Perl interpreter itself.
This attribute's default value is B<TRUE>. If you want to search
only specific directories, set $self->inc(0) before calling
$inc->survey or $inc->find.
=item $search->verbose( I<nonnegative-number> );
This attribute, if set to a nonzero positive value, will make searches output
(via C<warn>) notes about what they're doing as they do it.
This option may be useful for debugging a pod-related module.
This attribute's default value is zero, meaning that no C<warn> messages
are produced. (Setting verbose to 1 turns on some messages, and setting
it to 2 turns on even more messages, i.e., makes the following search(es)
even more verbose than 1 would make them.)
=item $search->limit_glob( I<some-glob-string> );
This option means that you want to limit the results just to items whose
podnames match the given glob/wildcard expression. For example, you
might limit your search to just "LWP::*", to search only for modules
starting with "LWP::*" (but not including the module "LWP" itself); or
you might limit your search to "LW*" to see only modules whose (full)
names begin with "LW"; or you might search for "*Find*" to search for
all modules with "Find" somewhere in their full name. (You can also use
"?" in a glob expression; so "DB?" will match "DBI" and "DBD".)
=item $search->callback( I<\&some_routine> );
This attribute means that every time this search sees a matching
Pod file, it should call this callback routine. The routine is called
with two parameters: the current file's filespec, and its pod name.
(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would
be in C<@_>.)
The callback routine's return value is not used for anything.
This attribute's default value is false, meaning that no callback
is called.
=item $search->laborious( I<true-or-false> );
Unless you set this attribute to a true value, Pod::Search will
apply Perl-specific heuristics to find the correct module PODs quickly.
This attribute's default value is false. You won't normally need
to set this to true.
Specifically: Turning on this option will disable the heuristics for
seeing only files with Perl-like extensions, omitting subdirectories
that are numeric but do I<not> match the current Perl interpreter's
version ID, suppressing F<site_perl> as a module hierarchy name, etc.
=item $search->recurse( I<true-or-false> );
Unless you set this attribute to a false value, Pod::Search will
recurse into subdirectories of the search directories.
=item $search->shadows( I<true-or-false> );
Unless you set this attribute to a true value, Pod::Simple::Search will
consider only the first file of a given modulename as it looks thru the
specified directories; that is, with this option off, if
Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this
search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm>
later on in that search, because that file is merely a "shadow". But if
you turn on C<< $self->shadows(1) >>, then these "shadow" files are
inspected too, and are noted in the pathname2podname return hash.
This attribute's default value is false; and normally you won't
need to turn it on.
=item $search->limit_re( I<some-regxp> );
Setting this attribute (to a value that's a regexp) means that you want
to limit the results just to items whose podnames match the given
regexp. Normally this option is not needed, and the more efficient
C<limit_glob> attribute is used instead.
=item $search->dir_prefix( I<some-string-value> );
Setting this attribute to a string value means that the searches should
begin in the specified subdirectory name (like "Pod" or "File::Find",
also expressible as "File/Find"). For example, the search option
C<< $search->limit_glob("File::Find::R*") >>
is the same as the combination of the search options
C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>.
Normally you don't need to know about the C<dir_prefix> option, but I
include it in case it might prove useful for someone somewhere.
(Implementationally, searching with limit_glob ends up setting limit_re
and usually dir_prefix.)
=item $search->progress( I<some-progress-object> );
If you set a value for this attribute, the value is expected
to be an object (probably of a class that you define) that has a
C<reach> method and a C<done> method. This is meant for reporting
progress during the search, if you don't want to use a simple
callback.
Normally you don't need to know about the C<progress> option, but I
include it in case it might prove useful for someone somewhere.
While a search is in progress, the progress object's C<reach> and
C<done> methods are called like this:
# Every time a file is being scanned for pod:
$progress->reach($count, "Scanning $file"); ++$count;
# And then at the end of the search:
$progress->done("Noted $count Pod files total");
Internally, we often set this to an object of class
Pod::Simple::Progress. That class is probably undocumented,
but you may wish to look at its source.
=item $name2path = $self->name2path;
This attribute is not a search parameter, but is used to report the
result of C<survey> method, as discussed in the next section.
=item $path2name = $self->path2name;
This attribute is not a search parameter, but is used to report the
result of C<survey> method, as discussed in the next section.
=back
=head1 MAIN SEARCH METHODS
Once you've actually set any options you want (if any), you can go
ahead and use the following methods to search for Pod files
in particular ways.
=head2 C<< $search->survey( @directories ) >>
The method C<survey> searches for POD documents in a given set of
files and/or directories. This runs the search according to the various
options set by the accessors above. (For example, if the C<inc> attribute
is on, as it is by default, then the perl @INC directories are implicitly
added to the list of directories (if any) that you specify.)
The return value of C<survey> is two hashes:
=over
=item C<name2path>
A hash that maps from each pod-name to the filespec (like
"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm")
=item C<path2name>
A hash that maps from each Pod filespec to its pod-name (like
"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing")
=back
Besides saving these hashes as the hashref attributes
C<name2path> and C<path2name>, calling this function also returns
these hashrefs. In list context, the return value of
C<< $search->survey >> is the list C<(\%name2path, \%path2name)>.
In scalar context, the return value is C<\%name2path>.
Or you can just call this in void context.
Regardless of calling context, calling C<survey> saves
its results in its C<name2path> and C<path2name> attributes.
E.g., when searching in F<$HOME/perl5lib>, the file
F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
I<Myclass::Subclass>. The name information can be used for POD
translators.
Only text files containing at least one valid POD command are found.
In verbose mode, a warning is printed if shadows are found (i.e., more
than one POD file with the same POD name is found, e.g. F<CPAN.pm> in
different directories). This usually indicates duplicate occurrences of
modules in the I<@INC> search path, which is occasionally inadvertent
(but is often simply a case of a user's path dir having a more recent
version than the system's general path dirs in general.)
The options to this argument is a list of either directories that are
searched recursively, or files. (Usually you wouldn't specify files,
but just dirs.) Or you can just specify an empty-list, as in
$name2path; with the C<inc> option on, as it is by default.
The POD names of files are the plain basenames with any Perl-like
extension (.pm, .pl, .pod) stripped, and path separators replaced by
C<::>'s.
Calling Pod::Simple::Search->search(...) is short for
Pod::Simple::Search->new->search(...). That is, a throwaway object
with default attribute values is used.
=head2 C<< $search->simplify_name( $str ) >>
The method B<simplify_name> is equivalent to B<basename>, but also
strips Perl-like extensions (.pm, .pl, .pod) and extensions like
F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
=head2 C<< $search->find( $pod ) >>
=head2 C<< $search->find( $pod, @search_dirs ) >>
Returns the location of a Pod file, given a Pod/module/script name
(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of
what files/directories to look in.
It searches according to the various options set by the accessors above.
(For example, if the C<inc> attribute is on, as it is by default, then
the perl @INC directories are implicitly added to the list of
directories (if any) that you specify.)
This returns the full path of the first occurrence to the file.
Package names (eg 'A::B') are automatically converted to directory
names in the selected directory. Additionally, '.pm', '.pl' and '.pod'
are automatically appended to the search as required.
(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm",
"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.)
If no such Pod file is found, this method returns undef.
If any of the given search directories contains a F<pod/> subdirectory,
then it is searched. (That's how we manage to find F<perlfunc>,
for example, which is usually in F<pod/perlfunc> in most Perl dists.)
The C<verbose> and C<inc> attributes influence the behavior of this
search; notably, C<inc>, if true, adds @INC I<and also
$Config::Config{'scriptdir'}> to the list of directories to search.
It is common to simply say C<< $filename = Pod::Simple::Search-> new
->find("perlvar") >> so that just the @INC (well, and scriptdir)
directories are searched. (This happens because the C<inc>
attribute is true by default.)
Calling Pod::Simple::Search->find(...) is short for
Pod::Simple::Search->new->find(...). That is, a throwaway object
with default attribute values is used.
=head2 C<< $self->contains_pod( $file ) >>
Returns true if the supplied filename (not POD module) contains some Pod
documentation.
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org> with code borrowed
from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from
Nick Ing-Simmons' C<PodToHtml>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ɮ[4��]m m Simple/Progress.pmnu �[���
require 5;
package Pod::Simple::Progress;
$VERSION = '3.35';
use strict;
# Objects of this class are used for noting progress of an
# operation every so often. Messages delivered more often than that
# are suppressed.
#
# There's actually nothing in here that's specific to Pod processing;
# but it's ad-hoc enough that I'm not willing to give it a name that
# implies that it's generally useful, like "IO::Progress" or something.
#
# -- sburke
#
#--------------------------------------------------------------------------
sub new {
my($class,$delay) = @_;
my $self = bless {'quiet_until' => 1}, ref($class) || $class;
$self->to(*STDOUT{IO});
$self->delay(defined($delay) ? $delay : 5);
return $self;
}
sub copy {
my $orig = shift;
bless {%$orig, 'quiet_until' => 1}, ref($orig);
}
#--------------------------------------------------------------------------
sub reach {
my($self, $point, $note) = @_;
if( (my $now = time) >= $self->{'quiet_until'}) {
my $goal;
my $to = $self->{'to'};
print $to join('',
($self->{'quiet_until'} == 1) ? () : '... ',
(defined $point) ? (
'#',
($goal = $self->{'goal'}) ? (
' ' x (length($goal) - length($point)),
$point, '/', $goal,
) : $point,
$note ? ': ' : (),
) : (),
$note || '',
"\n"
);
$self->{'quiet_until'} = $now + $self->{'delay'};
}
return $self;
}
#--------------------------------------------------------------------------
sub done {
my($self, $note) = @_;
$self->{'quiet_until'} = 1;
return $self->reach( undef, $note );
}
#--------------------------------------------------------------------------
# Simple accessors:
sub delay {
return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] }
sub goal {
return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] }
sub to {
return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] }
#--------------------------------------------------------------------------
unless(caller) { # Simple self-test:
my $p = __PACKAGE__->new->goal(5);
$p->reach(1, "Primus!");
sleep 1;
$p->reach(2, "Secundus!");
sleep 3;
$p->reach(3, "Tertius!");
sleep 5;
$p->reach(4);
$p->reach(5, "Quintus!");
sleep 1;
$p->done("All done");
}
#--------------------------------------------------------------------------
1;
__END__
PK ɮ[D� I� � Simple/DumpAsXML.pmnu �[���
require 5;
package Pod::Simple::DumpAsXML;
$VERSION = '3.35';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
use strict;
use Carp ();
use Text::Wrap qw(wrap);
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->accept_codes('VerbatimFormatted');
$new->keep_encoding_directive(1);
return $new;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_element_start {
# ($self, $element_name, $attr_hash_r)
my $fh = $_[0]{'output_fh'};
my($key, $value);
DEBUG and print STDERR "++ $_[1]\n";
print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1];
foreach my $key (sort keys %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_xml_escape($value = $_[2]{$key});
print $fh ' ', $key, '="', $value, '"';
}
}
print $fh ">\n";
$_[0]{'indent'}++;
return;
}
sub _handle_text {
DEBUG and print STDERR "== \"$_[1]\"\n";
if(length $_[1]) {
my $indent = ' ' x $_[0]{'indent'};
my $text = $_[1];
_xml_escape($text);
local $Text::Wrap::huge = 'overflow';
$text = wrap('', $indent, $text);
print {$_[0]{'output_fh'}} $indent, $text, "\n";
}
return;
}
sub _handle_element_end {
DEBUG and print STDERR "-- $_[1]\n";
print {$_[0]{'output_fh'}}
' ' x --$_[0]{'indent'}, "</", $_[1], ">\n";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _xml_escape {
foreach my $x (@_) {
# Escape things very cautiously:
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
}
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::DumpAsXML -- turn Pod into XML
=head1 SYNOPSIS
perl -MPod::Simple::DumpAsXML -e \
"exit Pod::Simple::DumpAsXML->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
Pod::Simple::DumpAsXML is a subclass of L<Pod::Simple> that parses Pod
and turns it into indented and wrapped XML. This class is of
interest to people writing Pod formatters based on Pod::Simple.
Pod::Simple::DumpAsXML inherits methods from
L<Pod::Simple>.
=head1 SEE ALSO
L<Pod::Simple::XMLOutStream> is rather like this class.
Pod::Simple::XMLOutStream's output is space-padded in a way
that's better for sending to an XML processor (that is, it has
no ignorable whitespace). But
Pod::Simple::DumpAsXML's output is much more human-readable, being
(more-or-less) one token per line, with line-wrapping.
L<Pod::Simple::DumpAsText> is rather like this class,
except that it doesn't dump with XML syntax. Try them and see
which one you like best!
L<Pod::Simple>, L<Pod::Simple::DumpAsXML>
The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
PK ʮ[L�ֿ/t /t Usage.pmnu �[��� #############################################################################
# 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;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '1.69'; ## Current version of this package
require 5.006; ## requires this Perl version or later
#use diagnostics;
use Carp;
use Config;
use Exporter;
use File::Spec;
@EXPORT = qw(&pod2usage);
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) {
$_ = File::Spec->catfile($dirname, $basename) if length;
last if (-e $_) && ($opts{'-input'} = $_);
}
}
## Now create a pod reader and constrain it to the desired sections.
my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
if ($opts{'-verbose'} == 0) {
$parser->select('(?:SYNOPSIS|USAGE)\s*');
}
elsif ($opts{'-verbose'} == 1) {
my $opt_re = '(?i)' .
'(?:OPTIONS|ARGUMENTS)' .
'(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
$parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
}
elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
$parser->select('.*');
}
elsif ($opts{'-verbose'} == 99) {
my $sections = $opts{'-sections'};
$parser->select( (ref $sections) ? @$sections : $sections );
$opts{'-verbose'} = 1;
}
## Check for perldoc
my $progpath = $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);
if($?) {
# RT16091: fall back to more if perldoc failed
system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
}
} else {
croak "Unspecified input file or insecure argument.\n";
}
}
else {
$parser->parse_from_file($opts{'-input'}, $opts{'-output'});
}
exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
}
##---------------------------------------------------------------------------
##-------------------------------
## Method definitions begin here
##-------------------------------
sub new {
my $this = shift;
my $class = ref($this) || $this;
my %params = @_;
my $self = {%params};
bless $self, $class;
if ($self->can('initialize')) {
$self->initialize();
} else {
# pass through options to Pod::Text
my %opts;
for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) {
my $val = $params{USAGE_OPTIONS}{"-$_"};
$opts{$_} = $val if defined $val;
}
$self = $self->SUPER::new(%opts);
%$self = (%$self, %params);
}
return $self;
}
# 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 { return $_[2] }
# 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/^\s*SYNOPSIS\s*$/USAGE/;
}
} elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
my $idx = $1 - 1;
$self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
$self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
# 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__
=head1 NAME
Pod::Usage - print a usage message from embedded pod documentation
=head1 SYNOPSIS
use Pod::Usage
my $message_text = "This text precedes the usage message.";
my $exit_status = 2; ## The exit status to use
my $verbose_level = 0; ## The verbose level to use
my $filehandle = \*STDERR; ## The filehandle to write to
pod2usage($message_text);
pod2usage($exit_status);
pod2usage( { -message => $message_text ,
-exitval => $exit_status ,
-verbose => $verbose_level,
-output => $filehandle } );
pod2usage( -msg => $message_text ,
-exitval => $exit_status ,
-verbose => $verbose_level,
-output => $filehandle );
pod2usage( -verbose => 2,
-noperldoc => 1 );
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 "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" section of the pod documentation
is printed. If the value is 1, then the "SYNOPSIS" section, along with any
section entitled "OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is
printed. If the corresponding value is 2 or more then the entire manpage is
printed, 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|ENVIORNMENT/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>. The -noperldoc 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,
the -perlcmd 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.
The -perldocopt 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> doesn't force the above conventions upon you, but it will
use them by default if you don't expressly tell it to do otherwise. The
ability of B<pod2usage()> to accept a single number or a string makes it
convenient to use as an innocent looking error message handling function:
use 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> isn't found, B<pod2usage()> will search
C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
If this is the case for your system, you may need to explicitly specify
the path to the pod docs for the invoking script using something
similar to the following:
pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
In the pathological case that a script is called via a relative path
I<and> the script itself changes the current working directory
(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
fail even on robust platforms. Don't do that. Or use L<FindBin> to locate
the script:
use FindBin;
pod2usage(-input => $FindBin::Bin . "/" . $FindBin::Script);
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Marek Rouchal E<lt>marekr@cpan.orgE<gt>
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<Pod::Text::pod2text()> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
=head1 ACKNOWLEDGMENTS
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
PK ʮ[pJ�7: :
Text/Color.pmnu �[��� # Convert POD data to formatted color ASCII text
#
# This is just a basic proof of concept. It should later be modified to make
# better use of color, take options changing what colors are used for what
# text, and the like.
#
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text::Color;
use 5.006;
use strict;
use warnings;
use Pod::Text ();
use Term::ANSIColor qw(color colored);
use vars qw(@ISA $VERSION);
@ISA = qw(Pod::Text);
$VERSION = '4.11';
##############################################################################
# Overrides
##############################################################################
# Make level one headings bold.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
local $Term::ANSIColor::EACHLINE = "\n";
$self->SUPER::cmd_head1 ($attrs, colored ($text, 'bold'));
}
# Make level two headings bold.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head2 ($attrs, colored ($text, 'bold'));
}
# Fix the various formatting codes.
sub cmd_b { return colored ($_[2], 'bold') }
sub cmd_f { return colored ($_[2], 'cyan') }
sub cmd_i { return colored ($_[2], 'yellow') }
# Analyze a single line and return any formatting codes in effect at the end
# of that line.
sub end_format {
my ($self, $line) = @_;
my $reset = color ('reset');
my $current;
while ($line =~ /(\e\[[\d;]+m)/g) {
my $code = $1;
if ($code eq $reset) {
undef $current;
} else {
$current .= $code;
}
}
return $current;
}
# Output any included code in green.
sub output_code {
my ($self, $code) = @_;
local $Term::ANSIColor::EACHLINE = "\n";
$code = colored ($code, 'green');
$self->output ($code);
}
# Strip all of the formatting from a provided string, returning the stripped
# version. We will eventually want to use colorstrip() from Term::ANSIColor,
# but it's fairly new so avoid the tight dependency.
sub strip_format {
my ($self, $text) = @_;
$text =~ s/\e\[[\d;]*m//g;
return $text;
}
# We unfortunately have to override the wrapping code here, since the normal
# wrapping code gets really confused by all the escape sequences.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
# $codes matches a single special sequence. $char matches any number of
# special sequences preceding a single character other than a newline.
# $shortchar matches some sequence of $char ending in codes followed by
# whitespace or the end of the string. $longchar matches exactly $width
# $chars, used when we have to truncate and hard wrap.
#
# $shortchar and $longchar are created in a slightly odd way because the
# construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x.
my $code = '(?:\e\[[\d;]+m)';
my $char = "(?>$code*[^\\n])";
my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)';
my $longchar = '^(' . $char . "{$width})";
while (length > $width) {
if (s/$shortchar// || s/$longchar//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
# less -R always resets terminal attributes at the end of each line, so we
# need to clear attributes at the end of lines and then set them again at
# the start of the next line. This requires a second pass through the
# wrapped string, accumulating any attributes we see, remembering them,
# and then inserting the appropriate sequences at the newline.
if ($output =~ /\n/) {
my @lines = split (/\n/, $output);
my $start_format;
for my $line (@lines) {
if ($start_format && $line =~ /\S/) {
$line =~ s/^(\s*)(\S)/$1$start_format$2/;
}
$start_format = $self->end_format ($line);
if ($start_format) {
$line .= color ('reset');
}
}
$output = join ("\n", @lines);
}
# Fix up trailing whitespace and return the results.
$output =~ s/\s+$/\n\n/;
$output;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=for stopwords
Allbery
=head1 NAME
Pod::Text::Color - Convert POD data to formatted color ASCII text
=head1 SYNOPSIS
use Pod::Text::Color;
my $parser = Pod::Text::Color->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text::Color is a simple subclass of Pod::Text that highlights output
text using ANSI color escape sequences. Apart from the color, it in all
ways functions like Pod::Text. See L<Pod::Text> for details and available
options.
Term::ANSIColor is used to get colors and therefore must be installed to use
this module.
=head1 BUGS
This is just a basic proof of concept. It should be seriously expanded to
support configurable coloration via options passed to the constructor, and
B<pod2text> should be taught about those.
=head1 AUTHOR
Russ Allbery <rra@cpan.org>.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2018 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::Text>, L<Pod::Simple>
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:
PK ͮ[��SJn n Text/Overstrike.pmnu �[��� # Convert POD data to formatted overstrike text
#
# This was written because the output from:
#
# pod2text Text.pm > plain.txt; less plain.txt
#
# is not as rich as the output from
#
# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt
#
# and because both Pod::Text::Color and Pod::Text::Termcap are not device
# independent.
#
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text::Overstrike;
use 5.006;
use strict;
use warnings;
use vars qw(@ISA $VERSION);
use Pod::Text ();
@ISA = qw(Pod::Text);
$VERSION = '4.11';
##############################################################################
# Overrides
##############################################################################
# Make level one headings bold, overriding any existing formatting.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/$1\b$1/g;
return $self->SUPER::cmd_head1 ($attrs, $text);
}
# Make level two headings bold, overriding any existing formatting.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/$1\b$1/g;
return $self->SUPER::cmd_head2 ($attrs, $text);
}
# Make level three headings underscored, overriding any existing formatting.
sub cmd_head3 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/_\b$1/g;
return $self->SUPER::cmd_head3 ($attrs, $text);
}
# Level four headings look like level three headings.
sub cmd_head4 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/_\b$1/g;
return $self->SUPER::cmd_head4 ($attrs, $text);
}
# The common code for handling all headers. We have to override to avoid
# interpolating twice and because we don't want to honor alt.
sub heading {
my ($self, $text, $indent, $marker) = @_;
$self->item ("\n\n") if defined $$self{ITEM};
$text .= "\n" if $$self{opt_loose};
my $margin = ' ' x ($$self{opt_margin} + $indent);
$self->output ($margin . $text . "\n");
return '';
}
# Fix the various formatting codes.
sub cmd_b { local $_ = $_[0]->strip_format ($_[2]); s/(.)/$1\b$1/g; $_ }
sub cmd_f { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
sub cmd_i { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
# Output any included code in bold.
sub output_code {
my ($self, $code) = @_;
$code =~ s/(.)/$1\b$1/g;
$self->output ($code);
}
# Strip all of the formatting from a provided string, returning the stripped
# version.
sub strip_format {
my ($self, $text) = @_;
$text =~ s/(.)[\b]\1/$1/g;
$text =~ s/_[\b]//g;
return $text;
}
# We unfortunately have to override the wrapping code here, since the normal
# wrapping code gets really confused by all the backspaces.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
while (length > $width) {
# This regex represents a single character, that's possibly underlined
# or in bold (in which case, it's three characters; the character, a
# backspace, and a character). Use [^\n] rather than . to protect
# against odd settings of $*.
my $char = '(?:[^\n][\b])?[^\n]';
if (s/^((?>$char){0,$width})(?:\Z|\s+)//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=for stopwords
overstrike overstruck Overstruck Allbery terminal's
=head1 NAME
Pod::Text::Overstrike - Convert POD data to formatted overstrike text
=head1 SYNOPSIS
use Pod::Text::Overstrike;
my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights
output text using overstrike sequences, in a manner similar to nroff.
Characters in bold text are overstruck (character, backspace, character)
and characters in underlined text are converted to overstruck underscores
(underscore, backspace, character). This format was originally designed
for hard-copy terminals and/or line printers, yet is readable on soft-copy
(CRT) terminals.
Overstruck text is best viewed by page-at-a-time programs that take
advantage of the terminal's B<stand-out> and I<underline> capabilities, such
as the less program on Unix.
Apart from the overstrike, it in all ways functions like Pod::Text. See
L<Pod::Text> for details and available options.
=head1 BUGS
Currently, the outermost formatting instruction wins, so for example
underlined text inside a region of bold text is displayed as simply bold.
There may be some better approach possible.
=head1 AUTHOR
Originally written by Joe Smith <Joe.Smith@inwap.com>, using the framework
created by Russ Allbery <rra@cpan.org>. Subsequently updated by Russ Allbery.
=head1 COPYRIGHT AND LICENSE
Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>
Copyright 2001, 2004, 2008, 2014, 2018 by 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::Text>, L<Pod::Simple>
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:
PK Ю[�����! �! Text/Termcap.pmnu �[��� # Convert POD data to ASCII text with format escapes.
#
# This is a simple subclass of Pod::Text that overrides a few key methods to
# output the right termcap escape sequences for formatted text on the current
# terminal type.
#
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text::Termcap;
use 5.006;
use strict;
use warnings;
use Pod::Text ();
use POSIX ();
use Term::Cap;
use vars qw(@ISA $VERSION);
@ISA = qw(Pod::Text);
$VERSION = '4.11';
##############################################################################
# Overrides
##############################################################################
# In the initialization method, grab our terminal characteristics as well as
# do all the stuff we normally do.
sub new {
my ($self, %args) = @_;
my ($ospeed, $term, $termios);
# $ENV{HOME} is usually not set on Windows. The default Term::Cap path
# may not work on Solaris.
unless (exists $ENV{TERMPATH}) {
my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : '';
$ENV{TERMPATH} =
"${home}/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap";
}
# Fall back on a hard-coded terminal speed if POSIX::Termios isn't
# available (such as on VMS).
eval { $termios = POSIX::Termios->new };
if ($@) {
$ospeed = 9600;
} else {
$termios->getattr;
$ospeed = $termios->getospeed || 9600;
}
# Get data from Term::Cap if possible.
my ($bold, $undl, $norm, $width);
eval {
my $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
$bold = $term->Tputs('md');
$undl = $term->Tputs('us');
$norm = $term->Tputs('me');
if (defined $$term{_co}) {
$width = $$term{_co};
$width =~ s/^\#//;
}
};
# Figure out the terminal width before calling the Pod::Text constructor,
# since it will otherwise force 76 characters. Pod::Text::Termcap has
# historically used 2 characters less than the width of the screen, while
# the other Pod::Text classes have used 76. This is weirdly inconsistent,
# but there's probably no good reason to change it now.
unless (defined $args{width}) {
$args{width} = $ENV{COLUMNS} || $width || 80;
$args{width} -= 2;
}
# Initialize Pod::Text.
$self = $self->SUPER::new (%args);
# Fall back on the ANSI escape sequences if Term::Cap doesn't work.
$$self{BOLD} = $bold || "\e[1m";
$$self{UNDL} = $undl || "\e[4m";
$$self{NORM} = $norm || "\e[m";
return $self;
}
# Make level one headings bold.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head1 ($attrs, "$$self{BOLD}$text$$self{NORM}");
}
# Make level two headings bold.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head2 ($attrs, "$$self{BOLD}$text$$self{NORM}");
}
# Fix up B<> and I<>. Note that we intentionally don't do F<>.
sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" }
sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" }
# Analyze a single line and return any formatting codes in effect at the end
# of that line.
sub end_format {
my ($self, $line) = @_;
my $pattern = "(\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)";
my $current;
while ($line =~ /$pattern/g) {
my $code = $1;
if ($code eq $$self{NORM}) {
undef $current;
} else {
$current .= $code;
}
}
return $current;
}
# Output any included code in bold.
sub output_code {
my ($self, $code) = @_;
$self->output ($$self{BOLD} . $code . $$self{NORM});
}
# Strip all of the formatting from a provided string, returning the stripped
# version.
sub strip_format {
my ($self, $text) = @_;
$text =~ s/\Q$$self{BOLD}//g;
$text =~ s/\Q$$self{UNDL}//g;
$text =~ s/\Q$$self{NORM}//g;
return $text;
}
# Override the wrapping code to ignore the special sequences.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
# $code matches a single special sequence. $char matches any number of
# special sequences preceding a single character other than a newline.
# $shortchar matches some sequence of $char ending in codes followed by
# whitespace or the end of the string. $longchar matches exactly $width
# $chars, used when we have to truncate and hard wrap.
#
# $shortchar and $longchar are created in a slightly odd way because the
# construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x.
my $code = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)";
my $char = "(?>$code*[^\\n])";
my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)';
my $longchar = '^(' . $char . "{$width})";
while (length > $width) {
if (s/$shortchar// || s/$longchar//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
# less -R always resets terminal attributes at the end of each line, so we
# need to clear attributes at the end of lines and then set them again at
# the start of the next line. This requires a second pass through the
# wrapped string, accumulating any attributes we see, remembering them,
# and then inserting the appropriate sequences at the newline.
if ($output =~ /\n/) {
my @lines = split (/\n/, $output);
my $start_format;
for my $line (@lines) {
if ($start_format && $line =~ /\S/) {
$line =~ s/^(\s*)(\S)/$1$start_format$2/;
}
$start_format = $self->end_format ($line);
if ($start_format) {
$line .= $$self{NORM};
}
}
$output = join ("\n", @lines);
}
# Fix up trailing whitespace and return the results.
$output =~ s/\s+$/\n\n/;
return $output;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=head1 NAME
Pod::Text::Termcap - Convert POD data to ASCII text with format escapes
=for stopwords
ECMA-48 VT100 Allbery Solaris TERMPATH
=head1 SYNOPSIS
use Pod::Text::Termcap;
my $parser = Pod::Text::Termcap->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text::Termcap is a simple subclass of Pod::Text that highlights output
text using the correct termcap escape sequences for the current terminal.
Apart from the format codes, it in all ways functions like Pod::Text. See
L<Pod::Text> for details and available options.
=head1 ENVIRONMENT
This module sets the TERMPATH environment variable globally to:
$HOME/.termcap:/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap
if it isn't already set. (The first entry is omitted if the HOME
environment variable isn't set.) This is a (very old) workaround for
problems finding termcap information on older versions of Solaris, and is
not good module behavior. Please do not rely on this behavior; it may be
dropped in a future release.
=head1 NOTES
This module uses Term::Cap to retrieve the formatting escape sequences for
the current terminal, and falls back on the ECMA-48 (the same in this
regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100
terminals) if the bold, underline, and reset codes aren't set in the
termcap information.
=head1 AUTHOR
Russ Allbery <rra@cpan.org>.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2001-2002, 2004, 2006, 2008-2009, 2014-2015, 2018 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::Text>, L<Pod::Simple>, L<Term::Cap>
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:
PK Ю[���� � Parser.pmnu �[��� #############################################################################
# Pod/Parser.pm -- package which defines a base class for parsing POD docs.
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Parser;
use strict;
## These "variables" are used as local "glob aliases" for performance
use vars qw($VERSION @ISA %myData %myOpts @input_stack);
$VERSION = '1.63'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
=head1 NAME
Pod::Parser - base class for creating POD filters and translators
=head1 SYNOPSIS
use Pod::Parser;
package MyParser;
@ISA = qw(Pod::Parser);
sub command {
my ($parser, $command, $paragraph, $line_num) = @_;
## Interpret the command and its text; sample actions might be:
if ($command eq 'head1') { ... }
elsif ($command eq 'head2') { ... }
## ... other commands and their actions
my $out_fh = $parser->output_handle();
my $expansion = $parser->interpolate($paragraph, $line_num);
print $out_fh $expansion;
}
sub verbatim {
my ($parser, $paragraph, $line_num) = @_;
## Format verbatim paragraph; sample actions might be:
my $out_fh = $parser->output_handle();
print $out_fh $paragraph;
}
sub textblock {
my ($parser, $paragraph, $line_num) = @_;
## Translate/Format this block of text; sample actions might be:
my $out_fh = $parser->output_handle();
my $expansion = $parser->interpolate($paragraph, $line_num);
print $out_fh $expansion;
}
sub interior_sequence {
my ($parser, $seq_command, $seq_argument) = @_;
## Expand an interior sequence; sample actions might be:
return "*$seq_argument*" if ($seq_command eq 'B');
return "`$seq_argument'" if ($seq_command eq 'C');
return "_${seq_argument}_'" if ($seq_command eq 'I');
## ... other sequence commands and their resulting text
}
package main;
## Create a parser object and have it parse file whose name was
## given on the command-line (use STDIN if no files were given).
$parser = new MyParser();
$parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0);
for (@ARGV) { $parser->parse_from_file($_); }
=head1 REQUIRES
perl5.005, Pod::InputObjects, Exporter, Symbol, Carp
=head1 EXPORTS
Nothing.
=head1 DESCRIPTION
B<NOTE: This module is considered legacy; modern Perl releases (5.18 and
higher) are going to remove Pod-Parser from core and use L<Pod-Simple>
for all things POD.>
B<Pod::Parser> is a base class for creating POD filters and translators.
It handles most of the effort involved with parsing the POD sections
from an input stream, leaving subclasses free to be concerned only with
performing the actual translation of text.
B<Pod::Parser> parses PODs, and makes method calls to handle the various
components of the POD. Subclasses of B<Pod::Parser> override these methods
to translate the POD into whatever output format they desire.
=head1 QUICK OVERVIEW
To create a POD filter for translating POD documentation into some other
format, you create a subclass of B<Pod::Parser> which typically overrides
just the base class implementation for the following methods:
=over 2
=item *
B<command()>
=item *
B<verbatim()>
=item *
B<textblock()>
=item *
B<interior_sequence()>
=back
You may also want to override the B<begin_input()> and B<end_input()>
methods for your subclass (to perform any needed per-file and/or
per-document initialization or cleanup).
If you need to perform any preprocessing of input before it is parsed
you may want to override one or more of B<preprocess_line()> and/or
B<preprocess_paragraph()>.
Sometimes it may be necessary to make more than one pass over the input
files. If this is the case you have several options. You can make the
first pass using B<Pod::Parser> and override your methods to store the
intermediate results in memory somewhere for the B<end_pod()> method to
process. You could use B<Pod::Parser> for several passes with an
appropriate state variable to control the operation for each pass. If
your input source can't be reset to start at the beginning, you can
store it in some other structure as a string or an array and have that
structure implement a B<getline()> method (which is all that
B<parse_from_filehandle()> uses to read input).
Feel free to add any member data fields you need to keep track of things
like current font, indentation, horizontal or vertical position, or
whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA">
to avoid name collisions.
For the most part, the B<Pod::Parser> base class should be able to
do most of the input parsing for you and leave you free to worry about
how to interpret the commands and translate the result.
Note that all we have described here in this quick overview is the
simplest most straightforward use of B<Pod::Parser> to do stream-based
parsing. It is also possible to use the B<Pod::Parser::parse_text> function
to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">.
=head1 PARSING OPTIONS
A I<parse-option> is simply a named option of B<Pod::Parser> with a
value that corresponds to a certain specified behavior. These various
behaviors of B<Pod::Parser> may be enabled/disabled by setting
or unsetting one or more I<parse-options> using the B<parseopts()> method.
The set of currently accepted parse-options is as follows:
=over 3
=item B<-want_nonPODs> (default: unset)
Normally (by default) B<Pod::Parser> will only provide access to
the POD sections of the input. Input paragraphs that are not part
of the POD-format documentation are not made available to the caller
(not even using B<preprocess_paragraph()>). Setting this option to a
non-empty, non-zero value will allow B<preprocess_paragraph()> to see
non-POD sections of the input as well as POD sections. The B<cutting()>
method can be used to determine if the corresponding paragraph is a POD
paragraph, or some other input paragraph.
=item B<-process_cut_cmd> (default: unset)
Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive
by itself and does not pass it on to the caller for processing. Setting
this option to a non-empty, non-zero value will cause B<Pod::Parser> to
pass the C<=cut> directive to the caller just like any other POD command
(and hence it may be processed by the B<command()> method).
B<Pod::Parser> will still interpret the C<=cut> directive to mean that
"cutting mode" has been (re)entered, but the caller will get a chance
to capture the actual C<=cut> paragraph itself for whatever purpose
it desires.
=item B<-warnings> (default: unset)
Normally (by default) B<Pod::Parser> recognizes a bare minimum of
pod syntax errors and warnings and issues diagnostic messages
for errors, but not for warnings. (Use B<Pod::Checker> to do more
thorough checking of POD syntax.) Setting this option to a non-empty,
non-zero value will cause B<Pod::Parser> to issue diagnostics for
the few warnings it recognizes as well as the errors.
=back
Please see L<"parseopts()"> for a complete description of the interface
for the setting and unsetting of parse-options.
=cut
#############################################################################
#use diagnostics;
use Pod::InputObjects;
use Carp;
use Exporter;
BEGIN {
if ($] < 5.006) {
require Symbol;
import Symbol;
}
}
@ISA = qw(Exporter);
#############################################################################
=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES
B<Pod::Parser> provides several methods which most subclasses will probably
want to override. These methods are as follows:
=cut
##---------------------------------------------------------------------------
=head1 B<command()>
$parser->command($cmd,$text,$line_num,$pod_para);
This method should be overridden by subclasses to take the appropriate
action when a POD command paragraph (denoted by a line beginning with
"=") is encountered. When such a POD directive is seen in the input,
this method is called and is passed:
=over 3
=item C<$cmd>
the name of the command for this POD paragraph
=item C<$text>
the paragraph text for the given POD paragraph command.
=item C<$line_num>
the line-number of the beginning of the paragraph
=item C<$pod_para>
a reference to a C<Pod::Paragraph> object which contains further
information about the paragraph command (see L<Pod::InputObjects>
for details).
=back
B<Note> that this method I<is> called for C<=pod> paragraphs.
The base class implementation of this method simply treats the raw POD
command as normal block of paragraph text (invoking the B<textblock()>
method with the command paragraph).
=cut
sub command {
my ($self, $cmd, $text, $line_num, $pod_para) = @_;
## Just treat this like a textblock
$self->textblock($pod_para->raw_text(), $line_num, $pod_para);
}
##---------------------------------------------------------------------------
=head1 B<verbatim()>
$parser->verbatim($text,$line_num,$pod_para);
This method may be overridden by subclasses to take the appropriate
action when a block of verbatim text is encountered. It is passed the
following parameters:
=over 3
=item C<$text>
the block of text for the verbatim paragraph
=item C<$line_num>
the line-number of the beginning of the paragraph
=item C<$pod_para>
a reference to a C<Pod::Paragraph> object which contains further
information about the paragraph (see L<Pod::InputObjects>
for details).
=back
The base class implementation of this method simply prints the textblock
(unmodified) to the output filehandle.
=cut
sub verbatim {
my ($self, $text, $line_num, $pod_para) = @_;
my $out_fh = $self->{_OUTPUT};
print $out_fh $text;
}
##---------------------------------------------------------------------------
=head1 B<textblock()>
$parser->textblock($text,$line_num,$pod_para);
This method may be overridden by subclasses to take the appropriate
action when a normal block of POD text is encountered (although the base
class method will usually do what you want). It is passed the following
parameters:
=over 3
=item C<$text>
the block of text for the a POD paragraph
=item C<$line_num>
the line-number of the beginning of the paragraph
=item C<$pod_para>
a reference to a C<Pod::Paragraph> object which contains further
information about the paragraph (see L<Pod::InputObjects>
for details).
=back
In order to process interior sequences, subclasses implementations of
this method will probably want to invoke either B<interpolate()> or
B<parse_text()>, passing it the text block C<$text>, and the corresponding
line number in C<$line_num>, and then perform any desired processing upon
the returned result.
The base class implementation of this method simply prints the text block
as it occurred in the input stream).
=cut
sub textblock {
my ($self, $text, $line_num, $pod_para) = @_;
my $out_fh = $self->{_OUTPUT};
print $out_fh $self->interpolate($text, $line_num);
}
##---------------------------------------------------------------------------
=head1 B<interior_sequence()>
$parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq);
This method should be overridden by subclasses to take the appropriate
action when an interior sequence is encountered. An interior sequence is
an embedded command within a block of text which appears as a command
name (usually a single uppercase character) followed immediately by a
string of text which is enclosed in angle brackets. This method is
passed the sequence command C<$seq_cmd> and the corresponding text
C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior
sequence that occurs in the string that it is passed. It should return
the desired text string to be used in place of the interior sequence.
The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence>
object which contains further information about the interior sequence.
Please see L<Pod::InputObjects> for details if you need to access this
additional information.
Subclass implementations of this method may wish to invoke the
B<nested()> method of C<$pod_seq> to see if it is nested inside
some other interior-sequence (and if so, which kind).
The base class implementation of the B<interior_sequence()> method
simply returns the raw text of the interior sequence (as it occurred
in the input) to the caller.
=cut
sub interior_sequence {
my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_;
## Just return the raw text of the interior sequence
return $pod_seq->raw_text();
}
#############################################################################
=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES
B<Pod::Parser> provides several methods which subclasses may want to override
to perform any special pre/post-processing. These methods do I<not> have to
be overridden, but it may be useful for subclasses to take advantage of them.
=cut
##---------------------------------------------------------------------------
=head1 B<new()>
my $parser = Pod::Parser->new();
This is the constructor for B<Pod::Parser> and its subclasses. You
I<do not> need to override this method! It is capable of constructing
subclass objects as well as base class objects, provided you use
any of the following constructor invocation styles:
my $parser1 = MyParser->new();
my $parser2 = new MyParser();
my $parser3 = $parser2->new();
where C<MyParser> is some subclass of B<Pod::Parser>.
Using the syntax C<MyParser::new()> to invoke the constructor is I<not>
recommended, but if you insist on being able to do this, then the
subclass I<will> need to override the B<new()> constructor method. If
you do override the constructor, you I<must> be sure to invoke the
B<initialize()> method of the newly blessed object.
Using any of the above invocations, the first argument to the
constructor is always the corresponding package name (or object
reference). No other arguments are required, but if desired, an
associative array (or hash-table) my be passed to the B<new()>
constructor, as in:
my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 );
my $parser2 = new MyParser( -myflag => 1 );
All arguments passed to the B<new()> constructor will be treated as
key/value pairs in a hash-table. The newly constructed object will be
initialized by copying the contents of the given hash-table (which may
have been empty). The B<new()> constructor for this class and all of its
subclasses returns a blessed reference to the initialized object (hash-table).
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my ($this,%params) = @_;
my $class = ref($this) || $this;
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object.
my $self = { %params };
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
$self->initialize();
return $self;
}
##---------------------------------------------------------------------------
=head1 B<initialize()>
$parser->initialize();
This method performs any necessary object initialization. It takes no
arguments (other than the object instance of course, which is typically
copied to a local variable named C<$self>). If subclasses override this
method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>.
=cut
sub initialize {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<begin_pod()>
$parser->begin_pod();
This method is invoked at the beginning of processing for each POD
document that is encountered in the input. Subclasses should override
this method to perform any per-document initialization.
=cut
sub begin_pod {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<begin_input()>
$parser->begin_input();
This method is invoked by B<parse_from_filehandle()> immediately I<before>
processing input from a filehandle. The base class implementation does
nothing, however, subclasses may override it to perform any per-file
initializations.
Note that if multiple files are parsed for a single POD document
(perhaps the result of some future C<=include> directive) this method
is invoked for every file that is parsed. If you wish to perform certain
initializations once per document, then you should use B<begin_pod()>.
=cut
sub begin_input {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<end_input()>
$parser->end_input();
This method is invoked by B<parse_from_filehandle()> immediately I<after>
processing input from a filehandle. The base class implementation does
nothing, however, subclasses may override it to perform any per-file
cleanup actions.
Please note that if multiple files are parsed for a single POD document
(perhaps the result of some kind of C<=include> directive) this method
is invoked for every file that is parsed. If you wish to perform certain
cleanup actions once per document, then you should use B<end_pod()>.
=cut
sub end_input {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<end_pod()>
$parser->end_pod();
This method is invoked at the end of processing for each POD document
that is encountered in the input. Subclasses should override this method
to perform any per-document finalization.
=cut
sub end_pod {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<preprocess_line()>
$textline = $parser->preprocess_line($text, $line_num);
This method should be overridden by subclasses that wish to perform
any kind of preprocessing for each I<line> of input (I<before> it has
been determined whether or not it is part of a POD paragraph). The
parameter C<$text> is the input line; and the parameter C<$line_num> is
the line number of the corresponding text line.
The value returned should correspond to the new text to use in its
place. If the empty string or an undefined value is returned then no
further processing will be performed for this line.
Please note that the B<preprocess_line()> method is invoked I<before>
the B<preprocess_paragraph()> method. After all (possibly preprocessed)
lines in a paragraph have been assembled together and it has been
determined that the paragraph is part of the POD documentation from one
of the selected sections, then B<preprocess_paragraph()> is invoked.
The base class implementation of this method returns the given text.
=cut
sub preprocess_line {
my ($self, $text, $line_num) = @_;
return $text;
}
##---------------------------------------------------------------------------
=head1 B<preprocess_paragraph()>
$textblock = $parser->preprocess_paragraph($text, $line_num);
This method should be overridden by subclasses that wish to perform any
kind of preprocessing for each block (paragraph) of POD documentation
that appears in the input stream. The parameter C<$text> is the POD
paragraph from the input file; and the parameter C<$line_num> is the
line number for the beginning of the corresponding paragraph.
The value returned should correspond to the new text to use in its
place If the empty string is returned or an undefined value is
returned, then the given C<$text> is ignored (not processed).
This method is invoked after gathering up all the lines in a paragraph
and after determining the cutting state of the paragraph,
but before trying to further parse or interpret them. After
B<preprocess_paragraph()> returns, the current cutting state (which
is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates
to true then input text (including the given C<$text>) is cut (not
processed) until the next POD directive is encountered.
Please note that the B<preprocess_line()> method is invoked I<before>
the B<preprocess_paragraph()> method. After all (possibly preprocessed)
lines in a paragraph have been assembled together and either it has been
determined that the paragraph is part of the POD documentation from one
of the selected sections or the C<-want_nonPODs> option is true,
then B<preprocess_paragraph()> is invoked.
The base class implementation of this method returns the given text.
=cut
sub preprocess_paragraph {
my ($self, $text, $line_num) = @_;
return $text;
}
#############################################################################
=head1 METHODS FOR PARSING AND PROCESSING
B<Pod::Parser> provides several methods to process input text. These
methods typically won't need to be overridden (and in some cases they
can't be overridden), but subclasses may want to invoke them to exploit
their functionality.
=cut
##---------------------------------------------------------------------------
=head1 B<parse_text()>
$ptree1 = $parser->parse_text($text, $line_num);
$ptree2 = $parser->parse_text({%opts}, $text, $line_num);
$ptree3 = $parser->parse_text(\%opts, $text, $line_num);
This method is useful if you need to perform your own interpolation
of interior sequences and can't rely upon B<interpolate> to expand
them in simple bottom-up order.
The parameter C<$text> is a string or block of text to be parsed
for interior sequences; and the parameter C<$line_num> is the
line number corresponding to the beginning of C<$text>.
B<parse_text()> will parse the given text into a parse-tree of "nodes."
and interior-sequences. Each "node" in the parse tree is either a
text-string, or a B<Pod::InteriorSequence>. The result returned is a
parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects>
for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>.
If desired, an optional hash-ref may be specified as the first argument
to customize certain aspects of the parse-tree that is created and
returned. The set of recognized option keywords are:
=over 3
=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name>
Normally, the parse-tree returned by B<parse_text()> will contain an
unexpanded C<Pod::InteriorSequence> object for each interior-sequence
encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand"
every interior-sequence it sees by invoking the referenced function
(or named method of the parser object) and using the return value as the
expanded result.
If a subroutine reference was given, it is invoked as:
&$code_ref( $parser, $sequence )
and if a method-name was given, it is invoked as:
$parser->method_name( $sequence )
where C<$parser> is a reference to the parser object, and C<$sequence>
is a reference to the interior-sequence object.
[I<NOTE>: If the B<interior_sequence()> method is specified, then it is
invoked according to the interface specified in L<"interior_sequence()">].
=item B<-expand_text> =E<gt> I<code-ref>|I<method-name>
Normally, the parse-tree returned by B<parse_text()> will contain a
text-string for each contiguous sequence of characters outside of an
interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to
"preprocess" every such text-string it sees by invoking the referenced
function (or named method of the parser object) and using the return value
as the preprocessed (or "expanded") result. [Note that if the result is
an interior-sequence, then it will I<not> be expanded as specified by the
B<-expand_seq> option; Any such recursive expansion needs to be handled by
the specified callback routine.]
If a subroutine reference was given, it is invoked as:
&$code_ref( $parser, $text, $ptree_node )
and if a method-name was given, it is invoked as:
$parser->method_name( $text, $ptree_node )
where C<$parser> is a reference to the parser object, C<$text> is the
text-string encountered, and C<$ptree_node> is a reference to the current
node in the parse-tree (usually an interior-sequence object or else the
top-level node of the parse-tree).
=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name>
Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an
argument to the referenced subroutine (or named method of the parser
object) and return the result instead of the parse-tree object.
If a subroutine reference was given, it is invoked as:
&$code_ref( $parser, $ptree )
and if a method-name was given, it is invoked as:
$parser->method_name( $ptree )
where C<$parser> is a reference to the parser object, and C<$ptree>
is a reference to the parse-tree object.
=back
=cut
sub parse_text {
my $self = shift;
local $_ = '';
## Get options and set any defaults
my %opts = (ref $_[0]) ? %{ shift() } : ();
my $expand_seq = $opts{'-expand_seq'} || undef;
my $expand_text = $opts{'-expand_text'} || undef;
my $expand_ptree = $opts{'-expand_ptree'} || undef;
my $text = shift;
my $line = shift;
my $file = $self->input_file();
my $cmd = "";
## Convert method calls into closures, for our convenience
my $xseq_sub = $expand_seq;
my $xtext_sub = $expand_text;
my $xptree_sub = $expand_ptree;
if (defined $expand_seq and $expand_seq eq 'interior_sequence') {
## If 'interior_sequence' is the method to use, we have to pass
## more than just the sequence object, we also need to pass the
## sequence name and text.
$xseq_sub = sub {
my ($sself, $iseq) = @_;
my $args = join('', $iseq->parse_tree->children);
return $sself->interior_sequence($iseq->name, $args, $iseq);
};
}
ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) };
ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) };
ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) };
## Keep track of the "current" interior sequence, and maintain a stack
## of "in progress" sequences.
##
## NOTE that we push our own "accumulator" at the very beginning of the
## stack. It's really a parse-tree, not a sequence; but it implements
## the methods we need so we can use it to gather-up all the sequences
## and strings we parse. Thus, by the end of our parsing, it should be
## the only thing left on our stack and all we have to do is return it!
##
my $seq = Pod::ParseTree->new();
my @seq_stack = ($seq);
my ($ldelim, $rdelim) = ('', '');
## Iterate over all sequence starts text (NOTE: split with
## capturing parens keeps the delimiters)
$_ = $text;
my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/;
while ( @tokens ) {
$_ = shift @tokens;
## Look for the beginning of a sequence
if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) {
## Push a new sequence onto the stack of those "in-progress"
my $ldelim_orig;
($cmd, $ldelim_orig) = ($1, $2);
($ldelim = $ldelim_orig) =~ s/\s+$//;
($rdelim = $ldelim) =~ tr/</>/;
$seq = Pod::InteriorSequence->new(
-name => $cmd,
-ldelim => $ldelim_orig, -rdelim => $rdelim,
-file => $file, -line => $line
);
(@seq_stack > 1) and $seq->nested($seq_stack[-1]);
push @seq_stack, $seq;
}
## Look for sequence ending
elsif ( @seq_stack > 1 ) {
## Make sure we match the right kind of closing delimiter
my ($seq_end, $post_seq) = ('', '');
if ( ($ldelim eq '<' and /\A(.*?)(>)/s)
or /\A(.*?)(\s+$rdelim)/s )
{
## Found end-of-sequence, capture the interior and the
## closing the delimiter, and put the rest back on the
## token-list
$post_seq = substr($_, length($1) + length($2));
($_, $seq_end) = ($1, $2);
(length $post_seq) and unshift @tokens, $post_seq;
}
if (length) {
## In the middle of a sequence, append this text to it, and
## don't forget to "expand" it if that's what the caller wanted
$seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
$_ .= $seq_end;
}
if (length $seq_end) {
## End of current sequence, record terminating delimiter
$seq->rdelim($seq_end);
## Pop it off the stack of "in progress" sequences
pop @seq_stack;
## Append result to its parent in current parse tree
$seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq)
: $seq);
## Remember the current cmd-name and left-delimiter
if(@seq_stack > 1) {
$cmd = $seq_stack[-1]->name;
$ldelim = $seq_stack[-1]->ldelim;
$rdelim = $seq_stack[-1]->rdelim;
} else {
$cmd = $ldelim = $rdelim = '';
}
}
}
elsif (length) {
## In the middle of a sequence, append this text to it, and
## don't forget to "expand" it if that's what the caller wanted
$seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
}
## Keep track of line count
$line += /\n/;
## Remember the "current" sequence
$seq = $seq_stack[-1];
}
## Handle unterminated sequences
my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef;
while (@seq_stack > 1) {
($cmd, $file, $line) = ($seq->name, $seq->file_line);
$ldelim = $seq->ldelim;
($rdelim = $ldelim) =~ tr/</>/;
$rdelim =~ s/^(\S+)(\s*)$/$2$1/;
pop @seq_stack;
my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}".
" at line $line in file $file\n";
(ref $errorsub) and &{$errorsub}($errmsg)
or (defined $errorsub) and $self->$errorsub($errmsg)
or carp($errmsg);
$seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq);
$seq = $seq_stack[-1];
}
## Return the resulting parse-tree
my $ptree = (pop @seq_stack)->parse_tree;
return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree;
}
##---------------------------------------------------------------------------
=head1 B<interpolate()>
$textblock = $parser->interpolate($text, $line_num);
This method translates all text (including any embedded interior sequences)
in the given text string C<$text> and returns the interpolated result. The
parameter C<$line_num> is the line number corresponding to the beginning
of C<$text>.
B<interpolate()> merely invokes a private method to recursively expand
nested interior sequences in bottom-up order (innermost sequences are
expanded first). If there is a need to expand nested sequences in
some alternate order, use B<parse_text> instead.
=cut
sub interpolate {
my($self, $text, $line_num) = @_;
my %parse_opts = ( -expand_seq => 'interior_sequence' );
my $ptree = $self->parse_text( \%parse_opts, $text, $line_num );
return join '', $ptree->children();
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<parse_paragraph()>
$parser->parse_paragraph($text, $line_num);
This method takes the text of a POD paragraph to be processed, along
with its corresponding line number, and invokes the appropriate method
(one of B<command()>, B<verbatim()>, or B<textblock()>).
For performance reasons, this method is invoked directly without any
dynamic lookup; Hence subclasses may I<not> override it!
=end __PRIVATE__
=cut
sub parse_paragraph {
my ($self, $text, $line_num) = @_;
local *myData = $self; ## alias to avoid deref-ing overhead
local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
local $_;
## See if we want to preprocess nonPOD paragraphs as well as POD ones.
my $wantNonPods = $myOpts{'-want_nonPODs'};
## Update cutting status
$myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/;
## Perform any desired preprocessing if we wanted it this early
$wantNonPods and $text = $self->preprocess_paragraph($text, $line_num);
## Ignore up until next POD directive if we are cutting
return if $myData{_CUTTING};
## Now we know this is block of text in a POD section!
##-----------------------------------------------------------------
## This is a hook (hack ;-) for Pod::Select to do its thing without
## having to override methods, but also without Pod::Parser assuming
## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS
## field exists then we assume there is an is_selected() method for
## us to invoke (calling $self->can('is_selected') could verify this
## but that is more overhead than I want to incur)
##-----------------------------------------------------------------
## Ignore this block if it isn't in one of the selected sections
if (exists $myData{_SELECTED_SECTIONS}) {
$self->is_selected($text) or return ($myData{_CUTTING} = 1);
}
## If we haven't already, perform any desired preprocessing and
## then re-check the "cutting" state
unless ($wantNonPods) {
$text = $self->preprocess_paragraph($text, $line_num);
return 1 unless ((defined $text) and (length $text));
return 1 if ($myData{_CUTTING});
}
## Look for one of the three types of paragraphs
my ($pfx, $cmd, $arg, $sep) = ('', '', '', '');
my $pod_para = undef;
if ($text =~ /^(={1,2})(?=\S)/) {
## Looks like a command paragraph. Capture the command prefix used
## ("=" or "=="), as well as the command-name, its paragraph text,
## and whatever sequence of characters was used to separate them
$pfx = $1;
$_ = substr($text, length $pfx);
($cmd, $sep, $text) = split /(\s+)/, $_, 2;
$sep = '' unless defined $sep;
$text = '' unless defined $text;
## If this is a "cut" directive then we don't need to do anything
## except return to "cutting" mode.
if ($cmd eq 'cut') {
$myData{_CUTTING} = 1;
return unless $myOpts{'-process_cut_cmd'};
}
}
## Save the attributes indicating how the command was specified.
$pod_para = new Pod::Paragraph(
-name => $cmd,
-text => $text,
-prefix => $pfx,
-separator => $sep,
-file => $myData{_INFILE},
-line => $line_num
);
# ## Invoke appropriate callbacks
# if (exists $myData{_CALLBACKS}) {
# ## Look through the callback list, invoke callbacks,
# ## then see if we need to do the default actions
# ## (invoke_callbacks will return true if we do).
# return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para);
# }
# If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp
if ($myData{_WHITESPACE} and $myOpts{'-warnings'}
and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) {
my $errorsub = $self->errorsub();
my $line = $line_num - 1;
my $errmsg = "*** WARNING: line containing nothing but whitespace".
" in paragraph at line $line in file $myData{_INFILE}\n";
(ref $errorsub) and &{$errorsub}($errmsg)
or (defined $errorsub) and $self->$errorsub($errmsg)
or carp($errmsg);
}
if (length $cmd) {
## A command paragraph
$self->command($cmd, $text, $line_num, $pod_para);
$myData{_PREVIOUS} = $cmd;
}
elsif ($text =~ /^\s+/) {
## Indented text - must be a verbatim paragraph
$self->verbatim($text, $line_num, $pod_para);
$myData{_PREVIOUS} = "verbatim";
}
else {
## Looks like an ordinary block of text
$self->textblock($text, $line_num, $pod_para);
$myData{_PREVIOUS} = "textblock";
}
# Update the whitespace for the next time around
#$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0;
return 1;
}
##---------------------------------------------------------------------------
=head1 B<parse_from_filehandle()>
$parser->parse_from_filehandle($in_fh,$out_fh);
This method takes an input filehandle (which is assumed to already be
opened for reading) and reads the entire input stream looking for blocks
(paragraphs) of POD documentation to be processed. If no first argument
is given the default input filehandle C<STDIN> is used.
The C<$in_fh> parameter may be any object that provides a B<getline()>
method to retrieve a single line of input text (hence, an appropriate
wrapper object could be used to parse PODs from a single string or an
array of strings).
Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled
into paragraphs or "blocks" (which are separated by lines containing
nothing but whitespace). For each block of POD documentation
encountered it will invoke a method to parse the given paragraph.
If a second argument is given then it should correspond to a filehandle where
output should be sent (otherwise the default output filehandle is
C<STDOUT> if no output filehandle is currently in use).
B<NOTE:> For performance reasons, this method caches the input stream at
the top of the stack in a local variable. Any attempts by clients to
change the stack contents during processing when in the midst executing
of this method I<will not affect> the input stream used by the current
invocation of this method.
This method does I<not> usually need to be overridden by subclasses.
=cut
sub parse_from_filehandle {
my $self = shift;
my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
my ($in_fh, $out_fh) = @_;
$in_fh = \*STDIN unless ($in_fh);
local *myData = $self; ## alias to avoid deref-ing overhead
local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
local $_;
## Put this stream at the top of the stack and do beginning-of-input
## processing. NOTE that $in_fh might be reset during this process.
my $topstream = $self->_push_input_stream($in_fh, $out_fh);
(exists $opts{-cutting}) and $self->cutting( $opts{-cutting} );
## Initialize line/paragraph
my ($textline, $paragraph) = ('', '');
my ($nlines, $plines) = (0, 0);
## Use <$fh> instead of $fh->getline where possible (for speed)
$_ = ref $in_fh;
my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh);
## Read paragraphs line-by-line
while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) {
$textline = $self->preprocess_line($textline, ++$nlines);
next unless ((defined $textline) && (length $textline));
if ((! length $paragraph) && ($textline =~ /^==/)) {
## '==' denotes a one-line command paragraph
$paragraph = $textline;
$plines = 1;
$textline = '';
} else {
## Append this line to the current paragraph
$paragraph .= $textline;
++$plines;
}
## See if this line is blank and ends the current paragraph.
## If it isn't, then keep iterating until it is.
next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/)
&& (length $paragraph));
## Now process the paragraph
parse_paragraph($self, $paragraph, ($nlines - $plines) + 1);
$paragraph = '';
$plines = 0;
}
## Don't forget about the last paragraph in the file
if (length $paragraph) {
parse_paragraph($self, $paragraph, ($nlines - $plines) + 1)
}
## Now pop the input stream off the top of the input stack.
$self->_pop_input_stream();
}
##---------------------------------------------------------------------------
=head1 B<parse_from_file()>
$parser->parse_from_file($filename,$outfile);
This method takes a filename and does the following:
=over 2
=item *
opens the input and output files for reading
(creating the appropriate filehandles)
=item *
invokes the B<parse_from_filehandle()> method passing it the
corresponding input and output filehandles.
=item *
closes the input and output files.
=back
If the special input filename "", "-" or "<&STDIN" is given then the STDIN
filehandle is used for input (and no open or close is performed). If no
input filename is specified then "-" is implied. Filehandle references,
or objects that support the regular IO operations (like C<E<lt>$fhE<gt>>
or C<$fh-<Egt>getline>) are also accepted; the handles must already be
opened.
If a second argument is given then it should be the name of the desired
output file. If the special output filename "-" or ">&STDOUT" is given
then the STDOUT filehandle is used for output (and no open or close is
performed). If the special output filename ">&STDERR" is given then the
STDERR filehandle is used for output (and no open or close is
performed). If no output filehandle is currently in use and no output
filename is specified, then "-" is implied.
Alternatively, filehandle references or objects that support the regular
IO operations (like C<print>, e.g. L<IO::String>) are also accepted;
the object must already be opened.
This method does I<not> usually need to be overridden by subclasses.
=cut
sub parse_from_file {
my $self = shift;
my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
my ($infile, $outfile) = @_;
my ($in_fh, $out_fh);
if ($] < 5.006) {
($in_fh, $out_fh) = (gensym(), gensym());
}
my ($close_input, $close_output) = (0, 0);
local *myData = $self;
local *_;
## Is $infile a filename or a (possibly implied) filehandle
if (defined $infile && ref $infile) {
if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
croak "Input from $1 reference not supported!\n";
}
## Must be a filehandle-ref (or else assume its a ref to an object
## that supports the common IO read operations).
$myData{_INFILE} = ${$infile};
$in_fh = $infile;
}
elsif (!defined($infile) || !length($infile) || ($infile eq '-')
|| ($infile =~ /^<&(?:STDIN|0)$/i))
{
## Not a filename, just a string implying STDIN
$infile ||= '-';
$myData{_INFILE} = '<standard input>';
$in_fh = \*STDIN;
}
else {
## We have a filename, open it for reading
$myData{_INFILE} = $infile;
open($in_fh, "< $infile") or
croak "Can't open $infile for reading: $!\n";
$close_input = 1;
}
## NOTE: we need to be *very* careful when "defaulting" the output
## file. We only want to use a default if this is the beginning of
## the entire document (but *not* if this is an included file). We
## determine this by seeing if the input stream stack has been set-up
## already
## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref?
if (ref $outfile) {
## we need to check for ref() first, as other checks involve reading
if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) {
croak "Output to $1 reference not supported!\n";
}
elsif (ref($outfile) eq 'SCALAR') {
# # NOTE: IO::String isn't a part of the perl distribution,
# # so probably we shouldn't support this case...
# require IO::String;
# $myData{_OUTFILE} = "$outfile";
# $out_fh = IO::String->new($outfile);
croak "Output to SCALAR reference not supported!\n";
}
else {
## Must be a filehandle-ref (or else assume its a ref to an
## object that supports the common IO write operations).
$myData{_OUTFILE} = ${$outfile};
$out_fh = $outfile;
}
}
elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-')
|| ($outfile =~ /^>&?(?:STDOUT|1)$/i))
{
if (defined $myData{_TOP_STREAM}) {
$out_fh = $myData{_OUTPUT};
}
else {
## Not a filename, just a string implying STDOUT
$outfile ||= '-';
$myData{_OUTFILE} = '<standard output>';
$out_fh = \*STDOUT;
}
}
elsif ($outfile =~ /^>&(STDERR|2)$/i) {
## Not a filename, just a string implying STDERR
$myData{_OUTFILE} = '<standard error>';
$out_fh = \*STDERR;
}
else {
## We have a filename, open it for writing
$myData{_OUTFILE} = $outfile;
(-d $outfile) and croak "$outfile is a directory, not POD input!\n";
open($out_fh, "> $outfile") or
croak "Can't open $outfile for writing: $!\n";
$close_output = 1;
}
## Whew! That was a lot of work to set up reasonably/robust behavior
## in the case of a non-filename for reading and writing. Now we just
## have to parse the input and close the handles when we're finished.
$self->parse_from_filehandle(\%opts, $in_fh, $out_fh);
$close_input and
close($in_fh) || croak "Can't close $infile after reading: $!\n";
$close_output and
close($out_fh) || croak "Can't close $outfile after writing: $!\n";
}
#############################################################################
=head1 ACCESSOR METHODS
Clients of B<Pod::Parser> should use the following methods to access
instance data fields:
=cut
##---------------------------------------------------------------------------
=head1 B<errorsub()>
$parser->errorsub("method_name");
$parser->errorsub(\&warn_user);
$parser->errorsub(sub { print STDERR, @_ });
Specifies the method or subroutine to use when printing error messages
about POD syntax. The supplied method/subroutine I<must> return TRUE upon
successful printing of the message. If C<undef> is given, then the B<carp>
builtin is used to issue error messages (this is the default behavior).
my $errorsub = $parser->errorsub()
my $errmsg = "This is an error message!\n"
(ref $errorsub) and &{$errorsub}($errmsg)
or (defined $errorsub) and $parser->$errorsub($errmsg)
or carp($errmsg);
Returns a method name, or else a reference to the user-supplied subroutine
used to print error messages. Returns C<undef> if the B<carp> builtin
is used to issue error messages (this is the default behavior).
=cut
sub errorsub {
return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB};
}
##---------------------------------------------------------------------------
=head1 B<cutting()>
$boolean = $parser->cutting();
Returns the current C<cutting> state: a boolean-valued scalar which
evaluates to true if text from the input file is currently being "cut"
(meaning it is I<not> considered part of the POD document).
$parser->cutting($boolean);
Sets the current C<cutting> state to the given value and returns the
result.
=cut
sub cutting {
return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING};
}
##---------------------------------------------------------------------------
##---------------------------------------------------------------------------
=head1 B<parseopts()>
When invoked with no additional arguments, B<parseopts> returns a hashtable
of all the current parsing options.
## See if we are parsing non-POD sections as well as POD ones
my %opts = $parser->parseopts();
$opts{'-want_nonPODs}' and print "-want_nonPODs\n";
When invoked using a single string, B<parseopts> treats the string as the
name of a parse-option and returns its corresponding value if it exists
(returns C<undef> if it doesn't).
## Did we ask to see '=cut' paragraphs?
my $want_cut = $parser->parseopts('-process_cut_cmd');
$want_cut and print "-process_cut_cmd\n";
When invoked with multiple arguments, B<parseopts> treats them as
key/value pairs and the specified parse-option names are set to the
given values. Any unspecified parse-options are unaffected.
## Set them back to the default
$parser->parseopts(-warnings => 0);
When passed a single hash-ref, B<parseopts> uses that hash to completely
reset the existing parse-options, all previous parse-option values
are lost.
## Reset all options to default
$parser->parseopts( { } );
See L<"PARSING OPTIONS"> for more information on the name and meaning of each
parse-option currently recognized.
=cut
sub parseopts {
local *myData = shift;
local *myOpts = ($myData{_PARSEOPTS} ||= {});
return %myOpts if (@_ == 0);
if (@_ == 1) {
local $_ = shift;
return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_};
}
my @newOpts = (%myOpts, @_);
$myData{_PARSEOPTS} = { @newOpts };
}
##---------------------------------------------------------------------------
=head1 B<output_file()>
$fname = $parser->output_file();
Returns the name of the output file being written.
=cut
sub output_file {
return $_[0]->{_OUTFILE};
}
##---------------------------------------------------------------------------
=head1 B<output_handle()>
$fhandle = $parser->output_handle();
Returns the output filehandle object.
=cut
sub output_handle {
return $_[0]->{_OUTPUT};
}
##---------------------------------------------------------------------------
=head1 B<input_file()>
$fname = $parser->input_file();
Returns the name of the input file being read.
=cut
sub input_file {
return $_[0]->{_INFILE};
}
##---------------------------------------------------------------------------
=head1 B<input_handle()>
$fhandle = $parser->input_handle();
Returns the current input filehandle object.
=cut
sub input_handle {
return $_[0]->{_INPUT};
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<input_streams()>
$listref = $parser->input_streams();
Returns a reference to an array which corresponds to the stack of all
the input streams that are currently in the middle of being parsed.
While parsing an input stream, it is possible to invoke
B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input
stream and then return to parsing the previous input stream. Each input
stream to be parsed is pushed onto the end of this input stack
before any of its input is read. The input stream that is currently
being parsed is always at the end (or top) of the input stack. When an
input stream has been exhausted, it is popped off the end of the
input stack.
Each element on this input stack is a reference to C<Pod::InputSource>
object. Please see L<Pod::InputObjects> for more details.
This method might be invoked when printing diagnostic messages, for example,
to obtain the name and line number of the all input files that are currently
being processed.
=end __PRIVATE__
=cut
sub input_streams {
return $_[0]->{_INPUT_STREAMS};
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<top_stream()>
$hashref = $parser->top_stream();
Returns a reference to the hash-table that represents the element
that is currently at the top (end) of the input stream stack
(see L<"input_streams()">). The return value will be the C<undef>
if the input stack is empty.
This method might be used when printing diagnostic messages, for example,
to obtain the name and line number of the current input file.
=end __PRIVATE__
=cut
sub top_stream {
return $_[0]->{_TOP_STREAM} || undef;
}
#############################################################################
=head1 PRIVATE METHODS AND DATA
B<Pod::Parser> makes use of several internal methods and data fields
which clients should not need to see or use. For the sake of avoiding
name collisions for client data and methods, these methods and fields
are briefly discussed here. Determined hackers may obtain further
information about them by reading the B<Pod::Parser> source code.
Private data fields are stored in the hash-object whose reference is
returned by the B<new()> constructor for this class. The names of all
private methods and data-fields used by B<Pod::Parser> begin with a
prefix of "_" and match the regular expression C</^_\w+$/>.
=cut
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head1 B<_push_input_stream()>
$hashref = $parser->_push_input_stream($in_fh,$out_fh);
This method will push the given input stream on the input stack and
perform any necessary beginning-of-document or beginning-of-file
processing. The argument C<$in_fh> is the input stream filehandle to
push, and C<$out_fh> is the corresponding output filehandle to use (if
it is not given or is undefined, then the current output stream is used,
which defaults to standard output if it doesnt exist yet).
The value returned will be reference to the hash-table that represents
the new top of the input stream stack. I<Please Note> that it is
possible for this method to use default values for the input and output
file handles. If this happens, you will need to look at the C<INPUT>
and C<OUTPUT> instance data members to determine their new values.
=end _PRIVATE_
=cut
sub _push_input_stream {
my ($self, $in_fh, $out_fh) = @_;
local *myData = $self;
## Initialize stuff for the entire document if this is *not*
## an included file.
##
## NOTE: we need to be *very* careful when "defaulting" the output
## filehandle. We only want to use a default value if this is the
## beginning of the entire document (but *not* if this is an included
## file).
unless (defined $myData{_TOP_STREAM}) {
$out_fh = \*STDOUT unless (defined $out_fh);
$myData{_CUTTING} = 1; ## current "cutting" state
$myData{_INPUT_STREAMS} = []; ## stack of all input streams
}
## Initialize input indicators
$myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE});
$myData{_OUTPUT} = $out_fh if (defined $out_fh);
$in_fh = \*STDIN unless (defined $in_fh);
$myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE});
$myData{_INPUT} = $in_fh;
my $input_top = $myData{_TOP_STREAM}
= new Pod::InputSource(
-name => $myData{_INFILE},
-handle => $in_fh,
-was_cutting => $myData{_CUTTING}
);
local *input_stack = $myData{_INPUT_STREAMS};
push(@input_stack, $input_top);
## Perform beginning-of-document and/or beginning-of-input processing
$self->begin_pod() if (@input_stack == 1);
$self->begin_input();
return $input_top;
}
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head1 B<_pop_input_stream()>
$hashref = $parser->_pop_input_stream();
This takes no arguments. It will perform any necessary end-of-file or
end-of-document processing and then pop the current input stream from
the top of the input stack.
The value returned will be reference to the hash-table that represents
the new top of the input stream stack.
=end _PRIVATE_
=cut
sub _pop_input_stream {
my ($self) = @_;
local *myData = $self;
local *input_stack = $myData{_INPUT_STREAMS};
## Perform end-of-input and/or end-of-document processing
$self->end_input() if (@input_stack > 0);
$self->end_pod() if (@input_stack == 1);
## Restore cutting state to whatever it was before we started
## parsing this file.
my $old_top = pop(@input_stack);
$myData{_CUTTING} = $old_top->was_cutting();
## Don't forget to reset the input indicators
my $input_top = undef;
if (@input_stack > 0) {
$input_top = $myData{_TOP_STREAM} = $input_stack[-1];
$myData{_INFILE} = $input_top->name();
$myData{_INPUT} = $input_top->handle();
} else {
delete $myData{_TOP_STREAM};
delete $myData{_INPUT_STREAMS};
}
return $input_top;
}
#############################################################################
=head1 TREE-BASED PARSING
If straightforward stream-based parsing wont meet your needs (as is
likely the case for tasks such as translating PODs into structured
markup languages like HTML and XML) then you may need to take the
tree-based approach. Rather than doing everything in one pass and
calling the B<interpolate()> method to expand sequences into text, it
may be desirable to instead create a parse-tree using the B<parse_text()>
method to return a tree-like structure which may contain an ordered
list of children (each of which may be a text-string, or a similar
tree-like structure).
Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and
to the objects described in L<Pod::InputObjects>. The former describes
the gory details and parameters for how to customize and extend the
parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides
several objects that may all be used interchangeably as parse-trees. The
most obvious one is the B<Pod::ParseTree> object. It defines the basic
interface and functionality that all things trying to be a POD parse-tree
should do. A B<Pod::ParseTree> is defined such that each "node" may be a
text-string, or a reference to another parse-tree. Each B<Pod::Paragraph>
object and each B<Pod::InteriorSequence> object also supports the basic
parse-tree interface.
The B<parse_text()> method takes a given paragraph of text, and
returns a parse-tree that contains one or more children, each of which
may be a text-string, or an InteriorSequence object. There are also
callback-options that may be passed to B<parse_text()> to customize
the way it expands or transforms interior-sequences, as well as the
returned result. These callbacks can be used to create a parse-tree
with custom-made objects (which may or may not support the parse-tree
interface, depending on how you choose to do it).
If you wish to turn an entire POD document into a parse-tree, that process
is fairly straightforward. The B<parse_text()> method is the key to doing
this successfully. Every paragraph-callback (i.e. the polymorphic methods
for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes
a B<Pod::Paragraph> object as an argument. Each paragraph object has a
B<parse_tree()> method that can be used to get or set a corresponding
parse-tree. So for each of those paragraph-callback methods, simply call
B<parse_text()> with the options you desire, and then use the returned
parse-tree to assign to the given paragraph object.
That gives you a parse-tree for each paragraph - so now all you need is
an ordered list of paragraphs. You can maintain that yourself as a data
element in the object/hash. The most straightforward way would be simply
to use an array-ref, with the desired set of custom "options" for each
invocation of B<parse_text>. Let's assume the desired option-set is
given by the hash C<%options>. Then we might do something like the
following:
package MyPodParserTree;
@ISA = qw( Pod::Parser );
...
sub begin_pod {
my $self = shift;
$self->{'-paragraphs'} = []; ## initialize paragraph list
}
sub command {
my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({%options}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
push @{ $self->{'-paragraphs'} }, $pod_para;
}
sub verbatim {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
push @{ $self->{'-paragraphs'} }, $pod_para;
}
sub textblock {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({%options}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
push @{ $self->{'-paragraphs'} }, $pod_para;
}
...
package main;
...
my $parser = new MyPodParserTree(...);
$parser->parse_from_file(...);
my $paragraphs_ref = $parser->{'-paragraphs'};
Of course, in this module-author's humble opinion, I'd be more inclined to
use the existing B<Pod::ParseTree> object than a simple array. That way
everything in it, paragraphs and sequences, all respond to the same core
interface for all parse-tree nodes. The result would look something like:
package MyPodParserTree2;
...
sub begin_pod {
my $self = shift;
$self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree
}
sub parse_tree {
## convenience method to get/set the parse-tree for the entire POD
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
}
sub command {
my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
$parser->parse_tree()->append( $pod_para );
}
sub verbatim {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
$parser->parse_tree()->append( $pod_para );
}
sub textblock {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
$parser->parse_tree()->append( $pod_para );
}
...
package main;
...
my $parser = new MyPodParserTree2(...);
$parser->parse_from_file(...);
my $ptree = $parser->parse_tree;
...
Now you have the entire POD document as one great big parse-tree. You
can even use the B<-expand_seq> option to B<parse_text> to insert
whole different kinds of objects. Just don't expect B<Pod::Parser>
to know what to do with them after that. That will need to be in your
code. Or, alternatively, you can insert any object you like so long as
it conforms to the B<Pod::ParseTree> interface.
One could use this to create subclasses of B<Pod::Paragraphs> and
B<Pod::InteriorSequences> for specific commands (or to create your own
custom node-types in the parse-tree) and add some kind of B<emit()>
method to each custom node/subclass object in the tree. Then all you'd
need to do is recursively walk the tree in the desired order, processing
the children (most likely from left to right) by formatting them if
they are text-strings, or by calling their B<emit()> method if they
are objects/references.
=head1 CAVEATS
Please note that POD has the notion of "paragraphs": this is something
starting I<after> a blank (read: empty) line, with the single exception
of the file start, which is also starting a paragraph. That means that
especially a command (e.g. C<=head1>) I<must> be preceded with a blank
line; C<__END__> is I<not> a blank line.
=head1 SEE ALSO
L<Pod::InputObjects>, L<Pod::Select>
B<Pod::InputObjects> defines POD input objects corresponding to
command paragraphs, parse-trees, and interior-sequences.
B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability
to selectively include and/or exclude sections of a POD document from being
translated based upon the current heading, subheading, subsubheading, etc.
=for __PRIVATE__
B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users
the ability the employ I<callback functions> instead of, or in addition
to, overriding methods of the base class.
=for __PRIVATE__
B<Pod::Select> and B<Pod::Callbacks> do not override any
methods nor do they define any new methods with the same name. Because
of this, they may I<both> be used (in combination) as a base class of
the same subclass in order to combine their functionality without
causing any namespace clashes due to multiple inheritance.
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<Pod::Text> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
=head1 LICENSE
Pod-Parser is free software; you can redistribute it and/or modify it
under the terms of the Artistic License distributed with Perl version
5.000 or (at your option) any later version. Please refer to the
Artistic License that came with your Perl distribution for more
details. If your version of Perl was not distributed under the
terms of the Artistic License, than you may distribute PodParser
under the same terms as Perl itself.
=cut
1;
# vim: ts=4 sw=4 et
PK Ю[��,j�~ �~
Checker.pmnu �[��� #############################################################################
# Pod/Checker.pm -- check pod documents for syntax errors
#
# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
# This is free software; you can redistribute it and/or modify it under the
# same terms as Perl itself.
#############################################################################
package Pod::Checker;
use strict;
use warnings;
our $VERSION = '1.73'; ## Current version of this package
=head1 NAME
Pod::Checker - check pod documents for syntax errors
=head1 SYNOPSIS
use Pod::Checker;
$syntax_okay = podchecker($filepath, $outputpath, %options);
my $checker = Pod::Checker->new(%options);
$checker->parse_from_file($filepath, \*STDERR);
=head1 OPTIONS/ARGUMENTS
C<$filepath> is the input POD to read and C<$outputpath> is
where to write POD syntax error messages. Either argument may be a scalar
indicating a file-path, or else a reference to an open filehandle.
If unspecified, the input-file it defaults to C<\*STDIN>, and
the output-file defaults to C<\*STDERR>.
=head2 podchecker()
This function can take a hash of options:
=over 4
=item B<-warnings> =E<gt> I<val>
Turn warnings on/off. I<val> is usually 1 for on, but higher values
trigger additional warnings. See L<"Warnings">.
=item B<-quiet> =E<gt> I<val>
If C<val> is true, do not print any errors/warnings.
=back
=head1 DESCRIPTION
B<podchecker> will perform syntax checking of Perl5 POD format documentation.
Curious/ambitious users are welcome to propose additional features they wish
to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
consistent with L<perlpod>.
The following checks are currently performed:
=over 4
=item *
Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
and unterminated interior sequences.
=item *
Check for proper balancing of C<=begin> and C<=end>. The contents of such
a block are generally ignored, i.e. no syntax checks are performed.
=item *
Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
=item *
Check for same nested interior-sequences (e.g.
C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
=item *
Check for malformed or non-existing entities C<EE<lt>...E<gt>>.
=item *
Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
for details.
=item *
Check for unresolved document-internal links. This check may also reveal
misspelled links that seem to be internal links but should be links
to something else.
=back
=head1 DIAGNOSTICS
=head2 Errors
=over 4
=item * empty =headn
A heading (C<=head1> or C<=head2>) without any text? That ain't no
heading!
=item * =over on line I<N> without closing =back
=item * You forgot a '=back' before '=headI<N>'
=item * =over is the last thing in the document?!
The C<=over> command does not have a corresponding C<=back> before the
next heading (C<=head1> or C<=head2>) or the end of the file.
=item * '=item' outside of any '=over'
=item * =back without =over
An C<=item> or C<=back> command has been found outside a
C<=over>/C<=back> block.
=item * Can't have a 0 in =over I<N>
You need to indent a strictly positive number of spaces, not 0.
=item * =over should be: '=over' or '=over positive_number'
Either have an argumentless =over, or have its argument a strictly positive number.
=item * =begin I<TARGET> without matching =end I<TARGET>
A C<=begin> command was found that has no matching =end command.
=item * =begin without a target?
A C<=begin> command was found that is not followed by the formatter
specification.
=item * =end I<TARGET> without matching =begin.
A standalone C<=end> command was found.
=item * '=end' without a target?
'=end' directives need to have a target, just like =begin directives.
=item * '=end I<TARGET>' is invalid.
I<TARGET> needs to be one word
=item * =end I<CONTENT> doesn't match =begin I<TARGET>
I<CONTENT> needs to match =begin's I<TARGET>.
=item * =for without a target?
There is no specification of the formatter after the C<=for> command.
=item * unresolved internal link I<NAME>
The given link to I<NAME> does not have a matching node in the current
POD. This also happened when a single word node name is not enclosed in
C<"">.
=item * Unknown directive: I<CMD>
An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
C<=for>, C<=pod>, C<=cut>
=item * Deleting unknown formatting code I<SEQ>
An invalid markup command has been encountered. Valid are:
C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
C<ZE<lt>E<gt>>
=item * Unterminated I<SEQ>E<lt>E<gt> sequence
An unclosed formatting code
=item * An EE<lt>...E<gt> surrounding strange content
The I<STRING> found cannot be interpreted as a character entity.
=item * An empty EE<lt>E<gt>
=item * An empty C<< LE<lt>E<gt> >>
=item * An empty XE<lt>E<gt>
There needs to be content inside E, L, and X formatting codes.
=item * A non-empty ZE<lt>E<gt>
The C<ZE<lt>E<gt>> sequence is supposed to be empty.
=item * Spurious text after =pod / =cut
The commands C<=pod> and C<=cut> do not take any arguments.
=item * =back doesn't take any parameters, but you said =back I<ARGUMENT>
The C<=back> command does not take any arguments.
=item * =pod directives shouldn't be over one line long! Ignoring all I<N> lines of content
Self explanatory
=item * =cut found outside a pod block.
A '=cut' directive found in the middle of non-POD
=item * Invalid =encoding syntax: I<CONTENT>
Syntax error in =encoding directive
=back
=head2 Warnings
These may not necessarily cause trouble, but indicate mediocre style.
=over 4
=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
Two nested identical markup commands have been found. Generally this
does not make sense.
=item * multiple occurrences (I<N>) of link target I<name>
The POD file has some C<=item> and/or C<=head> commands that have
the same text. Potential hyperlinks to such a text cannot be unique then.
This warning is printed only with warning level greater than one.
=item * line containing nothing but whitespace in paragraph
There is some whitespace on a seemingly empty line. POD is very sensitive
to such things, so this is flagged. B<vi> users switch on the B<list>
option to avoid this problem.
=item * =item has no contents
There is a list C<=item> that has no text contents. You probably want to delete
empty items.
=item * You can't have =items (as at line I<N>) unless the first thing after the =over is an =item
A list introduced by C<=over> starts with a text or verbatim paragraph,
but continues with C<=item>s. Move the non-item paragraph out of the
C<=over>/C<=back> block.
=item * Expected '=item I<EXPECTED VALUE>'
=item * Expected '=item *'
=item * Possible =item type mismatch: 'I<x>' found leading a supposed definition =item
A list started with e.g. a bullet-like C<=item> and continued with a
numbered one. This is obviously inconsistent. For most translators the
type of the I<first> C<=item> determines the type of the list.
=item * You have '=item x' instead of the expected '=item I<N>'
Erroneous numbering of =item numbers; they need to ascend consecutively.
=item * Unknown E content in EE<lt>I<CONTENT>E<gt>
A character entity was found that does not belong to the standard
ISO set or the POD specials C<verbar> and C<sol>. I<Currently, this warning
only appears if a character entity was found that does not have a Unicode
character. This should be fixed to adhere to the original warning.>
=item * empty =over/=back block
The list opened with C<=over> does not contain anything.
=item * empty section in previous paragraph
The previous section (introduced by a C<=head> command) does not contain
any valid content. This usually indicates that something is missing. Note: A
C<=head1> followed immediately by C<=head2> does not trigger this warning.
=item * Verbatim paragraph in NAME section
The NAME section (C<=head1 NAME>) should consist of a single paragraph
with the script/module name, followed by a dash `-' and a very short
description of what the thing is good for.
=item * =headI<n> without preceding higher level
For example if there is a C<=head2> in the POD file prior to a
C<=head1>.
=back
=head2 Hyperlinks
There are some warnings with respect to malformed hyperlinks:
=over 4
=item * ignoring leading/trailing whitespace in link
There is whitespace at the beginning or the end of the contents of
LE<lt>...E<gt>.
=item * alternative text/node '%s' contains non-escaped | or /
The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
Although the hyperlink parser does its best to determine which "/" is
text and which is a delimiter in case of doubt, one ought to escape
these literal characters like this:
/ E<sol>
| E<verbar>
=back
Note that the line number of the error/warning may refer to the line number of
the start of the paragraph in which the error/warning exists, not the line
number that the error/warning is on. This bug is present in errors/warnings
related to formatting codes. I<This should be fixed.>
=head1 RETURN VALUE
B<podchecker> returns the number of POD syntax errors found or -1 if
there were no POD commands at all found in the file.
=head1 EXAMPLES
See L</SYNOPSIS>
=head1 SCRIPTS
The B<podchecker> script that comes with this distribution is a lean wrapper
around this module. See the online manual with
podchecker -help
podchecker -man
=head1 INTERFACE
While checking, this module collects document properties, e.g. the nodes
for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
POD translators can use this feature to syntax-check and get the nodes in
a first pass before actually starting to convert. This is expensive in terms
of execution time, but allows for very robust conversions.
Since v1.24 the B<Pod::Checker> module uses only the B<poderror>
method to print errors and warnings. The summary output (e.g.
"Pod syntax OK") has been dropped from the module and has been included in
B<podchecker> (the script). This allows users of B<Pod::Checker> to
control completely the output behavior. Users of B<podchecker> (the script)
get the well-known behavior.
v1.45 inherits from Pod::Simple as opposed to all previous versions
inheriting from Pod::Parser. Do B<not> use Pod::Simple's interface when
using Pod::Checker unless it is documented somewhere on this page. I
repeat, DO B<NOT> USE POD::SIMPLE'S INTERFACE.
=cut
#############################################################################
#use diagnostics;
use Carp qw(croak);
use Exporter 'import';
use base qw/Pod::Simple::Methody/;
our @EXPORT = qw(&podchecker);
##---------------------------------
## Function definitions begin here
##---------------------------------
sub podchecker {
my ($infile, $outfile, %options) = @_;
local $_;
## Set defaults
$infile ||= \*STDIN;
$outfile ||= \*STDERR;
## Now create a pod checker
my $checker = Pod::Checker->new(%options);
## Now check the pod document for errors
$checker->parse_from_file($infile, $outfile);
## Return the number of errors found
return $checker->num_errors();
}
##---------------------------------------------------------------------------
##-------------------------------
## Method definitions begin here
##-------------------------------
##################################
=over 4
=item C<Pod::Checker-E<gt>new( %options )>
Return a reference to a new Pod::Checker object that inherits from
Pod::Simple and is used for calling the required methods later. The
following options are recognized:
C<-warnings =E<gt> num>
Print warnings if C<num> is true. The higher the value of C<num>,
the more warnings are printed. Currently there are only levels 1 and 2.
C<-quiet =E<gt> num>
If C<num> is true, do not print any errors/warnings. This is useful
when Pod::Checker is used to munge POD code into plain text from within
POD formatters.
=cut
sub new {
my $new = shift->SUPER::new(@_);
$new->{'output_fh'} ||= *STDERR{IO};
# Set options
my %opts = @_;
$new->{'-warnings'} = defined $opts{'-warnings'} ?
$opts{'-warnings'} : 1; # default on
$new->{'-quiet'} = $opts{'-quiet'} || 0; # default off
# Initialize number of errors/warnings
$new->{'_NUM_ERRORS'} = 0;
$new->{'_NUM_WARNINGS'} = 0;
# 'current' also means 'most recent' in the follow comments
$new->{'_thispara'} = ''; # current POD paragraph
$new->{'_line'} = 0; # current line number
$new->{'_head_num'} = 0; # current =head level (set to 0 to make
# logic easier down the road)
$new->{'_cmds_since_head'} = 0; # num of POD directives since prev. =headN
$new->{'_nodes'} = []; # stack for =head/=item nodes
$new->{'_fcode_stack'} = []; # stack for nested formatting codes
$new->{'_fcode_pos'} = []; # stack for position in paragraph of fcodes
$new->{'_begin_stack'} = []; # stack for =begins: [line #, target]
$new->{'_links'} = []; # stack for hyperlinks to external entities
$new->{'_internal_links'} = []; # set of linked-to internal sections
$new->{'_index'} = []; # stack for text in X<>s
$new->accept_targets('*'); # check all =begin/=for blocks
$new->cut_handler( \&handle_pod_and_cut ); # warn if text after =cut
$new->pod_handler( \&handle_pod_and_cut ); # warn if text after =pod
$new->whiteline_handler( \&handle_whiteline ); # warn if whiteline
$new->parse_empty_lists(1); # warn if they are empty
return $new;
}
##################################
=item C<$checker-E<gt>poderror( @args )>
=item C<$checker-E<gt>poderror( {%opts}, @args )>
Internal method for printing errors and warnings. If no options are given,
simply prints "@_". The following options are recognized and used to form
the output:
-msg
A message to print prior to C<@args>.
-line
The line number the error occurred in.
-file
The file (name) the error occurred in. Defaults to the name of the current
file being processed.
-severity
The error level, should be 'WARNING' or 'ERROR'.
=cut
# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
sub poderror {
my $self = shift;
my %opts = (ref $_[0]) ? %{shift()} : ();
## Retrieve options
chomp( my $msg = ($opts{'-msg'} || '')."@_" );
my $line = (exists $opts{'-line'}) ? " at line $opts{'-line'}" : '';
my $file = ' in file ' . ((exists $opts{'-file'})
? $opts{'-file'}
: ((defined $self->source_filename)
? $self->source_filename
: "???"));
unless (exists $opts{'-severity'}) {
## See if can find severity in message prefix
$opts{'-severity'} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
}
my $severity = (exists $opts{'-severity'}) ? "*** $opts{-severity}: " : '';
## Increment error count and print message "
++($self->{'_NUM_ERRORS'})
if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'ERROR'));
++($self->{'_NUM_WARNINGS'})
if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'WARNING'));
unless($self->{'-quiet'}) {
my $out_fh = $self->{'output_fh'} || \*STDERR;
print $out_fh ($severity, $msg, $line, $file, "\n")
if($self->{'-warnings'} || !%opts || $opts{'-severity'} ne 'WARNING');
}
}
##################################
=item C<$checker-E<gt>num_errors()>
Set (if argument specified) and retrieve the number of errors found.
=cut
sub num_errors {
return (@_ > 1) ? ($_[0]->{'_NUM_ERRORS'} = $_[1]) : $_[0]->{'_NUM_ERRORS'};
}
##################################
=item C<$checker-E<gt>num_warnings()>
Set (if argument specified) and retrieve the number of warnings found.
=cut
sub num_warnings {
return (@_ > 1) ? ($_[0]->{'_NUM_WARNINGS'} = $_[1]) :
$_[0]->{'_NUM_WARNINGS'};
}
##################################
=item C<$checker-E<gt>name()>
Set (if argument specified) and retrieve the canonical name of POD as
found in the C<=head1 NAME> section.
=cut
sub name {
return (@_ > 1 && $_[1]) ?
($_[0]->{'_pod_name'} = $_[1]) : $_[0]->{'_pod_name'};
}
##################################
=item C<$checker-E<gt>node()>
Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
and C<=item>) of the current POD. The nodes are returned in the order of
their occurrence. They consist of plain text, each piece of whitespace is
collapsed to a single blank.
=cut
sub node {
my ($self,$text) = @_;
if(defined $text) {
$text =~ s/\s+$//s; # strip trailing whitespace
$text =~ s/\s+/ /gs; # collapse whitespace
# add node, order important!
push(@{$self->{'_nodes'}}, $text);
# keep also a uniqueness counter
$self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
return $text;
}
@{$self->{'_nodes'}};
}
##################################
=item C<$checker-E<gt>idx()>
Add (if argument specified) and retrieve the index entries (as defined by
C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
of whitespace is collapsed to a single blank.
=cut
# set/return index entries of current POD
sub idx {
my ($self,$text) = @_;
if(defined $text) {
$text =~ s/\s+$//s; # strip trailing whitespace
$text =~ s/\s+/ /gs; # collapse whitespace
# add node, order important!
push(@{$self->{'_index'}}, $text);
# keep also a uniqueness counter
$self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
return $text;
}
@{$self->{'_index'}};
}
##################################
# add a hyperlink to the list of those of the current POD; returns current
# list after the addition has been done
sub hyperlink {
my $self = shift;
push(@{$self->{'_links'}}, $_[0]);
return $_[0];
}
=item C<$checker-E<gt>hyperlinks()>
Retrieve an array containing the hyperlinks to things outside
the current POD (as defined by C<LE<lt>E<gt>>).
Each is an instance of a class with the following methods:
=cut
sub hyperlinks {
@{shift->{'_links'}};
}
##################################
# override Pod::Simple's whine() and scream() to use poderror()
# Note:
# Ignore $self->{'no_whining'} b/c $self->{'quiet'} takes care of it in poderror
# Don't bother incrementing $self->{'errors_seen'} -- it's not used
# Don't bother pushing to $self->{'errata'} b/c poderror() outputs immediately
# We don't need to set $self->no_errata_section(1) b/c of these overrides
sub whine {
my ($self, $line, $complaint) = @_;
my $severity = 'ERROR';
if (0) {
# XXX: Let's standardize what's a warning and what's an error. Let's not
# move stuff up and down the severity tree. -- rjbs, 2013-04-12
# Convert errors in Pod::Simple that are warnings in Pod::Checker
# XXX Do differently so the $complaint can be reworded without this breaking
$severity = 'WARNING' if
$complaint =~ /^Expected '=item .+?'$/ ||
$complaint =~ /^You can't have =items \(as at line .+?\) unless the first thing after the =over is an =item$/ ||
$complaint =~ /^You have '=item .+?' instead of the expected '=item .+?'$/;
}
$self->poderror({ -line => $line,
-severity => $severity,
-msg => $complaint });
return 1; # assume everything is peachy keen
}
sub scream {
my ($self, $line, $complaint) = @_;
$self->poderror({ -line => $line,
-severity => 'ERROR', # consider making severity 'FATAL'
-msg => $complaint });
return 1;
}
##################################
# Some helper subroutines
sub _init_event { # assignments done at the start of most events
$_[0]{'_thispara'} = '';
$_[0]{'_line'} = $_[1]{'start_line'};
$_[0]{'_cmds_since_head'}++;
}
sub _check_fcode {
my ($self, $inner, $outers) = @_;
# Check for an fcode inside another of the same fcode
# XXX line number is the line of the start of the paragraph that the warning
# is in, not the line that the warning is on. Fix this
# Later versions of Pod::Simple forbid nested L<>'s
return if $inner eq 'L' && $Pod::Simple::VERSION ge '3.33';
if (grep { $_ eq $inner } @$outers) {
$self->poderror({ -line => $self->{'_line'},
-severity => 'WARNING',
-msg => "nested commands $inner<...$inner<...>...>"});
}
}
##################################
sub handle_text { $_[0]{'_thispara'} .= $_[1] }
# whiteline is a seemingly blank line that matches /[^\S\r\n]/
sub handle_whiteline {
my ($line, $line_n, $self) = @_;
$self->poderror({
-line => $line_n,
-severity => 'WARNING',
-msg => 'line containing nothing but whitespace in paragraph'});
}
######## Directives
sub handle_pod_and_cut {
my ($line, $line_n, $self) = @_;
$self->{'_cmds_since_head'}++;
if ($line =~ /=(pod|cut)\s+\S/) {
$self->poderror({ -line => $line_n,
-severity => 'ERROR',
-msg => "Spurious text after =$1"});
}
}
sub start_Para { shift->_init_event(@_); }
sub end_Para {
my $self = shift;
# Get the NAME of the pod document
if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') {
if ($self->{'_thispara'} =~ /^\s*(\S+?)\s*[,-]/) {
$self->{'_pod_name'} = $1 unless defined $self->{'_pod_name'};
}
}
}
sub start_Verbatim {
my $self = shift;
$self->_init_event(@_);
if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') {
$self->poderror({ -line => $self->{'_line'},
-severity => 'WARNING',
-msg => 'Verbatim paragraph in NAME section' });
}
}
# Don't need an end_Verbatim
# Do I need to do anything else with this?
sub start_Data { shift->_init_event() }
sub start_head1 { shift->start_head(1, @_) }
sub start_head2 { shift->start_head(2, @_) }
sub start_head3 { shift->start_head(3, @_) }
sub start_head4 { shift->start_head(4, @_) }
sub start_head {
my $self = shift;
my $h = shift;
$self->_init_event(@_);
my $prev_h = $self->{'_head_num'};
$self->{'_head_num'} = $h;
$self->{"_count_head$h"}++;
if ($h > 1 && !$self->{'_count_head'.($h-1)}) {
$self->poderror({ -line => $self->{'_line'},
-severity => 'WARNING',
-msg => "=head$h without preceding higher level"});
}
# If this is the first =head of the doc, $prev_h is 0, thus less than $h
if ($self->{'_cmds_since_head'} == 1 && $prev_h >= $h) {
$self->poderror({ -line => $self->{'_line'},
-severity => 'WARNING',
-msg => 'empty section in previous paragraph'});
}
}
sub end_head1 { shift->end_head(@_) }
sub end_head2 { shift->end_head(@_) }
sub end_head3 { shift->end_head(@_) }
sub end_head4 { shift->end_head(@_) }
sub end_head {
my $self = shift;
my $arg = $self->{'_thispara'};
$arg =~ s/\s+$//;
$self->{'_head_text'} = $arg;
$self->{'_cmds_since_head'} = 0;
my $h = $self->{'_head_num'};
$self->node($arg); # remember this node
if ($arg eq '') {
$self->poderror({ -line => $self->{'_line'},
-severity => 'ERROR',
-msg => "empty =head$h" });
}
}
sub start_over_bullet { shift->start_over(@_, 'bullet') }
sub start_over_number { shift->start_over(@_, 'number') }
sub start_over_text { shift->start_over(@_, 'definition') }
sub start_over_block { shift->start_over(@_, 'block') }
sub start_over_empty {
my $self = shift;
$self->start_over(@_, 'empty');
$self->poderror({ -line => $self->{'_line'},
-severity => 'WARNING',
-msg => 'empty =over/=back block' });
}
sub start_over {
my $self = shift;
my $type = pop;
$self->_init_event(@_);
}
sub start_item_bullet { shift->_init_event(@_) }
sub start_item_number { shift->_init_event(@_) }
sub start_item_text { shift->_init_event(@_) }
sub end_item_bullet { shift->end_item('bullet') }
sub end_item_number { shift->end_item('number') }
sub end_item_text { shift->end_item('definition') }
sub end_item {
my $self = shift;
my $type = shift;
# If there is verbatim text in this item, it will show up as part of
# 'paras', and not part of '_thispara'. If the first para after this is a
# verbatim one, it actually will be (part of) the contents for this item.
if ( $self->{'_thispara'} eq ''
&& ( ! @{$self->{'paras'}}
|| $self->{'paras'}[0][0] !~ /Verbatim/i))
{
$self->poderror({ -line => $self->{'_line'},
-severity => 'WARNING',
-msg => '=item has no contents' });
}
$self->node($self->{'_thispara'}); # remember this node
}
sub start_for { # =for and =begin directives
my ($self, $flags) = @_;
$self->_init_event($flags);
push @{$self->{'_begin_stack'}}, [$self->{'_line'}, $flags->{'target'}];
}
sub end_for {
my ($self, $flags) = @_;
my ($line, $target) = @{pop @{$self->{'_begin_stack'}}};
if ($flags->{'fake-closer'}) { # meaning Pod::Simple generated this =end
$self->poderror({ -line => $line,
-severity => 'ERROR',
-msg => "=begin $target without matching =end $target"
});
}
}
sub end_Document {
# Some final error checks
my $self = shift;
# no POD found here
$self->num_errors(-1) && return unless $self->content_seen;
my %nodes;
for ($self->node()) {
$nodes{$_} = 1;
if(/^(\S+)\s+\S/) {
# we have more than one word. Use the first as a node, too.
# This is used heavily in perlfunc.pod
$nodes{$1} ||= 2; # derived node
}
}
for ($self->idx()) {
$nodes{$_} = 3; # index node
}
# XXX update unresolved internal link POD -- single word not enclosed in ""?
# I don't know what I was thinking when I made the above TODO, and I don't
# know what it means...
for my $link (@{ $self->{'_internal_links'} }) {
my ($name, $line) = @$link;
unless ( $nodes{$name} ) {
$self->poderror({ -line => $line,
-severity => 'ERROR',
-msg => "unresolved internal link '$name'"});
}
}
# check the internal nodes for uniqueness. This pertains to
# =headX, =item and X<...>
if ($self->{'-warnings'} > 1 ) {
for my $node (sort keys %{ $self->{'_unique_nodes'} }) {
my $count = $self->{'_unique_nodes'}{$node};
if ($count > 1) { # not unique
$self->poderror({
-line => '-',
-severity => 'WARNING',
-msg => "multiple occurrences ($count) of link target ".
"'$node'"});
}
}
}
}
######## Formatting codes
sub start_B { shift->start_fcode('B') }
sub start_C { shift->start_fcode('C') }
sub start_F { shift->start_fcode('F') }
sub start_I { shift->start_fcode('I') }
sub start_S { shift->start_fcode('S') }
sub start_fcode {
my ($self, $fcode) = @_;
unshift @{$self->{'_fcode_stack'}}, $fcode;
}
sub end_B { shift->end_fcode() }
sub end_C { shift->end_fcode() }
sub end_F { shift->end_fcode() }
sub end_I { shift->end_fcode() }
sub end_S { shift->end_fcode() }
sub end_fcode {
my $self = shift;
$self->_check_fcode(shift @{$self->{'_fcode_stack'}}, # current fcode removed
$self->{'_fcode_stack'}); # previous fcodes
}
sub start_L {
my ($self, $flags) = @_;
$self->start_fcode('L');
my $link = Pod::Checker::Hyperlink->new($flags, $self);
if ($link) {
if ( $link->type eq 'pod'
&& $link->node
# It's an internal-to-this-page link if no page is given, or
# if the given one is to our NAME.
&& (! $link->page || ( $self->{'_pod_name'}
&& $link->page eq $self->{'_pod_name'})))
{
push @{ $self->{'_internal_links'} }, [ $link->{'-raw_node'}, $link->line ];
}
else {
$self->hyperlink($link);
}
}
}
sub end_L {
my $self = shift;
$self->end_fcode();
}
sub start_X {
my $self = shift;
$self->start_fcode('X');
# keep track of where X<> starts in the paragraph
# (this is a stack so nested X<>s are handled correctly)
push @{$self->{'_fcode_pos'}}, length $self->{'_thispara'};
}
sub end_X {
my $self = shift;
# extract contents of X<> and replace with ''
my $start = pop @{$self->{'_fcode_pos'}}; # start at the beginning of X<>
my $end = length($self->{'_thispara'}) - $start; # end at end of X<>
my $x = substr($self->{'_thispara'}, $start, $end, '');
if ($x eq "") {
$self->poderror({ -line => $self->{'_line'},
-severity => 'ERROR',
-msg => "An empty X<>" });
}
$self->idx($x); # remember this node
$self->end_fcode();
}
package Pod::Checker::Hyperlink;
# This class is used to represent L<> link structures, so that the individual
# elements are easily accessible. It is based on code in Pod::Hyperlink
sub new {
my ($class,
$simple_link, # The link structure returned by Pod::Simple
$caller # The caller class
) = @_;
my $self = +{};
bless $self, $class;
$self->{'-line'} ||= $caller->{'_line'};
$self->{'-type'} ||= $simple_link->{'type'};
# Force stringification of page and node. (This expands any E<>.)
$self->{'-page'} = exists $simple_link->{'to'} ? "$simple_link->{'to'}" : "";
$self->{'-node'} = exists $simple_link->{'section'} ? "$simple_link->{'section'}" : "";
# Save the unmodified node text, as the .t files are expecting the message
# for internal link failures to include it (hence this preserves backward
# compatibility).
$self->{'-raw_node'} = $self->{'-node'};
# Remove leading/trailing white space. Pod::Simple already warns about
# these, so if the only error is this, and the link is otherwise correct,
# only the Pod::Simple warning will be output, avoiding unnecessary
# confusion.
$self->{'-page'} =~ s/ ^ \s+ //x;
$self->{'-page'} =~ s/ \s+ $ //x;
$self->{'-node'} =~ s/ ^ \s+ //x;
$self->{'-node'} =~ s/ \s+ $ //x;
# Pod::Simple warns about L<> and L< >, but not L</>
if ($self->{'-page'} eq "" && $self->{'-node'} eq "") {
$caller->poderror({ -line => $caller->{'_line'},
-severity => 'WARNING',
-msg => 'empty link'});
return;
}
return $self;
}
=item line()
Returns the approximate line number in which the link was encountered
=cut
sub line {
return $_[0]->{-line};
}
=item type()
Returns the type of the link; one of:
C<"url"> for things like
C<http://www.foo>, C<"man"> for man pages, or C<"pod">.
=cut
sub type {
return $_[0]->{-type};
}
=item page()
Returns the linked-to page or url.
=cut
sub page {
return $_[0]->{-page};
}
=item node()
Returns the anchor or node within the linked-to page, or an empty string
(C<"">) if none appears in the link.
=back
=cut
sub node {
return $_[0]->{-node};
}
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),
Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
Marc Green E<lt>marcgreen@cpan.orgE<gt> (port to Pod::Simple)
Ricardo Signes E<lt>rjbs@cpan.orgE<gt> (more porting to Pod::Simple)
Karl Williamson E<lt>khw@cpan.orgE<gt> (more porting to Pod::Simple)
Based on code for B<Pod::Text::pod2text()> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
=cut
1
PK Ю[ ����7 �7 Man.pmnu �[��� # 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.006;
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.
our $HAS_ENCODE;
BEGIN {
$HAS_ENCODE = eval { require Encode };
}
@ISA = qw(Pod::Simple);
$VERSION = '4.11';
# 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) = @_;
# We used to try first to get the version number from a local binary, but
# we shouldn't need that any more. Get the version from the running Perl.
# Work a little magic to handle subversions correctly under both the
# pre-5.6 and the post-5.6 version numbering schemes.
my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
$version[2] ||= 0;
$version[2] *= 10 ** (3 - length $version[2]);
for (@version) { $_ += 0 }
my $version = join ('.', @version);
# Set the defaults for page titles and indentation if the user didn't
# override anything.
$$self{center} = 'User Contributed Perl Documentation'
unless defined $$self{center};
$$self{release} = 'perl v' . $version
unless defined $$self{release};
$$self{indent} = 4
unless defined $$self{indent};
# Double quotes in things that will be quoted.
for (qw/center release/) {
$$self{$_} =~ s/\"/\"\"/g if $$self{$_};
}
}
##############################################################################
# Core parsing
##############################################################################
# This is the glue that connects the code below with Pod::Simple itself. The
# goal is to convert the event stream coming from the POD parser into method
# calls to handlers once the complete content of a tag has been seen. Each
# paragraph or POD command will have textual content associated with it, and
# as soon as all of a paragraph or POD command has been seen, that content
# will be passed in to the corresponding method for handling that type of
# object. The exceptions are handlers for lists, which have opening tag
# handlers and closing tag handlers that will be called right away.
#
# The internal hash key PENDING is used to store the contents of a tag until
# all of it has been seen. It holds a stack of open tags, each one
# represented by a tuple of the attributes hash for the tag, formatting
# options for the tag (which are inherited), and the contents of the tag.
# Add a block of text to the contents of the current node, formatting it
# according to the current formatting instructions as we do.
sub _handle_text {
my ($self, $text) = @_;
DEBUG > 3 and print "== $text\n";
my $tag = $$self{PENDING}[-1];
$$tag[2] .= $self->format_text ($$tag[1], $text);
}
# Given an element name, get the corresponding method name.
sub method_for_element {
my ($self, $element) = @_;
$element =~ tr/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] & 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(.wu*8/10-\*(#H)'\'\h"|\\n:u"
. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
.\}
. \" troff and (daisy-wheel) nroff accents
.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
.ds ae a\h'-(\w'a'u*4/10)'e
.ds Ae A\h'-(\w'A'u*4/10)'E
. \" corrections for vroff
.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
. \" for low resolution devices (crt and lpr)
.if \n(.H>23 .if \n(.V>19 \
\{\
. ds : e
. ds 8 ss
. ds o a
. ds d- d\h'-1'\(ga
. ds D- D\h'-1'\(hy
. ds th \o'bp'
. ds Th \o'LP'
. ds ae ae
. ds Ae AE
.\}
.rm #[ #] #H #V #F C
----END OF PREAMBLE----
#`# for cperl-mode
}
return $preamble;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=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.
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-2018 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:
PK Ю[:���c �c PlainText.pmnu �[��� # Pod::PlainText -- Convert POD data to formatted ASCII text.
# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $
#
# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu>
#
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This module is intended to be a replacement for Pod::Text, and attempts to
# match its output except for some specific circumstances where other
# decisions seemed to produce better output. It uses Pod::Parser and is
# designed to be very easy to subclass.
############################################################################
# Modules and declarations
############################################################################
package Pod::PlainText;
use strict;
require 5.005;
use Carp qw(carp croak);
use Pod::Select ();
use vars qw(@ISA %ESCAPES $VERSION);
# We inherit from Pod::Select instead of Pod::Parser so that we can be used
# by Pod::Usage.
@ISA = qw(Pod::Select);
$VERSION = '2.07';
BEGIN {
if ($] < 5.006) {
require Symbol;
import Symbol;
}
}
############################################################################
# Table of supported E<> escapes
############################################################################
# This table is taken near verbatim from Pod::PlainText in Pod::Parser,
# which got it near verbatim from the original Pod::Text. It is therefore
# credited to Tom Christiansen, and I'm glad I didn't have to write it. :)
%ESCAPES = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "\xC1", # capital A, acute accent
"aacute" => "\xE1", # small a, acute accent
"Acirc" => "\xC2", # capital A, circumflex accent
"acirc" => "\xE2", # small a, circumflex accent
"AElig" => "\xC6", # capital AE diphthong (ligature)
"aelig" => "\xE6", # small ae diphthong (ligature)
"Agrave" => "\xC0", # capital A, grave accent
"agrave" => "\xE0", # small a, grave accent
"Aring" => "\xC5", # capital A, ring
"aring" => "\xE5", # small a, ring
"Atilde" => "\xC3", # capital A, tilde
"atilde" => "\xE3", # small a, tilde
"Auml" => "\xC4", # capital A, dieresis or umlaut mark
"auml" => "\xE4", # small a, dieresis or umlaut mark
"Ccedil" => "\xC7", # capital C, cedilla
"ccedil" => "\xE7", # small c, cedilla
"Eacute" => "\xC9", # capital E, acute accent
"eacute" => "\xE9", # small e, acute accent
"Ecirc" => "\xCA", # capital E, circumflex accent
"ecirc" => "\xEA", # small e, circumflex accent
"Egrave" => "\xC8", # capital E, grave accent
"egrave" => "\xE8", # small e, grave accent
"ETH" => "\xD0", # capital Eth, Icelandic
"eth" => "\xF0", # small eth, Icelandic
"Euml" => "\xCB", # capital E, dieresis or umlaut mark
"euml" => "\xEB", # small e, dieresis or umlaut mark
"Iacute" => "\xCD", # capital I, acute accent
"iacute" => "\xED", # small i, acute accent
"Icirc" => "\xCE", # capital I, circumflex accent
"icirc" => "\xEE", # small i, circumflex accent
"Igrave" => "\xCD", # capital I, grave accent
"igrave" => "\xED", # small i, grave accent
"Iuml" => "\xCF", # capital I, dieresis or umlaut mark
"iuml" => "\xEF", # small i, dieresis or umlaut mark
"Ntilde" => "\xD1", # capital N, tilde
"ntilde" => "\xF1", # small n, tilde
"Oacute" => "\xD3", # capital O, acute accent
"oacute" => "\xF3", # small o, acute accent
"Ocirc" => "\xD4", # capital O, circumflex accent
"ocirc" => "\xF4", # small o, circumflex accent
"Ograve" => "\xD2", # capital O, grave accent
"ograve" => "\xF2", # small o, grave accent
"Oslash" => "\xD8", # capital O, slash
"oslash" => "\xF8", # small o, slash
"Otilde" => "\xD5", # capital O, tilde
"otilde" => "\xF5", # small o, tilde
"Ouml" => "\xD6", # capital O, dieresis or umlaut mark
"ouml" => "\xF6", # small o, dieresis or umlaut mark
"szlig" => "\xDF", # small sharp s, German (sz ligature)
"THORN" => "\xDE", # capital THORN, Icelandic
"thorn" => "\xFE", # small thorn, Icelandic
"Uacute" => "\xDA", # capital U, acute accent
"uacute" => "\xFA", # small u, acute accent
"Ucirc" => "\xDB", # capital U, circumflex accent
"ucirc" => "\xFB", # small u, circumflex accent
"Ugrave" => "\xD9", # capital U, grave accent
"ugrave" => "\xF9", # small u, grave accent
"Uuml" => "\xDC", # capital U, dieresis or umlaut mark
"uuml" => "\xFC", # small u, dieresis or umlaut mark
"Yacute" => "\xDD", # capital Y, acute accent
"yacute" => "\xFD", # small y, acute accent
"yuml" => "\xFF", # small y, dieresis or umlaut mark
"lchevron" => "\xAB", # left chevron (double less than)
"rchevron" => "\xBB", # right chevron (double greater than)
);
############################################################################
# Initialization
############################################################################
# Initialize the object. Must be sure to call our parent initializer.
sub initialize {
my $self = shift;
$$self{alt} = 0 unless defined $$self{alt};
$$self{indent} = 4 unless defined $$self{indent};
$$self{loose} = 0 unless defined $$self{loose};
$$self{sentence} = 0 unless defined $$self{sentence};
$$self{width} = 76 unless defined $$self{width};
$$self{INDENTS} = []; # Stack of indentations.
$$self{MARGIN} = $$self{indent}; # Current left margin in spaces.
return $self->SUPER::initialize;
}
############################################################################
# Core overrides
############################################################################
# Called for each command paragraph. Gets the command, the associated
# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
# the command to a method named the same as the command. =cut is handled
# internally by Pod::Parser.
sub command {
my $self = shift;
my $command = shift;
return if $command eq 'pod';
return if ($$self{EXCLUDE} && $command ne 'end');
if (defined $$self{ITEM}) {
$self->item ("\n");
local $_ = "\n";
$self->output($_) if($command eq 'back');
}
$command = 'cmd_' . $command;
return $self->$command (@_);
}
# Called for a verbatim paragraph. Gets the paragraph, the line number, and
# a Pod::Paragraph object. Just output it verbatim, but with tabs converted
# to spaces.
sub verbatim {
my $self = shift;
return if $$self{EXCLUDE};
$self->item if defined $$self{ITEM};
local $_ = shift;
return if /^\s*$/;
s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme;
return $self->output($_);
}
# Called for a regular text block. Gets the paragraph, the line number, and
# a Pod::Paragraph object. Perform interpolation and output the results.
sub textblock {
my $self = shift;
return if $$self{EXCLUDE};
if($$self{VERBATIM}) {
$self->output($_[0]);
return;
}
local $_ = shift;
my $line = shift;
# Perform a little magic to collapse multiple L<> references. This is
# here mostly for backwards-compatibility. We'll just rewrite the whole
# thing into actual text at this part, bypassing the whole internal
# sequence parsing thing.
s{
(
L< # A link of the form L</something>.
/
(
[:\w]+ # The item has to be a simple word...
(\(\))? # ...or simple function.
)
>
(
,?\s+(and\s+)? # Allow lots of them, conjuncted.
L<
/
(
[:\w]+
(\(\))?
)
>
)+
)
} {
local $_ = $1;
s%L</([^>]+)>%$1%g;
my @items = split /(?:,?\s+(?:and\s+)?)/;
my $string = "the ";
my $i;
for ($i = 0; $i < @items; $i++) {
$string .= $items[$i];
$string .= ", " if @items > 2 && $i != $#items;
$string .= " and " if ($i == $#items - 1);
}
$string .= " entries elsewhere in this document";
$string;
}gex;
# Now actually interpolate and output the paragraph.
$_ = $self->interpolate ($_, $line);
s/\s*$/\n/s;
if (defined $$self{ITEM}) {
$self->item ($_ . "\n");
} else {
$self->output ($self->reformat ($_ . "\n"));
}
}
# Called for an interior sequence. Gets the command, argument, and a
# Pod::InteriorSequence object and is expected to return the resulting text.
# Calls code, bold, italic, file, and link to handle those types of
# sequences, and handles S<>, E<>, X<>, and Z<> directly.
sub interior_sequence {
my $self = shift;
my $command = shift;
local $_ = shift;
return '' if ($command eq 'X' || $command eq 'Z');
# Expand escapes into the actual character now, carping if invalid.
if ($command eq 'E') {
return $ESCAPES{$_} if defined $ESCAPES{$_};
carp "Unknown escape: E<$_>";
return "E<$_>";
}
# For all the other sequences, empty content produces no output.
return if $_ eq '';
# For S<>, compress all internal whitespace and then map spaces to \01.
# When we output the text, we'll map this back.
if ($command eq 'S') {
s/\s{2,}/ /g;
tr/ /\01/;
return $_;
}
# Anything else needs to get dispatched to another method.
if ($command eq 'B') { return $self->seq_b ($_) }
elsif ($command eq 'C') { return $self->seq_c ($_) }
elsif ($command eq 'F') { return $self->seq_f ($_) }
elsif ($command eq 'I') { return $self->seq_i ($_) }
elsif ($command eq 'L') { return $self->seq_l ($_) }
else { carp "Unknown sequence $command<$_>" }
}
# Called for each paragraph that's actually part of the POD. We take
# advantage of this opportunity to untabify the input.
sub preprocess_paragraph {
my $self = shift;
local $_ = shift;
1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
return $_;
}
############################################################################
# Command paragraphs
############################################################################
# All command paragraphs take the paragraph and the line number.
# First level heading.
sub cmd_head1 {
my $self = shift;
local $_ = shift;
s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n==== $_ ====\n\n");
} else {
$_ .= "\n" if $$self{loose};
$self->output ($_ . "\n");
}
}
# Second level heading.
sub cmd_head2 {
my $self = shift;
local $_ = shift;
s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n== $_ ==\n\n");
} else {
$_ .= "\n" if $$self{loose};
$self->output (' ' x ($$self{indent} / 2) . $_ . "\n");
}
}
# third level heading - not strictly perlpodspec compliant
sub cmd_head3 {
my $self = shift;
local $_ = shift;
s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n= $_ =\n");
} else {
$_ .= "\n" if $$self{loose};
$self->output (' ' x ($$self{indent}) . $_ . "\n");
}
}
# fourth level heading - not strictly perlpodspec compliant
# just like head3
*cmd_head4 = \&cmd_head3;
# Start a list.
sub cmd_over {
my $self = shift;
local $_ = shift;
unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
push (@{ $$self{INDENTS} }, $$self{MARGIN});
$$self{MARGIN} += ($_ + 0);
}
# End a list.
sub cmd_back {
my $self = shift;
$$self{MARGIN} = pop @{ $$self{INDENTS} };
unless (defined $$self{MARGIN}) {
carp 'Unmatched =back';
$$self{MARGIN} = $$self{indent};
}
}
# An individual list item.
sub cmd_item {
my $self = shift;
if (defined $$self{ITEM}) { $self->item }
local $_ = shift;
s/\s+$//s;
$$self{ITEM} = $self->interpolate ($_);
}
# Begin a block for a particular translator. Setting VERBATIM triggers
# special handling in textblock().
sub cmd_begin {
my $self = shift;
local $_ = shift;
my ($kind) = /^(\S+)/ or return;
if ($kind eq 'text') {
$$self{VERBATIM} = 1;
} else {
$$self{EXCLUDE} = 1;
}
}
# End a block for a particular translator. We assume that all =begin/=end
# pairs are properly closed.
sub cmd_end {
my $self = shift;
$$self{EXCLUDE} = 0;
$$self{VERBATIM} = 0;
}
# One paragraph for a particular translator. Ignore it unless it's intended
# for text, in which case we treat it as a verbatim text block.
sub cmd_for {
my $self = shift;
local $_ = shift;
my $line = shift;
return unless s/^text\b[ \t]*\r?\n?//;
$self->verbatim ($_, $line);
}
# just a dummy method for the time being
sub cmd_encoding {
return;
}
############################################################################
# Interior sequences
############################################################################
# The simple formatting ones. These are here mostly so that subclasses can
# override them and do more complicated things.
sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" }
sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
sub seq_i { return '*' . $_[1] . '*' }
# The complicated one. Handle links. Since this is plain text, we can't
# actually make any real links, so this is all to figure out what text we
# print out.
sub seq_l {
my $self = shift;
local $_ = shift;
# Smash whitespace in case we were split across multiple lines.
s/\s+/ /g;
# If we were given any explicit text, just output it.
if (/^([^|]+)\|/) { return $1 }
# Okay, leading and trailing whitespace isn't important; get rid of it.
s/^\s+//;
s/\s+$//;
# Default to using the whole content of the link entry as a section
# name. Note that L<manpage/> forces a manpage interpretation, as does
# something looking like L<manpage(section)>. The latter is an
# enhancement over the original Pod::Text.
my ($manpage, $section) = ('', $_);
if (/^(?:https?|ftp|news):/) {
# a URL
return $_;
} elsif (/^"\s*(.*?)\s*"$/) {
$section = '"' . $1 . '"';
} elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {
($manpage, $section) = ($_, '');
} elsif (m{/}) {
($manpage, $section) = split (/\s*\/\s*/, $_, 2);
}
my $text = '';
# Now build the actual output text.
if (!length $section) {
$text = "the $manpage manpage" if length $manpage;
} elsif ($section =~ /^[:\w]+(?:\(\))?/) {
$text .= 'the ' . $section . ' entry';
$text .= (length $manpage) ? " in the $manpage manpage"
: ' elsewhere in this document';
} else {
$section =~ s/^\"\s*//;
$section =~ s/\s*\"$//;
$text .= 'the section on "' . $section . '"';
$text .= " in the $manpage manpage" if length $manpage;
}
return $text;
}
############################################################################
# List handling
############################################################################
# This method is called whenever an =item command is complete (in other
# words, we've seen its associated paragraph or know for certain that it
# doesn't have one). It gets the paragraph associated with the item as an
# argument. If that argument is empty, just output the item tag; if it
# contains a newline, output the item tag followed by the newline.
# Otherwise, see if there's enough room for us to output the item tag in the
# margin of the text or if we have to put it on a separate line.
sub item {
my $self = shift;
local $_ = shift;
my $tag = $$self{ITEM};
unless (defined $tag) {
carp 'item called without tag';
return;
}
undef $$self{ITEM};
my $indent = $$self{INDENTS}[-1];
unless (defined $indent) { $indent = $$self{indent} }
my $space = ' ' x $indent;
$space =~ s/^ /:/ if $$self{alt};
if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {
my $margin = $$self{MARGIN};
$$self{MARGIN} = $indent;
my $output = $self->reformat ($tag);
$output =~ s/[\r\n]*$/\n/;
$self->output ($output);
$$self{MARGIN} = $margin;
$self->output ($self->reformat ($_)) if /\S/;
} else {
$_ = $self->reformat ($_);
s/^ /:/ if ($$self{alt} && $indent > 0);
my $tagspace = ' ' x length $tag;
s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item';
$self->output ($_);
}
}
############################################################################
# Output formatting
############################################################################
# Wrap a line, indenting by the current left margin. We can't use
# Text::Wrap because it plays games with tabs. We can't use formline, even
# though we'd really like to, because it screws up non-printing characters.
# So we have to do the wrapping ourselves.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{width} - $$self{MARGIN};
while (length > $width) {
if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
# Reformat a paragraph of text for the current margin. Takes the text to
# reformat and returns the formatted text.
sub reformat {
my $self = shift;
local $_ = shift;
# If we're trying to preserve two spaces after sentences, do some
# munging to support that. Otherwise, smash all repeated whitespace.
if ($$self{sentence}) {
s/ +$//mg;
s/\.\r?\n/. \n/g;
s/[\r\n]+/ /g;
s/ +/ /g;
} else {
s/\s+/ /g;
}
return $self->wrap($_);
}
# Output text to the output device.
sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
############################################################################
# Backwards compatibility
############################################################################
# The old Pod::Text module did everything in a pod2text() function. This
# tries to provide the same interface for legacy applications.
sub pod2text {
my @args;
# This is really ugly; I hate doing option parsing in the middle of a
# module. But the old Pod::Text module supported passing flags to its
# entry function, so handle -a and -<number>.
while ($_[0] =~ /^-/) {
my $flag = shift;
if ($flag eq '-a') { push (@args, alt => 1) }
elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
else {
unshift (@_, $flag);
last;
}
}
# Now that we know what arguments we're using, create the parser.
my $parser = Pod::PlainText->new (@args);
# If two arguments were given, the second argument is going to be a file
# handle. That means we want to call parse_from_filehandle(), which
# means we need to turn the first argument into a file handle. Magic
# open will handle the <&STDIN case automagically.
if (defined $_[1]) {
my $infh;
if ($] < 5.006) {
$infh = gensym();
}
unless (open ($infh, $_[0])) {
croak ("Can't open $_[0] for reading: $!\n");
}
$_[0] = $infh;
return $parser->parse_from_filehandle (@_);
} else {
return $parser->parse_from_file (@_);
}
}
############################################################################
# Module return value and documentation
############################################################################
1;
__END__
=head1 NAME
Pod::PlainText - Convert POD data to formatted ASCII text
=head1 SYNOPSIS
use Pod::PlainText;
my $parser = Pod::PlainText->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
B<NOTE: This module is considered legacy; modern Perl releases (5.18 and
higher) are going to remove Pod-Parser from core and use L<Pod-Simple>
for all things POD.>
Pod::PlainText is a module that can convert documentation in the POD format (the
preferred language for documenting Perl) into formatted ASCII. It uses no
special formatting controls or codes whatsoever, and its output is therefore
suitable for nearly any device.
As a derived class from Pod::Parser, Pod::PlainText supports the same methods and
interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
new parser with C<Pod::PlainText-E<gt>new()> and then calls either
parse_from_filehandle() or parse_from_file().
new() can take options, in the form of key/value pairs, that control the
behavior of the parser. The currently recognized options are:
=over 4
=item alt
If set to a true value, selects an alternate output format that, among other
things, uses a different heading style and marks C<=item> entries with a
colon in the left margin. Defaults to false.
=item indent
The number of spaces to indent regular text, and the default indentation for
C<=over> blocks. Defaults to 4.
=item loose
If set to a true value, a blank line is printed after a C<=headN> headings.
If set to false (the default), no blank line is printed after C<=headN>.
This is the default because it's the expected formatting for manual pages;
if you're formatting arbitrary text documents, setting this to true may
result in more pleasing output.
=item sentence
If set to a true value, Pod::PlainText will assume that each sentence ends in two
spaces, and will try to preserve that spacing. If set to false, all
consecutive whitespace in non-verbatim paragraphs is compressed into a
single space. Defaults to true.
=item width
The column at which to wrap text on the right-hand side. Defaults to 76.
=back
The standard Pod::Parser method parse_from_filehandle() takes up to two
arguments, the first being the file handle to read POD from and the second
being the file handle to write the formatted output to. The first defaults
to STDIN if not given, and the second defaults to STDOUT. The method
parse_from_file() is almost identical, except that its two arguments are the
input and output disk files instead. See L<Pod::Parser> for the specific
details.
=head1 DIAGNOSTICS
=over 4
=item Bizarre space in item
(W) Something has gone wrong in internal C<=item> processing. This message
indicates a bug in Pod::PlainText; you should never see it.
=item Can't open %s for reading: %s
(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface
and the input file it was given could not be opened.
=item Unknown escape: %s
(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't
know about.
=item Unknown sequence: %s
(W) The POD source contained a non-standard internal sequence (something of
the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about.
=item Unmatched =back
(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an
C<=over> command.
=back
=head1 RESTRICTIONS
Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on
output, due to an internal implementation detail.
=head1 NOTES
This is a replacement for an earlier Pod::Text module written by Tom
Christiansen. It has a revamped interface, since it now uses Pod::Parser,
but an interface roughly compatible with the old Pod::Text::pod2text()
function is still available. Please change to the new calling convention,
though.
The original Pod::Text contained code to do formatting via termcap
sequences, although it wasn't turned on by default and it was problematic to
get it to work at all. This rewrite doesn't even try to do that, but a
subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.
=head1 SEE ALSO
B<Pod::PlainText> is part of the L<Pod::Parser> distribution.
L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,
pod2text(1)
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the
original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and
its conversion to Pod::Parser by Brad Appleton
E<lt>bradapp@enteract.comE<gt>.
=cut
PK Ю[ʝ0Œ7 �7
Simple.podnu �[���
=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>.
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;
});
=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!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
Documentation has been contributed by:
=over
=item * Gabor Szabo C<szabgab@gmail.com>
=item * Shawn H Corey C<SHCOREY at cpan.org>
=back
=cut
PK Ю[ ��� � ParseLink.pmnu �[��� # 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.006;
use strict;
use warnings;
use vars qw(@EXPORT @ISA $VERSION);
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(parselink);
$VERSION = '4.11';
##############################################################################
# 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 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:
PK Ю[�f;9�R �R
ParseUtils.pmnu �[��� #############################################################################
# Pod/ParseUtils.pm -- helpers for POD parsing and conversion
#
# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::ParseUtils;
use strict;
use vars qw($VERSION);
$VERSION = '1.63'; ## Current version of this package
require 5.005; ## requires this Perl version or later
=head1 NAME
Pod::ParseUtils - helpers for POD parsing and conversion
=head1 SYNOPSIS
use Pod::ParseUtils;
my $list = new Pod::List;
my $link = Pod::Hyperlink->new('Pod::Parser');
=head1 DESCRIPTION
B<NOTE: This module is considered legacy; modern Perl releases (5.18 and
higher) are going to remove Pod-Parser from core and use L<Pod-Simple>
for all things POD.>
B<Pod::ParseUtils> contains a few object-oriented helper packages for
POD parsing and processing (i.e. in POD formatters and translators).
=cut
#-----------------------------------------------------------------------------
# Pod::List
#
# class to hold POD list info (=over, =item, =back)
#-----------------------------------------------------------------------------
package Pod::List;
use Carp;
=head2 Pod::List
B<Pod::List> can be used to hold information about POD lists
(written as =over ... =item ... =back) for further processing.
The following methods are available:
=over 4
=item Pod::List-E<gt>new()
Create a new list object. Properties may be specified through a hash
reference like this:
my $list = Pod::List->new({ -start => $., -indent => 4 });
See the individual methods/properties for details.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my %params = @_;
my $self = {%params};
bless $self, $class;
$self->initialize();
return $self;
}
sub initialize {
my $self = shift;
$self->{-file} ||= 'unknown';
$self->{-start} ||= 'unknown';
$self->{-indent} ||= 4; # perlpod: "should be the default"
$self->{_items} = [];
$self->{-type} ||= '';
}
=item $list-E<gt>file()
Without argument, retrieves the file name the list is in. This must
have been set before by either specifying B<-file> in the B<new()>
method or by calling the B<file()> method with a scalar argument.
=cut
# The POD file name the list appears in
sub file {
return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
}
=item $list-E<gt>start()
Without argument, retrieves the line number where the list started.
This must have been set before by either specifying B<-start> in the
B<new()> method or by calling the B<start()> method with a scalar
argument.
=cut
# The line in the file the node appears
sub start {
return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start};
}
=item $list-E<gt>indent()
Without argument, retrieves the indent level of the list as specified
in C<=over n>. This must have been set before by either specifying
B<-indent> in the B<new()> method or by calling the B<indent()> method
with a scalar argument.
=cut
# indent level
sub indent {
return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent};
}
=item $list-E<gt>type()
Without argument, retrieves the list type, which can be an arbitrary value,
e.g. C<OL>, C<UL>, ... when thinking the HTML way.
This must have been set before by either specifying
B<-type> in the B<new()> method or by calling the B<type()> method
with a scalar argument.
=cut
# The type of the list (UL, OL, ...)
sub type {
return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
}
=item $list-E<gt>rx()
Without argument, retrieves a regular expression for simplifying the
individual item strings once the list type has been determined. Usage:
E.g. when converting to HTML, one might strip the leading number in
an ordered list as C<E<lt>OLE<gt>> already prints numbers itself.
This must have been set before by either specifying
B<-rx> in the B<new()> method or by calling the B<rx()> method
with a scalar argument.
=cut
# The regular expression to simplify the items
sub rx {
return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx};
}
=item $list-E<gt>item()
Without argument, retrieves the array of the items in this list.
The items may be represented by any scalar.
If an argument has been given, it is pushed on the list of items.
=cut
# The individual =items of this list
sub item {
my ($self,$item) = @_;
if(defined $item) {
push(@{$self->{_items}}, $item);
return $item;
}
else {
return @{$self->{_items}};
}
}
=item $list-E<gt>parent()
Without argument, retrieves information about the parent holding this
list, which is represented as an arbitrary scalar.
This must have been set before by either specifying
B<-parent> in the B<new()> method or by calling the B<parent()> method
with a scalar argument.
=cut
# possibility for parsers/translators to store information about the
# lists's parent object
sub parent {
return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent};
}
=item $list-E<gt>tag()
Without argument, retrieves information about the list tag, which can be
any scalar.
This must have been set before by either specifying
B<-tag> in the B<new()> method or by calling the B<tag()> method
with a scalar argument.
=back
=cut
# possibility for parsers/translators to store information about the
# list's object
sub tag {
return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag};
}
#-----------------------------------------------------------------------------
# Pod::Hyperlink
#
# class to manipulate POD hyperlinks (L<>)
#-----------------------------------------------------------------------------
package Pod::Hyperlink;
=head2 Pod::Hyperlink
B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage:
my $link = Pod::Hyperlink->new('alternative text|page/"section in page"');
The B<Pod::Hyperlink> class is mainly designed to parse the contents of the
C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the
different parts of a POD hyperlink for further processing. It can also be
used to construct hyperlinks.
=over 4
=item Pod::Hyperlink-E<gt>new()
The B<new()> method can either be passed a set of key/value pairs or a single
scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object
of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a
failure, the error message is stored in C<$@>.
=cut
use Carp;
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = +{};
bless $self, $class;
$self->initialize();
if(defined $_[0]) {
if(ref($_[0])) {
# called with a list of parameters
%$self = %{$_[0]};
$self->_construct_text();
}
else {
# called with L<> contents
return unless($self->parse($_[0]));
}
}
return $self;
}
sub initialize {
my $self = shift;
$self->{-line} ||= 'undef';
$self->{-file} ||= 'undef';
$self->{-page} ||= '';
$self->{-node} ||= '';
$self->{-alttext} ||= '';
$self->{-type} ||= 'undef';
$self->{_warnings} = [];
}
=item $link-E<gt>parse($string)
This method can be used to (re)parse a (new) hyperlink, i.e. the contents
of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object.
Warnings are stored in the B<warnings> property.
E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point
to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage
section can simply be dropped.
=cut
sub parse {
my $self = shift;
local($_) = $_[0];
# syntax check the link and extract destination
my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0);
$self->{_warnings} = [];
# collapse newlines with whitespace
s/\s*\n+\s*/ /g;
# strip leading/trailing whitespace
if(s/^[\s\n]+//) {
$self->warning('ignoring leading whitespace in link');
}
if(s/[\s\n]+$//) {
$self->warning('ignoring trailing whitespace in link');
}
unless(length($_)) {
_invalid_link('empty link');
return;
}
## Check for different possibilities. This is tedious and error-prone
# we match all possibilities (alttext, page, section/item)
#warn "DEBUG: link=$_\n";
# only page
# problem: a lot of people use (), or (1) or the like to indicate
# man page sections. But this collides with L<func()> that is supposed
# to point to an internal function...
my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)';
# page name only
if(/^($page_rx)$/o) {
$page = $1;
$type = 'page';
}
# alttext, page and "section"
elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) {
($alttext, $page, $node) = ($1, $2, $3);
$type = 'section';
$quoted = 1; #... therefore | and / are allowed
}
# alttext and page
elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) {
($alttext, $page) = ($1, $2);
$type = 'page';
}
# alttext and "section"
elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) {
($alttext, $node) = ($1,$2);
$type = 'section';
$quoted = 1;
}
# page and "section"
elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) {
($page, $node) = ($1, $2);
$type = 'section';
$quoted = 1;
}
# page and item
elsif(m{^($page_rx)\s*/\s*(.+)$}o) {
($page, $node) = ($1, $2);
$type = 'item';
}
# only "section"
elsif(m{^/?"(.+)"$}) {
$node = $1;
$type = 'section';
$quoted = 1;
}
# only item
elsif(m{^\s*/(.+)$}) {
$node = $1;
$type = 'item';
}
# non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should?
elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) {
($alttext,$node) = ($1,$2);
$type = 'hyperlink';
}
# non-standard: Hyperlink
elsif(/^(\w+:[^:\s]\S*)$/i) {
$node = $1;
$type = 'hyperlink';
}
# alttext, page and item
elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) {
($alttext, $page, $node) = ($1, $2, $3);
$type = 'item';
}
# alttext and item
elsif(m{^(.*?)\s*[|]\s*/(.+)$}) {
($alttext, $node) = ($1,$2);
}
# must be an item or a "malformed" section (without "")
else {
$node = $_;
$type = 'item';
}
# collapse whitespace in nodes
$node =~ s/\s+/ /gs;
# empty alternative text expands to node name
if(defined $alttext) {
if(!length($alttext)) {
$alttext = $node || $page;
}
}
else {
$alttext = '';
}
if($page =~ /[(]\w*[)]$/) {
$self->warning("(section) in '$page' deprecated");
}
if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') {
$self->warning("node '$node' contains non-escaped | or /");
}
if($alttext =~ m{[|/]}) {
$self->warning("alternative text '$node' contains non-escaped | or /");
}
$self->{-page} = $page;
$self->{-node} = $node;
$self->{-alttext} = $alttext;
#warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n";
$self->{-type} = $type;
$self->_construct_text();
1;
}
sub _construct_text {
my $self = shift;
my $alttext = $self->alttext();
my $type = $self->type();
my $section = $self->node();
my $page = $self->page();
my $page_ext = '';
$page =~ s/([(]\w*[)])$// && ($page_ext = $1);
if($alttext) {
$self->{_text} = $alttext;
}
elsif($type eq 'hyperlink') {
$self->{_text} = $section;
}
else {
$self->{_text} = ($section || '') .
(($page && $section) ? ' in ' : '') .
"$page$page_ext";
}
# for being marked up later
# use the non-standard markers P<> and Q<>, so that the resulting
# text can be parsed by the translators. It's their job to put
# the correct hypertext around the linktext
if($alttext) {
$self->{_markup} = "Q<$alttext>";
}
elsif($type eq 'hyperlink') {
$self->{_markup} = "Q<$section>";
}
else {
$self->{_markup} = (!$section ? '' : "Q<$section>") .
($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : '');
}
}
=item $link-E<gt>markup($string)
Set/retrieve the textual value of the link. This string contains special
markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the
translator's interior sequence expansion engine to the
formatter-specific code to highlight/activate the hyperlink. The details
have to be implemented in the translator.
=cut
#' retrieve/set markuped text
sub markup {
return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup};
}
=item $link-E<gt>text()
This method returns the textual representation of the hyperlink as above,
but without markers (read only). Depending on the link type this is one of
the following alternatives (the + and * denote the portions of the text
that are marked up):
+perl+ L<perl>
*$|* in +perlvar+ L<perlvar/$|>
*OPTIONS* in +perldoc+ L<perldoc/"OPTIONS">
*DESCRIPTION* L<"DESCRIPTION">
=cut
# The complete link's text
sub text {
return $_[0]->{_text};
}
=item $link-E<gt>warning()
After parsing, this method returns any warnings encountered during the
parsing process.
=cut
# Set/retrieve warnings
sub warning {
my $self = shift;
if(@_) {
push(@{$self->{_warnings}}, @_);
return @_;
}
return @{$self->{_warnings}};
}
=item $link-E<gt>file()
=item $link-E<gt>line()
Just simple slots for storing information about the line and the file
the link was encountered in. Has to be filled in manually.
=cut
# The line in the file the link appears
sub line {
return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line};
}
# The POD file name the link appears in
sub file {
return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
}
=item $link-E<gt>page()
This method sets or returns the POD page this link points to.
=cut
# The POD page the link appears on
sub page {
if (@_ > 1) {
$_[0]->{-page} = $_[1];
$_[0]->_construct_text();
}
return $_[0]->{-page};
}
=item $link-E<gt>node()
As above, but the destination node text of the link.
=cut
# The link destination
sub node {
if (@_ > 1) {
$_[0]->{-node} = $_[1];
$_[0]->_construct_text();
}
return $_[0]->{-node};
}
=item $link-E<gt>alttext()
Sets or returns an alternative text specified in the link.
=cut
# Potential alternative text
sub alttext {
if (@_ > 1) {
$_[0]->{-alttext} = $_[1];
$_[0]->_construct_text();
}
return $_[0]->{-alttext};
}
=item $link-E<gt>type()
The node type, either C<section> or C<item>. As an unofficial type,
there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>>
=cut
# The type: item or headn
sub type {
return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
}
=item $link-E<gt>link()
Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>.
=back
=cut
# The link itself
sub link {
my $self = shift;
my $link = $self->page() || '';
if($self->node()) {
my $node = $self->node();
$node =~ s/\|/E<verbar>/g;
$node =~ s{/}{E<sol>}g;
if($self->type() eq 'section') {
$link .= ($link ? '/' : '') . '"' . $node . '"';
}
elsif($self->type() eq 'hyperlink') {
$link = $self->node();
}
else { # item
$link .= '/' . $node;
}
}
if($self->alttext()) {
my $text = $self->alttext();
$text =~ s/\|/E<verbar>/g;
$text =~ s{/}{E<sol>}g;
$link = "$text|$link";
}
return $link;
}
sub _invalid_link {
my ($msg) = @_;
# this sets @_
#eval { die "$msg\n" };
#chomp $@;
$@ = $msg; # this seems to work, too!
return;
}
#-----------------------------------------------------------------------------
# Pod::Cache
#
# class to hold POD page details
#-----------------------------------------------------------------------------
package Pod::Cache;
=head2 Pod::Cache
B<Pod::Cache> holds information about a set of POD documents,
especially the nodes for hyperlinks.
The following methods are available:
=over 4
=item Pod::Cache-E<gt>new()
Create a new cache object. This object can hold an arbitrary number of
POD documents of class Pod::Cache::Item.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = [];
bless $self, $class;
return $self;
}
=item $cache-E<gt>item()
Add a new item to the cache. Without arguments, this method returns a
list of all cache elements.
=cut
sub item {
my ($self,%param) = @_;
if(%param) {
my $item = Pod::Cache::Item->new(%param);
push(@$self, $item);
return $item;
}
else {
return @{$self};
}
}
=item $cache-E<gt>find_page($name)
Look for a POD document named C<$name> in the cache. Returns the
reference to the corresponding Pod::Cache::Item object or undef if
not found.
=back
=cut
sub find_page {
my ($self,$page) = @_;
foreach(@$self) {
if($_->page() eq $page) {
return $_;
}
}
return;
}
package Pod::Cache::Item;
=head2 Pod::Cache::Item
B<Pod::Cache::Item> holds information about individual POD documents,
that can be grouped in a Pod::Cache object.
It is intended to hold information about the hyperlink nodes of POD
documents.
The following methods are available:
=over 4
=item Pod::Cache::Item-E<gt>new()
Create a new object.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my %params = @_;
my $self = {%params};
bless $self, $class;
$self->initialize();
return $self;
}
sub initialize {
my $self = shift;
$self->{-nodes} = [] unless(defined $self->{-nodes});
}
=item $cacheitem-E<gt>page()
Set/retrieve the POD document name (e.g. "Pod::Parser").
=cut
# The POD page
sub page {
return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page};
}
=item $cacheitem-E<gt>description()
Set/retrieve the POD short description as found in the C<=head1 NAME>
section.
=cut
# The POD description, taken out of NAME if present
sub description {
return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description};
}
=item $cacheitem-E<gt>path()
Set/retrieve the POD file storage path.
=cut
# The file path
sub path {
return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path};
}
=item $cacheitem-E<gt>file()
Set/retrieve the POD file name.
=cut
# The POD file name
sub file {
return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
}
=item $cacheitem-E<gt>nodes()
Add a node (or a list of nodes) to the document's node list. Note that
the order is kept, i.e. start with the first node and end with the last.
If no argument is given, the current list of nodes is returned in the
same order the nodes have been added.
A node can be any scalar, but usually is a pair of node string and
unique id for the C<find_node> method to work correctly.
=cut
# The POD nodes
sub nodes {
my ($self,@nodes) = @_;
if(@nodes) {
push(@{$self->{-nodes}}, @nodes);
return @nodes;
}
else {
return @{$self->{-nodes}};
}
}
=item $cacheitem-E<gt>find_node($name)
Look for a node or index entry named C<$name> in the object.
Returns the unique id of the node (i.e. the second element of the array
stored in the node array) or undef if not found.
=cut
sub find_node {
my ($self,$node) = @_;
my @search;
push(@search, @{$self->{-nodes}}) if($self->{-nodes});
push(@search, @{$self->{-idx}}) if($self->{-idx});
foreach(@search) {
if($_->[0] eq $node) {
return $_->[1]; # id
}
}
return;
}
=item $cacheitem-E<gt>idx()
Add an index entry (or a list of them) to the document's index list. Note that
the order is kept, i.e. start with the first node and end with the last.
If no argument is given, the current list of index entries is returned in the
same order the entries have been added.
An index entry can be any scalar, but usually is a pair of string and
unique id.
=back
=cut
# The POD index entries
sub idx {
my ($self,@idx) = @_;
if(@idx) {
push(@{$self->{-idx}}, @idx);
return @idx;
}
else {
return @{$self->{-idx}};
}
}
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing
a lot of things from L<pod2man> and L<pod2roff> as well as other POD
processing tools by Tom Christiansen, Brad Appleton and Russ Allbery.
B<Pod::ParseUtils> is part of the L<Pod::Parser> distribution.
=head1 SEE ALSO
L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>,
L<pod2html>
=cut
1;
PK Ю[��� Perldoc/ToXml.pmnu �[��� package Pod::Perldoc::ToXml;
use strict;
use warnings;
use vars qw($VERSION);
use parent qw( Pod::Simple::XMLOutStream );
use vars qw($VERSION);
$VERSION = '3.28';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
sub output_extension { 'xml' }
1;
__END__
=head1 NAME
Pod::Perldoc::ToXml - let Perldoc render Pod as XML
=head1 SYNOPSIS
perldoc -o xml -d out.xml Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Simple::XMLOutStream as a formatter class.
This is actually a Pod::Simple::XMLOutStream subclass, and inherits
all its options.
You have to have installed Pod::Simple::XMLOutStream (from the Pod::Simple
dist), or this class won't work.
=head1 SEE ALSO
L<Pod::Simple::XMLOutStream>, L<Pod::Simple>, L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ю[~|0^� � Perldoc/ToTerm.pmnu �[��� package Pod::Perldoc::ToTerm;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '3.28';
use parent qw(Pod::Perldoc::BaseTo);
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' }
use Pod::Text::Termcap ();
sub alt { shift->_perldoc_elem('alt' , @_) }
sub indent { shift->_perldoc_elem('indent' , @_) }
sub loose { shift->_perldoc_elem('loose' , @_) }
sub quotes { shift->_perldoc_elem('quotes' , @_) }
sub sentence { shift->_perldoc_elem('sentence', @_) }
sub width {
my $self = shift;
$self->_perldoc_elem('width' , @_) ||
$self->_get_columns_from_manwidth ||
$self->_get_columns_from_stty ||
$self->_get_default_width;
}
sub pager_configuration {
my($self, $pager, $perldoc) = @_;
# do not modify anything on Windows or DOS
return if ( $perldoc->is_mswin32 || $perldoc->is_dos );
if ( $pager =~ /less/ ) {
$self->_maybe_modify_environment('LESS');
}
elsif ( $pager =~ /more/ ) {
$self->_maybe_modify_environment('MORE');
}
return;
}
sub _maybe_modify_environment {
my($self, $name) = @_;
if ( ! defined $ENV{$name} ) {
$ENV{$name} = "-R";
}
# if the environment is set, don't modify
# anything
}
sub _get_stty { `stty -a` }
sub _get_columns_from_stty {
my $output = $_[0]->_get_stty;
if( $output =~ /\bcolumns\s+(\d+)/ ) { return $1; }
elsif( $output =~ /;\s*(\d+)\s+columns;/ ) { return $1; }
else { return 0 }
}
sub _get_columns_from_manwidth {
my( $self ) = @_;
return 0 unless defined $ENV{MANWIDTH};
unless( $ENV{MANWIDTH} =~ m/\A\d+\z/ ) {
$self->warn( "Ignoring non-numeric MANWIDTH ($ENV{MANWIDTH})\n" );
return 0;
}
if( $ENV{MANWIDTH} == 0 ) {
$self->warn( "Ignoring MANWIDTH of 0. Really? Why even run the program? :)\n" );
return 0;
}
if( $ENV{MANWIDTH} =~ m/\A(\d+)\z/ ) { return $1 }
return 0;
}
sub _get_default_width {
76
}
sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my $self = shift;
$self->{width} = $self->width();
my @options =
map {; $_, $self->{$_} }
grep !m/^_/s,
keys %$self
;
defined(&Pod::Perldoc::DEBUG)
and Pod::Perldoc::DEBUG()
and print "About to call new Pod::Text::Termcap ",
$Pod::Text::VERSION ? "(v$Pod::Text::Termcap::VERSION) " : '',
"with options: ",
@options ? "[@options]" : "(nil)", "\n";
;
Pod::Text::Termcap->new(@options)->parse_from_file(@_);
}
1;
=head1 NAME
Pod::Perldoc::ToTerm - render Pod with terminal escapes
=head1 SYNOPSIS
perldoc -o term Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Text as a formatter class.
It supports the following options, which are explained in
L<Pod::Text>: alt, indent, loose, quotes, sentence, width
For example:
perldoc -o term -w indent:5 Some::Modulename
=head1 PAGER FORMATTING
Depending on the platform, and because this class emits terminal escapes it
will attempt to set the C<-R> flag on your pager by injecting the flag into
your environment variable for C<less> or C<more>.
On Windows and DOS, this class will not modify any environment variables.
=head1 CAVEAT
This module may change to use a different text formatter class in the
future, and this may change what options are supported.
=head1 SEE ALSO
L<Pod::Text>, L<Pod::Text::Termcap>, L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2017 Mark Allen.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=head1 AUTHOR
Mark Allen C<< <mallen@cpan.org> >>
=cut
PK Ю[��%�0 0 Perldoc/GetOptsOO.pmnu �[��� package Pod::Perldoc::GetOptsOO;
use strict;
use vars qw($VERSION);
$VERSION = '3.28';
BEGIN { # Make a DEBUG constant ASAP
*DEBUG = defined( &Pod::Perldoc::DEBUG )
? \&Pod::Perldoc::DEBUG
: sub(){10};
}
sub getopts {
my($target, $args, $truth) = @_;
$args ||= \@ARGV;
$target->aside(
"Starting switch processing. Scanning arguments [@$args]\n"
) if $target->can('aside');
return unless @$args;
$truth = 1 unless @_ > 2;
DEBUG > 3 and print " Truth is $truth\n";
my $error_count = 0;
while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) {
my($first,$rest) = ($1,$2);
if ($_ eq '--') { # early exit if "--"
shift @$args;
last;
}
if ($first eq '-' and $rest) { # GNU style long param names
($first, $rest) = split '=', $rest, 2;
}
my $method = "opt_${first}_with";
if( $target->can($method) ) { # it's argumental
if($rest eq '') { # like -f bar
shift @$args;
$target->warn( "Option $first needs a following argument!\n" ) unless @$args;
$rest = shift @$args;
} else { # like -fbar (== -f bar)
shift @$args;
}
DEBUG > 3 and print " $method => $rest\n";
$target->$method( $rest );
# Otherwise, it's not argumental...
} else {
if( $target->can( $method = "opt_$first" ) ) {
DEBUG > 3 and print " $method is true ($truth)\n";
$target->$method( $truth );
# Otherwise it's an unknown option...
} elsif( $target->can('handle_unknown_option') ) {
DEBUG > 3
and print " calling handle_unknown_option('$first')\n";
$error_count += (
$target->handle_unknown_option( $first ) || 0
);
} else {
++$error_count;
$target->warn( "Unknown option: $first\n" );
}
if($rest eq '') { # like -f
shift @$args
} else { # like -fbar (== -f -bar )
DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n";
$args->[0] = "-$rest";
}
}
}
$target->aside(
"Ending switch processing. Args are [@$args] with $error_count errors.\n"
) if $target->can('aside');
$error_count == 0;
}
1;
__END__
=head1 NAME
Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc
=head1 SYNOPSIS
use Pod::Perldoc::GetOptsOO ();
Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth )
or die "wrong usage";
=head1 DESCRIPTION
Implements a customized option parser used for
L<Pod::Perldoc>.
Rather like Getopt::Std's getopts:
=over
=item Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth)
=item Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT )
(e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo")
=item Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth)
(Truth defaults to 1)
=item Otherwise we try calling $object->handle_unknown_option('n')
(and we increment the error count by the return value of it)
=item If there's no handle_unknown_option, then we just warn, and then increment
the error counter
=back
The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
otherwise it's false.
=head1 SEE ALSO
L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2007 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ю[5���� � Perldoc/ToText.pmnu �[��� package Pod::Perldoc::ToText;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '3.28';
use parent qw(Pod::Perldoc::BaseTo);
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' }
use Pod::Text ();
sub alt { shift->_perldoc_elem('alt' , @_) }
sub indent { shift->_perldoc_elem('indent' , @_) }
sub loose { shift->_perldoc_elem('loose' , @_) }
sub quotes { shift->_perldoc_elem('quotes' , @_) }
sub sentence { shift->_perldoc_elem('sentence', @_) }
sub width { shift->_perldoc_elem('width' , @_) }
sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my $self = shift;
my @options =
map {; $_, $self->{$_} }
grep !m/^_/s,
keys %$self
;
defined(&Pod::Perldoc::DEBUG)
and Pod::Perldoc::DEBUG()
and print "About to call new Pod::Text ",
$Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '',
"with options: ",
@options ? "[@options]" : "(nil)", "\n";
;
Pod::Text->new(@options)->parse_from_file(@_);
}
1;
=head1 NAME
Pod::Perldoc::ToText - let Perldoc render Pod as plaintext
=head1 SYNOPSIS
perldoc -o text Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Text as a formatter class.
It supports the following options, which are explained in
L<Pod::Text>: alt, indent, loose, quotes, sentence, width
For example:
perldoc -o text -w indent:5 Some::Modulename
=head1 CAVEAT
This module may change to use a different text formatter class in the
future, and this may change what options are supported.
=head1 SEE ALSO
L<Pod::Text>, L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[kޛ � Perldoc/ToChecker.pmnu �[��� package Pod::Perldoc::ToChecker;
use strict;
use warnings;
use vars qw(@ISA);
use vars qw($VERSION);
$VERSION = '3.28';
# Pick our superclass...
#
eval 'require Pod::Simple::Checker';
if($@) {
require Pod::Checker;
@ISA = ('Pod::Checker');
} else {
@ISA = ('Pod::Simple::Checker');
}
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' }
sub if_zero_length {
my( $self, $file, $tmp, $tmpfd ) = @_;
print "No Pod errors in $file\n";
}
1;
__END__
=head1 NAME
Pod::Perldoc::ToChecker - let Perldoc check Pod for errors
=head1 SYNOPSIS
% perldoc -o checker SomeFile.pod
No Pod errors in SomeFile.pod
(or an error report)
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Simple::Checker as a "formatter" class (or if that is
not available, then Pod::Checker), to check for errors in a given
Pod file.
This is actually a Pod::Simple::Checker (or Pod::Checker) subclass, and
inherits all its options.
=head1 SEE ALSO
L<Pod::Simple::Checker>, L<Pod::Simple>, L<Pod::Checker>, L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[p�!b� � Perldoc/ToTk.pmnu �[��� package Pod::Perldoc::ToTk;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '3.28';
use parent qw(Pod::Perldoc::BaseTo);
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' } # doesn't matter
sub if_zero_length { } # because it will be 0-length!
sub new { return bless {}, ref($_[0]) || $_[0] }
# TODO: document these and their meanings...
sub tree { shift->_perldoc_elem('tree' , @_) }
sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) }
sub forky { shift->_perldoc_elem('forky' , @_) }
use Pod::Perldoc ();
use File::Spec::Functions qw(catfile);
BEGIN{ # Tk is not core, but this is
eval { require Tk } ||
__PACKAGE__->die( <<"HERE" );
You must have the Tk module to use Pod::Perldoc::ToTk.
If you have it installed, ensure it's in your Perl library
path.
HERE
__PACKAGE__->die(
__PACKAGE__,
" doesn't work nice with Tk.pm version $Tk::VERSION"
) if $Tk::VERSION eq '800.003';
}
BEGIN { eval { require Tk::FcyEntry; }; };
BEGIN{ # Tk::Pod is not core, but this is
eval { require Tk::Pod } ||
__PACKAGE__->die( <<"HERE" );
You must have the Tk::Pod module to use Pod::Perldoc::ToTk.
If you have it installed, ensure it's in your Perl library
path.
HERE
}
# The following was adapted from "tkpod" in the Tk-Pod dist.
sub parse_from_file {
my($self, $Input_File) = @_;
if($self->{'forky'}) {
return if fork; # i.e., parent process returns
}
$Input_File =~ s{\\}{/}g
if $self->is_mswin32 or $self->is_dos
# and maybe OS/2
;
my($tk_opt, $tree);
$tree = $self->{'tree' };
$tk_opt = $self->{'tk_opt'};
#require Tk::ErrorDialog;
# Add 'Tk' subdirectories to search path so, e.g.,
# 'Scrolled' will find doc in 'Tk/Scrolled'
if( $tk_opt ) {
push @INC, grep -d $_, map catfile($_,'Tk'), @INC;
}
my $mw = MainWindow->new();
#eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug';
$mw->withdraw;
# CDE use Font Settings if available
my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width
my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional
if (defined($ufont) and defined($sfont)) {
foreach ($ufont, $sfont) { s/:$//; };
$mw->optionAdd('*Font', $sfont);
$mw->optionAdd('*Entry.Font', $ufont);
$mw->optionAdd('*Text.Font', $ufont);
}
$mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0);
$mw->Pod(
'-file' => $Input_File,
(($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ())
)->focusNext;
# xxx dirty but it works. A simple $mw->destroy if $mw->children
# does not work because Tk::ErrorDialogs could be created.
# (they are withdrawn after Ok instead of destory'ed I guess)
if ($mw->children) {
$mw->repeat(1000, sub {
# ErrorDialog is withdrawn not deleted :-(
foreach ($mw->children) {
return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod')
}
$mw->destroy;
});
} else {
$mw->destroy;
}
#$mw->WidgetDump;
MainLoop();
exit if $self->{'forky'}; # we were the child! so exit now!
return;
}
1;
__END__
=head1 NAME
Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod
=head1 SYNOPSIS
perldoc -o tk Some::Modulename &
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Tk::Pod as a formatter class.
You have to have installed Tk::Pod first, or this class won't load.
=head1 SEE ALSO
L<Tk::Pod>, L<Pod::Perldoc>
=head1 AUTHOR
Current maintainer: 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> >>;
significant portions copied from
F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al.
=cut
PK Ѯ[� ��� � Perldoc/ToPod.pmnu �[��� package Pod::Perldoc::ToPod;
use strict;
use warnings;
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
$VERSION = '3.28';
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'pod' }
sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my( $self, $in, $outfh ) = @_;
open(IN, "<", $in) or $self->die( "Can't read-open $in: $!\nAborting" );
my $cut_mode = 1;
# A hack for finding things between =foo and =cut, inclusive
local $_;
while (<IN>) {
if( m/^=(\w+)/s ) {
if($cut_mode = ($1 eq 'cut')) {
print $outfh "\n=cut\n\n";
# Pass thru the =cut line with some harmless
# (and occasionally helpful) padding
}
}
next if $cut_mode;
print $outfh $_ or $self->die( "Can't print to $outfh: $!" );
}
close IN or $self->die( "Can't close $in: $!" );
return;
}
1;
__END__
=head1 NAME
Pod::Perldoc::ToPod - let Perldoc render Pod as ... Pod!
=head1 SYNOPSIS
perldoc -opod Some::Modulename
(That's currently the same as the following:)
perldoc -u Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to display Pod source as
itself! Pretty Zen, huh?
Currently this class works by just filtering out the non-Pod stuff from
a given input file.
=head1 SEE ALSO
L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: Mark Allen C<< <mallencpan.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
PK Ѯ[j�v�7 �7 Perldoc/ToMan.pmnu �[��� require 5.006;
package Pod::Perldoc::ToMan;
use strict;
use warnings;
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
$VERSION = '3.28';
use File::Spec::Functions qw(catfile);
use Pod::Man 2.18;
# This class is unlike ToText.pm et al, because we're NOT paging thru
# the output in our particular format -- we make the output and
# then we run nroff (or whatever) on it, and then page thru the
# (plaintext) output of THAT!
sub SUCCESS () { 1 }
sub FAILED () { 0 }
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' }
sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) }
sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) }
sub __bindir { shift->_perldoc_elem('__bindir' , @_) }
sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) }
sub __output_file { shift->_perldoc_elem('__output_file' , @_) }
sub center { shift->_perldoc_elem('center' , @_) }
sub date { shift->_perldoc_elem('date' , @_) }
sub fixed { shift->_perldoc_elem('fixed' , @_) }
sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) }
sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) }
sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) }
sub name { shift->_perldoc_elem('name' , @_) }
sub quotes { shift->_perldoc_elem('quotes' , @_) }
sub release { shift->_perldoc_elem('release' , @_) }
sub section { shift->_perldoc_elem('section' , @_) }
sub new {
my( $either ) = shift;
my $self = bless {}, ref($either) || $either;
$self->init( @_ );
return $self;
}
sub init {
my( $self, @args ) = @_;
unless( $self->__nroffer ) {
my $roffer = $self->_find_roffer( $self->_roffer_candidates );
$self->debug( "Using $roffer\n" );
$self->__nroffer( $roffer );
}
else {
$self->debug( "__nroffer is " . $self->__nroffer() . "\n" );
}
$self->_check_nroffer;
}
sub _roffer_candidates {
my( $self ) = @_;
if( $self->is_openbsd || $self->is_freebsd || $self->is_bitrig ) { qw( mandoc groff nroff ) }
else { qw( groff nroff mandoc ) }
}
sub _find_roffer {
my( $self, @candidates ) = @_;
my @found = ();
foreach my $candidate ( @candidates ) {
push @found, $self->_find_executable_in_path( $candidate );
}
return wantarray ? @found : $found[0];
}
sub _check_nroffer {
return 1;
# where is it in the PATH?
# is it executable?
# what is its real name?
# what is its version?
# does it support the flags we need?
# is it good enough for us?
}
sub _get_stty { `stty -a` }
sub _get_columns_from_stty {
my $output = $_[0]->_get_stty;
if( $output =~ /\bcolumns\s+(\d+)/ ) { return $1 }
elsif( $output =~ /;\s*(\d+)\s+columns;/ ) { return $1 }
else { return 0 }
}
sub _get_columns_from_manwidth {
my( $self ) = @_;
return 0 unless defined $ENV{MANWIDTH};
unless( $ENV{MANWIDTH} =~ m/\A\d+\z/ ) {
$self->warn( "Ignoring non-numeric MANWIDTH ($ENV{MANWIDTH})\n" );
return 0;
}
if( $ENV{MANWIDTH} == 0 ) {
$self->warn( "Ignoring MANWIDTH of 0. Really? Why even run the program? :)\n" );
return 0;
}
if( $ENV{MANWIDTH} =~ m/\A(\d+)\z/ ) { return $1 }
return 0;
}
sub _get_default_width {
73
}
sub _get_columns {
$_[0]->_get_columns_from_manwidth ||
$_[0]->_get_columns_from_stty ||
$_[0]->_get_default_width;
}
sub _get_podman_switches {
my( $self ) = @_;
my @switches = map { $_, $self->{$_} } grep !m/^_/s, keys %$self;
# There needs to be a cleaner way to handle setting
# the UTF-8 flag, but for now, comment out this
# line because it often does the wrong thing.
#
# See RT #77465
#
#push @switches, 'utf8' => 1;
$self->debug( "Pod::Man switches are [@switches]\n" );
return @switches;
}
sub _parse_with_pod_man {
my( $self, $file ) = @_;
#->output_fh and ->output_string from Pod::Simple aren't
# working, apparently, so there's this ugly hack:
local *STDOUT;
open STDOUT, '>', $self->{_text_ref};
my $parser = Pod::Man->new( $self->_get_podman_switches );
$self->debug( "Parsing $file\n" );
$parser->parse_from_file( $file );
$self->debug( "Done parsing $file\n" );
close STDOUT;
$self->die( "No output from Pod::Man!\n" )
unless length $self->{_text_ref};
$self->_save_pod_man_output if $self->debugging;
return SUCCESS;
}
sub _save_pod_man_output {
my( $self, $fh ) = @_;
$fh = do {
my $file = "podman.out.$$.txt";
$self->debug( "Writing $file with Pod::Man output\n" );
open my $fh2, '>', $file;
$fh2;
} unless $fh;
print { $fh } ${ $self->{_text_ref} };
}
sub _have_groff_with_utf8 {
my( $self ) = @_;
return 0 unless $self->_is_groff;
my $roffer = $self->__nroffer;
my $minimum_groff_version = '1.20.1';
my $version_string = `$roffer -v`;
my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/;
$self->debug( "Found groff $version\n" );
# is a string comparison good enough?
if( $version lt $minimum_groff_version ) {
$self->warn(
"You have an old groff." .
" Update to version $minimum_groff_version for good Unicode support.\n" .
"If you don't upgrade, wide characters may come out oddly.\n"
);
}
$version ge $minimum_groff_version;
}
sub _have_mandoc_with_utf8 {
my( $self ) = @_;
$self->_is_mandoc and not system 'mandoc -Tlocale -V > /dev/null 2>&1';
}
sub _collect_nroff_switches {
my( $self ) = shift;
my @render_switches = ('-man', $self->_get_device_switches);
# Thanks to Brendan O'Dea for contributing the following block
if( $self->_is_roff and -t STDOUT and my ($cols) = $self->_get_columns ) {
my $c = $cols * 39 / 40;
$cols = $c > $cols - 2 ? $c : $cols -2;
push @render_switches, '-rLL=' . (int $c) . 'n' if $cols > 80;
}
# I hear persistent reports that adding a -c switch to $render
# solves many people's problems. But I also hear that some mans
# don't have a -c switch, so that unconditionally adding it here
# would presumably be a Bad Thing -- sburke@cpan.org
push @render_switches, '-c' if( $self->_is_roff and $self->is_cygwin );
return @render_switches;
}
sub _get_device_switches {
my( $self ) = @_;
if( $self->_is_nroff ) { qw() }
elsif( $self->_have_groff_with_utf8 ) { qw(-Kutf8 -Tutf8) }
elsif( $self->_is_ebcdic ) { qw(-Tcp1047) }
elsif( $self->_have_mandoc_with_utf8 ) { qw(-Tlocale) }
elsif( $self->_is_mandoc ) { qw() }
else { qw(-Tlatin1) }
}
sub _is_roff {
my( $self ) = @_;
$self->_is_nroff or $self->_is_groff;
}
sub _is_nroff {
my( $self ) = @_;
$self->__nroffer =~ /\bnroff\b/;
}
sub _is_groff {
my( $self ) = @_;
$self->__nroffer =~ /\bgroff\b/;
}
sub _is_mandoc {
my ( $self ) = @_;
$self->__nroffer =~ /\bmandoc\b/;
}
sub _is_ebcdic {
my( $self ) = @_;
return 0;
}
sub _filter_through_nroff {
my( $self ) = shift;
$self->debug( "Filtering through " . $self->__nroffer() . "\n" );
# Maybe someone set rendering switches as part of the opt_n value
# Deal with that here.
my ($render, $switches) = $self->__nroffer() =~ /\A([\/a-zA-Z0-9_\.-]+)\b(.+)?\z/;
$self->die("no nroffer!?") unless $render;
my @render_switches = $self->_collect_nroff_switches;
if ( $switches ) {
# Eliminate whitespace
$switches =~ s/\s//g;
# Then separate the switches with a zero-width positive
# lookahead on the dash.
#
# See:
# http://www.effectiveperlprogramming.com/blog/1411
# for a good discussion of this technique
push @render_switches, split(/(?=-)/, $switches);
}
$self->debug( "render is $render\n" );
$self->debug( "render options are @render_switches\n" );
require Symbol;
require IPC::Open3;
require IO::Handle;
my $pid = IPC::Open3::open3(
my $writer,
my $reader,
my $err = Symbol::gensym(),
$render,
@render_switches
);
$reader->autoflush(1);
use IO::Select;
my $selector = IO::Select->new( $reader );
$self->debug( "Writing to pipe to $render\n" );
my $offset = 0;
my $chunk_size = 4096;
my $length = length( ${ $self->{_text_ref} } );
my $chunks = $length / $chunk_size;
my $done;
my $buffer;
while( $offset <= $length ) {
$self->debug( "Writing chunk $chunks\n" ); $chunks++;
syswrite $writer, ${ $self->{_text_ref} }, $chunk_size, $offset
or $self->die( $! );
$offset += $chunk_size;
$self->debug( "Checking read\n" );
READ: {
last READ unless $selector->can_read( 0.01 );
$self->debug( "Reading\n" );
my $bytes = sysread $reader, $buffer, 4096;
$self->debug( "Read $bytes bytes\n" );
$done .= $buffer;
$self->debug( sprintf "Output is %d bytes\n",
length $done
);
next READ;
}
}
close $writer;
$self->debug( "Done writing\n" );
# read any leftovers
$done .= do { local $/; <$reader> };
$self->debug( sprintf "Done reading. Output is %d bytes\n",
length $done
);
if( $? ) {
$self->warn( "Error from pipe to $render!\n" );
$self->debug( 'Error: ' . do { local $/; <$err> } );
}
close $reader;
if( my $err = $? ) {
$self->debug(
"Nonzero exit ($?) while running `$render @render_switches`.\n" .
"Falling back to Pod::Perldoc::ToPod\n"
);
return $self->_fallback_to_pod( @_ );
}
$self->debug( "Output:\n----\n$done\n----\n" );
${ $self->{_text_ref} } = $done;
return length ${ $self->{_text_ref} } ? SUCCESS : FAILED;
}
sub parse_from_file {
my( $self, $file, $outfh) = @_;
# We have a pipeline of filters each affecting the reference
# in $self->{_text_ref}
$self->{_text_ref} = \my $output;
$self->_parse_with_pod_man( $file );
# so far, nroff is an external command so we ensure it worked
my $result = $self->_filter_through_nroff;
return $self->_fallback_to_pod( @_ ) unless $result == SUCCESS;
$self->_post_nroff_processing;
print { $outfh } $output or
$self->die( "Can't print to $$self{__output_file}: $!" );
return;
}
sub _fallback_to_pod {
my( $self, @args ) = @_;
$self->warn( "Falling back to Pod because there was a problem!\n" );
require Pod::Perldoc::ToPod;
return Pod::Perldoc::ToPod->new->parse_from_file(@_);
}
# maybe there's a user setting we should check?
sub _get_tab_width { 4 }
sub _expand_tabs {
my( $self ) = @_;
my $tab_width = ' ' x $self->_get_tab_width;
${ $self->{_text_ref} } =~ s/\t/$tab_width/g;
}
sub _post_nroff_processing {
my( $self ) = @_;
if( $self->is_hpux ) {
$self->debug( "On HP-UX, I'm going to expand tabs for you\n" );
# this used to be a pipe to `col -x` for HP-UX
$self->_expand_tabs;
}
if( $self->{'__filter_nroff'} ) {
$self->debug( "filter_nroff is set, so filtering\n" );
$self->_remove_nroff_header;
$self->_remove_nroff_footer;
}
else {
$self->debug( "filter_nroff is not set, so not filtering\n" );
}
$self->_handle_unicode;
return 1;
}
# I don't think this does anything since there aren't two consecutive
# newlines in the Pod::Man output
sub _remove_nroff_header {
my( $self ) = @_;
$self->debug( "_remove_nroff_header is still a stub!\n" );
return 1;
# my @data = split /\n{2,}/, shift;
# shift @data while @data and $data[0] !~ /\S/; # Go to header
# shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
}
# I don't think this does anything since there aren't two consecutive
# newlines in the Pod::Man output
sub _remove_nroff_footer {
my( $self ) = @_;
$self->debug( "_remove_nroff_footer is still a stub!\n" );
return 1;
${ $self->{_text_ref} } =~ s/\n\n+.*\w.*\Z//m;
# my @data = split /\n{2,}/, shift;
# pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
# 28/Jan/99 perl 5.005, patch 53 1
}
sub _unicode_already_handled {
my( $self ) = @_;
$self->_have_groff_with_utf8 ||
1 # so, we don't have a case that needs _handle_unicode
;
}
sub _handle_unicode {
# this is the job of preconv
# we don't need this with groff 1.20 and later.
my( $self ) = @_;
return 1 if $self->_unicode_already_handled;
require Encode;
# it's UTF-8 here, but we need character data
my $text = Encode::decode( 'UTF-8', ${ $self->{_text_ref} } ) ;
# http://www.mail-archive.com/groff@gnu.org/msg01378.html
# http://linux.die.net/man/7/groff_char
# http://www.gnu.org/software/groff/manual/html_node/Using-Symbols.html
# http://lists.gnu.org/archive/html/groff/2011-05/msg00007.html
# http://www.simplicidade.org/notes/archives/2009/05/fixing_the_pod.html
# http://lists.freebsd.org/pipermail/freebsd-questions/2011-July/232239.html
$text =~ s/(\P{ASCII})/
sprintf '\\[u%04X]', ord $1
/eg;
# should we encode?
${ $self->{_text_ref} } = $text;
}
1;
__END__
=head1 NAME
Pod::Perldoc::ToMan - let Perldoc render Pod as man pages
=head1 SYNOPSIS
perldoc -o man Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Man and C<groff> for reading Pod pages.
The following options are supported: center, date, fixed, fixedbold,
fixeditalic, fixedbolditalic, quotes, release, section
(Those options are explained in L<Pod::Man>.)
For example:
perldoc -o man -w center:Pod Some::Modulename
=head1 CAVEAT
This module may change to use a different pod-to-nroff formatter class
in the future, and this may change what options are supported.
=head1 SEE ALSO
L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2011 brian d foy. All rights reserved.
Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[�mV!� � Perldoc/ToANSI.pmnu �[��� package Pod::Perldoc::ToANSI;
use strict;
use warnings;
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
$VERSION = '3.28';
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' }
use Pod::Text::Color ();
sub alt { shift->_perldoc_elem('alt' , @_) }
sub indent { shift->_perldoc_elem('indent' , @_) }
sub loose { shift->_perldoc_elem('loose' , @_) }
sub quotes { shift->_perldoc_elem('quotes' , @_) }
sub sentence { shift->_perldoc_elem('sentence', @_) }
sub width { shift->_perldoc_elem('width' , @_) }
sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my $self = shift;
my @options =
map {; $_, $self->{$_} }
grep !m/^_/s,
keys %$self
;
defined(&Pod::Perldoc::DEBUG)
and Pod::Perldoc::DEBUG()
and print "About to call new Pod::Text::Color ",
$Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '',
"with options: ",
@options ? "[@options]" : "(nil)", "\n";
;
Pod::Text::Color->new(@options)->parse_from_file(@_);
}
1;
=head1 NAME
Pod::Perldoc::ToANSI - render Pod with ANSI color escapes
=head1 SYNOPSIS
perldoc -o ansi Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Text as a formatter class.
It supports the following options, which are explained in
L<Pod::Text>: alt, indent, loose, quotes, sentence, width
For example:
perldoc -o term -w indent:5 Some::Modulename
=head1 CAVEAT
This module may change to use a different text formatter class in the
future, and this may change what options are supported.
=head1 SEE ALSO
L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2011 Mark Allen. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[Y2��5 5 Perldoc/BaseTo.pmnu �[��� package Pod::Perldoc::BaseTo;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '3.28';
use Carp qw(croak carp);
use Config qw(%Config);
use File::Spec::Functions qw(catfile);
sub is_pageable { '' }
sub write_with_binmode { 1 }
sub output_extension { 'txt' } # override in subclass!
# sub new { my $self = shift; ... }
# sub parse_from_file( my($class, $in, $out) = ...; ... }
#sub new { return bless {}, ref($_[0]) || $_[0] }
# this is also in Perldoc.pm, but why look there when you're a
# subclass of this?
sub TRUE () {1}
sub FALSE () {return}
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_openbsd = $^O =~ m/openbsd/ ? \&TRUE : \&FALSE unless defined &is_openbsd;
*is_freebsd = $^O =~ m/freebsd/ ? \&TRUE : \&FALSE unless defined &is_freebsd;
*is_bitrig = $^O =~ m/bitrig/ ? \&TRUE : \&FALSE unless defined &is_bitrig;
}
sub _perldoc_elem {
my($self, $name) = splice @_,0,2;
if(@_) {
$self->{$name} = $_[0];
} else {
$self->{$name};
}
}
sub debugging {
my( $self, @messages ) = @_;
( 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 _get_path_components {
my( $self ) = @_;
my @paths = split /\Q$Config{path_sep}/, $ENV{PATH};
return @paths;
}
sub _find_executable_in_path {
my( $self, $program ) = @_;
my @found = ();
foreach my $dir ( $self->_get_path_components ) {
my $binary = catfile( $dir, $program );
$self->debug( "Looking for $binary\n" );
next unless -e $binary;
unless( -x $binary ) {
$self->warn( "Found $binary but it's not executable. Skipping.\n" );
next;
}
$self->debug( "Found $binary\n" );
push @found, $binary;
}
return @found;
}
1;
__END__
=head1 NAME
Pod::Perldoc::BaseTo - Base for Pod::Perldoc formatters
=head1 SYNOPSIS
package Pod::Perldoc::ToMyFormat;
use parent qw( Pod::Perldoc::BaseTo );
...
=head1 DESCRIPTION
This package is meant as a base of Pod::Perldoc formatters,
like L<Pod::Perldoc::ToText>, L<Pod::Perldoc::ToMan>, etc.
It provides default implementations for the methods
is_pageable
write_with_binmode
output_extension
_perldoc_elem
The concrete formatter must implement
new
parse_from_file
=head1 SEE ALSO
L<perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2007 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[`#�ke e Perldoc/ToRtf.pmnu �[��� package Pod::Perldoc::ToRtf;
use strict;
use warnings;
use parent qw( Pod::Simple::RTF );
use vars qw($VERSION);
$VERSION = '3.28';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
sub output_extension { 'rtf' }
sub page_for_perldoc {
my($self, $tempfile, $perldoc) = @_;
return unless $perldoc->IS_MSWin32;
my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe';
$perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" );
return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0;
return 0;
}
1;
__END__
=head1 NAME
Pod::Perldoc::ToRtf - let Perldoc render Pod as RTF
=head1 SYNOPSIS
perldoc -o rtf Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Simple::RTF as a formatter class.
This is actually a Pod::Simple::RTF subclass, and inherits
all its options.
You have to have Pod::Simple::RTF installed (from the Pod::Simple dist),
or this module won't work.
If Perldoc is running under MSWin and uses this class as a formatter,
the output will be opened with F<write.exe> or whatever program is
specified in the environment variable C<RTFREADER>. For example, to
specify that RTF files should be opened the same as they are when you
double-click them, you would do C<set RTFREADER=start.exe> in your
F<autoexec.bat>.
Handy tip: put C<set PERLDOC=-ortf> in your F<autoexec.bat>
and that will set this class as the default formatter to run when
you do C<perldoc whatever>.
=head1 SEE ALSO
L<Pod::Simple::RTF>, L<Pod::Simple>, L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[_���
�
Perldoc/ToNroff.pmnu �[��� package Pod::Perldoc::ToNroff;
use strict;
use warnings;
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
$VERSION = '3.28';
# This is unlike ToMan.pm in that it emits the raw nroff source!
sub is_pageable { 1 } # well, if you ask for it...
sub write_with_binmode { 0 }
sub output_extension { 'man' }
use Pod::Man ();
sub center { shift->_perldoc_elem('center' , @_) }
sub date { shift->_perldoc_elem('date' , @_) }
sub fixed { shift->_perldoc_elem('fixed' , @_) }
sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) }
sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) }
sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) }
sub quotes { shift->_perldoc_elem('quotes' , @_) }
sub release { shift->_perldoc_elem('release' , @_) }
sub section { shift->_perldoc_elem('section' , @_) }
sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my $self = shift;
my $file = $_[0];
my @options =
map {; $_, $self->{$_} }
grep !m/^_/s,
keys %$self
;
defined(&Pod::Perldoc::DEBUG)
and Pod::Perldoc::DEBUG()
and print "About to call new Pod::Man ",
$Pod::Man::VERSION ? "(v$Pod::Man::VERSION) " : '',
"with options: ",
@options ? "[@options]" : "(nil)", "\n";
;
Pod::Man->new(@options)->parse_from_file(@_);
}
1;
__END__
=head1 NAME
Pod::Perldoc::ToNroff - let Perldoc convert Pod to nroff
=head1 SYNOPSIS
perldoc -o nroff -d something.3 Some::Modulename
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
Pod::Man as a formatter class.
The following options are supported: center, date, fixed, fixedbold,
fixeditalic, fixedbolditalic, quotes, release, section
Those options are explained in L<Pod::Man>.
For example:
perldoc -o nroff -w center:Pod -d something.3 Some::Modulename
=head1 CAVEAT
This module may change to use a different pod-to-nroff formatter class
in the future, and this may change what options are supported.
=head1 SEE ALSO
L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToMan>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: 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
PK Ѯ[�_���= �= Find.pmnu �[��� #############################################################################
# Pod/Find.pm -- finds files containing POD documentation
#
# Author: Marek Rouchal <marekr@cpan.org>
#
# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
# from Nick Ing-Simmon's PodToHtml). All rights reserved.
# This file is part of "PodParser". Pod::Find is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Find;
use strict;
use vars qw($VERSION);
$VERSION = '1.63'; ## Current version of this package
require 5.005; ## requires this Perl version or later
use Carp;
BEGIN {
if ($] < 5.006) {
require Symbol;
import Symbol;
}
}
#############################################################################
=head1 NAME
Pod::Find - find POD documents in directory trees
=head1 SYNOPSIS
use Pod::Find qw(pod_find simplify_name);
my %pods = pod_find({ -verbose => 1, -inc => 1 });
foreach(keys %pods) {
print "found library POD `$pods{$_}' in $_\n";
}
print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
$location = pod_where( { -inc => 1 }, "Pod::Find" );
=head1 DESCRIPTION
B<NOTE: This module is considered legacy; modern Perl releases (5.18 and
higher) are going to remove Pod-Parser from core and use L<Pod-Simple>
for all things POD.>
B<Pod::Find> provides a set of functions to locate POD files. Note that
no function is exported by default to avoid pollution of your namespace,
so be sure to specify them in the B<use> statement if you need them:
use Pod::Find qw(pod_find);
From this version on the typical SCM (software configuration management)
directories are ignored. These are: RCS, CVS, SCCS, .svn, .hg, .git, .sync
=cut
#use diagnostics;
use Exporter;
use File::Spec;
use File::Find;
use Cwd qw(abs_path cwd);
use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);
# package global variables
my $SIMPLIFY_RX;
=head2 C<pod_find( { %opts } , @directories )>
The function B<pod_find> searches for POD documents in a given set of
files and/or directories. It returns a hash with the file names as keys
and the POD name as value. The POD name is derived from the file name
and its position in the directory tree.
E.g. when searching in F<$HOME/perl5lib>, the file
F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
I<Myclass::Subclass>. The name information can be used for POD
translators.
Only text files containing at least one valid POD command are found.
A warning is printed if more than one POD file with the same POD name
is found, e.g. F<CPAN.pm> in different directories. This usually
indicates duplicate occurrences of modules in the I<@INC> search path.
B<OPTIONS> The first argument for B<pod_find> may be a hash reference
with options. The rest are either directories that are searched
recursively or files. The POD names of files are the plain basenames
with any Perl-like extension (.pm, .pl, .pod) stripped.
=over 4
=item C<-verbose =E<gt> 1>
Print progress information while scanning.
=item C<-perl =E<gt> 1>
Apply Perl-specific heuristics to find the correct PODs. This includes
stripping Perl-like extensions, omitting subdirectories that are numeric
but do I<not> match the current Perl interpreter's version id, suppressing
F<site_perl> as a module hierarchy name etc.
=item C<-script =E<gt> 1>
Search for PODs in the current Perl interpreter's installation
B<scriptdir>. This is taken from the local L<Config|Config> module.
=item C<-inc =E<gt> 1>
Search for PODs in the current Perl interpreter's I<@INC> paths. This
automatically considers paths specified in the C<PERL5LIB> environment
as this is included in I<@INC> by the Perl interpreter itself.
=back
=cut
# return a hash of the POD files found
# first argument may be a hashref (options),
# rest is a list of directories to search recursively
sub pod_find
{
my %opts;
if(ref $_[0]) {
%opts = %{shift()};
}
$opts{-verbose} ||= 0;
$opts{-perl} ||= 0;
my (@search) = @_;
if($opts{-script}) {
require Config;
push(@search, $Config::Config{scriptdir})
if -d $Config::Config{scriptdir};
$opts{-perl} = 1;
}
if($opts{-inc}) {
if ($^O eq 'MacOS') {
# tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
my @new_INC = @INC;
for (@new_INC) {
if ( $_ eq '.' ) {
$_ = ':';
} elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
$_ = ':'. $_;
} else {
$_ =~ s{^\./}{:};
}
}
push(@search, grep($_ ne File::Spec->curdir, @new_INC));
} else {
my %seen;
my $curdir = File::Spec->curdir;
foreach(@INC) {
next if $_ eq $curdir;
my $path = abs_path($_);
push(@search, $path) unless $seen{$path}++;
}
}
$opts{-perl} = 1;
}
if($opts{-perl}) {
require Config;
# this code simplifies the POD name for Perl modules:
# * remove "site_perl"
# * remove e.g. "i586-linux" (from 'archname')
# * remove e.g. 5.00503
# * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
# Mac OS:
# * remove ":?site_perl:"
# * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)
if ($^O eq 'MacOS') {
$SIMPLIFY_RX =
qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!;
} else {
$SIMPLIFY_RX =
qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
}
}
my %dirs_visited;
my %pods;
my %names;
my $pwd = cwd();
foreach my $try (@search) {
unless(File::Spec->file_name_is_absolute($try)) {
# make path absolute
$try = File::Spec->catfile($pwd,$try);
}
# simplify path
# on VMS canonpath will vmsify:[the.path], but File::Find::find
# wants /unixy/paths
if ($^O eq 'VMS') {
$try = VMS::Filespec::unixify($try);
}
else {
$try = File::Spec->canonpath($try);
}
my $name;
if(-f $try) {
if($name = _check_and_extract_name($try, $opts{-verbose})) {
_check_for_duplicates($try, $name, \%names, \%pods);
}
next;
}
my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
$root_rx=~ s|//$|/|; # remove trailing double slash
File::Find::find( sub {
my $item = $File::Find::name;
if(-d) {
if($item =~ m{/(?:RCS|CVS|SCCS|\.svn|\.hg|\.git|\.sync)$}) {
$File::Find::prune = 1;
return;
}
elsif($dirs_visited{$item}) {
warn "Directory '$item' already seen, skipping.\n"
if($opts{-verbose});
$File::Find::prune = 1;
return;
}
else {
$dirs_visited{$item} = 1;
}
if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
$File::Find::prune = 1;
warn "Perl $] version mismatch on $_, skipping.\n"
if($opts{-verbose});
}
return;
}
if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
_check_for_duplicates($item, $name, \%names, \%pods);
}
}, $try); # end of File::Find::find
}
chdir $pwd;
return %pods;
}
sub _check_for_duplicates {
my ($file, $name, $names_ref, $pods_ref) = @_;
if($$names_ref{$name}) {
warn "Duplicate POD found (shadowing?): $name ($file)\n";
warn ' Already seen in ',
join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
}
else {
$$names_ref{$name} = 1;
}
return $$pods_ref{$file} = $name;
}
sub _check_and_extract_name {
my ($file, $verbose, $root_rx) = @_;
# check extension or executable flag
# this involves testing the .bat extension on Win32!
unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) {
return;
}
return unless contains_pod($file,$verbose);
# strip non-significant path components
# TODO what happens on e.g. Win32?
my $name = $file;
if(defined $root_rx) {
$name =~ s/$root_rx//is;
$name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX);
}
else {
if ($^O eq 'MacOS') {
$name =~ s/^.*://s;
} else {
$name =~ s{^.*/}{}s;
}
}
_simplify($name);
$name =~ s{/+}{::}g;
if ($^O eq 'MacOS') {
$name =~ s{:+}{::}g; # : -> ::
} else {
$name =~ s{/+}{::}g; # / -> ::
}
return $name;
}
=head2 C<simplify_name( $str )>
The function B<simplify_name> is equivalent to B<basename>, but also
strips Perl-like extensions (.pm, .pl, .pod) and extensions like
F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
=cut
# basic simplification of the POD name:
# basename & strip extension
sub simplify_name {
my ($str) = @_;
# remove all path components
if ($^O eq 'MacOS') {
$str =~ s/^.*://s;
} else {
$str =~ s{^.*/}{}s;
}
_simplify($str);
return $str;
}
# internal sub only
sub _simplify {
# strip Perl's own extensions
$_[0] =~ s/\.(pod|pm|plx?)\z//i;
# strip meaningless extensions on Win32 and OS/2
$_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i);
# strip meaningless extensions on VMS
$_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
}
# contribution from Tim Jenness <t.jenness@jach.hawaii.edu>
=head2 C<pod_where( { %opts }, $pod )>
Returns the location of a pod document given a search directory
and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.
Options:
=over 4
=item C<-inc =E<gt> 1>
Search @INC for the pod and also the C<scriptdir> defined in the
L<Config|Config> module.
=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>
Reference to an array of search directories. These are searched in order
before looking in C<@INC> (if B<-inc>). Current directory is used if
none are specified.
=item C<-verbose =E<gt> 1>
List directories as they are searched
=back
Returns the full path of the first occurrence to the file.
Package names (eg 'A::B') are automatically converted to directory
names in the selected directory. (eg on unix 'A::B' is converted to
'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
search automatically if required.
A subdirectory F<pod/> is also checked if it exists in any of the given
search directories. This ensures that e.g. L<perlfunc|perlfunc> is
found.
It is assumed that if a module name is supplied, that that name
matches the file name. Pods are not opened to check for the 'NAME'
entry.
A check is made to make sure that the file that is found does
contain some pod documentation.
=cut
sub pod_where {
# default options
my %options = (
'-inc' => 0,
'-verbose' => 0,
'-dirs' => [ File::Spec->curdir ],
);
# Check for an options hash as first argument
if (defined $_[0] && ref($_[0]) eq 'HASH') {
my $opt = shift;
# Merge default options with supplied options
%options = (%options, %$opt);
}
# Check usage
carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));
# Read argument
my $pod = shift;
# Split on :: and then join the name together using File::Spec
my @parts = split (/::/, $pod);
# Get full directory list
my @search_dirs = @{ $options{'-dirs'} };
if ($options{'-inc'}) {
require Config;
# Add @INC
if ($^O eq 'MacOS' && $options{'-inc'}) {
# tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
my @new_INC = @INC;
for (@new_INC) {
if ( $_ eq '.' ) {
$_ = ':';
} elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
$_ = ':'. $_;
} else {
$_ =~ s{^\./}{:};
}
}
push (@search_dirs, @new_INC);
} elsif ($options{'-inc'}) {
push (@search_dirs, @INC);
}
# Add location of pod documentation for perl man pages (eg perlfunc)
# This is a pod directory in the private install tree
#my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
# 'pod');
#push (@search_dirs, $perlpoddir)
# if -d $perlpoddir;
# Add location of binaries such as pod2text
push (@search_dirs, $Config::Config{'scriptdir'})
if -d $Config::Config{'scriptdir'};
}
warn 'Search path is: '.join(' ', @search_dirs)."\n"
if $options{'-verbose'};
# Loop over directories
Dir: foreach my $dir ( @search_dirs ) {
# Don't bother if can't find the directory
if (-d $dir) {
warn "Looking in directory $dir\n"
if $options{'-verbose'};
# Now concatenate this directory with the pod we are searching for
my $fullname = File::Spec->catfile($dir, @parts);
$fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS';
warn "Filename is now $fullname\n"
if $options{'-verbose'};
# Loop over possible extensions
foreach my $ext ('', '.pod', '.pm', '.pl') {
my $fullext = $fullname . $ext;
if (-f $fullext &&
contains_pod($fullext, $options{'-verbose'}) ) {
warn "FOUND: $fullext\n" if $options{'-verbose'};
return $fullext;
}
}
} else {
warn "Directory $dir does not exist\n"
if $options{'-verbose'};
next Dir;
}
# for some strange reason the path on MacOS/darwin/cygwin is
# 'pods' not 'pod'
# this could be the case also for other systems that
# have a case-tolerant file system, but File::Spec
# does not recognize 'darwin' yet. And cygwin also has "pods",
# but is not case tolerant. Oh well...
if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i)
&& -d File::Spec->catdir($dir,'pods')) {
$dir = File::Spec->catdir($dir,'pods');
redo Dir;
}
if(-d File::Spec->catdir($dir,'pod')) {
$dir = File::Spec->catdir($dir,'pod');
redo Dir;
}
}
# No match;
return;
}
=head2 C<contains_pod( $file , $verbose )>
Returns true if the supplied filename (not POD module) contains some pod
information.
=cut
sub contains_pod {
my $file = shift;
my $verbose = 0;
$verbose = shift if @_;
# check for one line of POD
my $podfh;
if ($] < 5.006) {
$podfh = gensym();
}
unless(open($podfh,"<$file")) {
warn "Error: $file is unreadable: $!\n";
return;
}
local $/ = undef;
my $pod = <$podfh>;
close($podfh) || die "Error closing $file: $!\n";
unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) {
warn "No POD in $file, skipping.\n"
if($verbose);
return 0;
}
return 1;
}
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
heavily borrowing code from Nick Ing-Simmons' PodToHtml.
Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided
C<pod_where> and C<contains_pod>.
B<Pod::Find> is part of the L<Pod::Parser> distribution.
=head1 SEE ALSO
L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
=cut
1;
PK Ѯ[��)�e� e� Text.pmnu �[��� # 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.006;
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.11';
# 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 {
if ($] ge 5.007_003) {
$NBSP = chr utf8::unicode_to_native(0xA0);
$SHY = chr utf8::unicode_to_native(0xAD);
} elsif (Pod::Simple::ASCII) {
$NBSP = "\xA0";
$SHY = "\xAD";
} else {
$NBSP = "\x41";
$SHY = "\xCA";
}
}
##############################################################################
# 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})\s+// || s/^([^\n]{$width})//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
# Reformat a paragraph of text for the current margin. Takes the text to
# reformat and returns the formatted text.
sub reformat {
my $self = shift;
local $_ = shift;
# If we're trying to preserve two spaces after sentences, do some munging
# to support that. Otherwise, smash all repeated whitespace.
if ($$self{opt_sentence}) {
s/ +$//mg;
s/\.\n/. \n/g;
s/\n/ /g;
s/ +/ /g;
} else {
s/\s+/ /g;
}
return $self->wrap ($_);
}
# Output text to the output device. Replace non-breaking spaces with spaces
# and soft hyphens with nothing, and then try to fix the output encoding if
# necessary to match the input encoding unless UTF-8 output is forced. This
# preserves the traditional pass-through behavior of Pod::Text.
sub output {
my ($self, @text) = @_;
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). Wrap the
# check in an eval to handle versions of Perl without PerlIO.
$$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 & 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.
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 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:
PK Ѯ[��` �� �� Simple.pmnu �[���
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.35';
@Known_formatting_codes = qw(I B C L E F S X Z);
%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
@Known_directives = qw(head1 head2 head3 head4 item over back);
%Known_directives = map(($_=>'Plain'), @Known_directives);
$NL = $/ unless defined $NL;
#-----------------------------------------------------------------------------
# Set up some constants:
BEGIN {
if(defined &ASCII) { }
elsif(chr(65) eq 'A') { *ASCII = sub () {1} }
else { *ASCII = sub () {''} }
unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
DEBUG > 4 and print 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(
'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
'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;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
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__ );
return bless {
'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) },
'accept_directives' => { %Known_directives },
'accept_targets' => {},
}, $class;
}
# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_element_start { # OVERRIDE IN DERIVED CLASS
my($self, $element_name, $attr_hash_r) = @_;
return;
}
sub _handle_element_end { # OVERRIDE IN DERIVED CLASS
my($self, $element_name) = @_;
return;
}
sub _handle_text { # OVERRIDE IN DERIVED CLASS
my($self, $text) = @_;
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now directives (not targets)
sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) }
sub accept_directive_as_data { shift->_accept_directives('Data', @_) }
sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) }
sub _accept_directives {
my($this, $type) = splice @_,0,2;
foreach my $d (@_) {
next unless defined $d and length $d;
Carp::croak "\"$d\" isn't a valid directive name"
unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
Carp::croak "\"$d\" is already a reserved Pod directive name"
if exists $Known_directives{$d};
$this->{'accept_directives'}{$d} = $type;
DEBUG > 2 and print 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 = eval "qr/[^-.0-8:A-Z_a-z[:^ascii:]]/";
if (! defined $xml_name_re) {
$xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/;
}
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->_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 $ell\n";
# bitch if it's empty
if( @{$ell} == 2
or (@{$ell} == 3 and $ell->[2] eq '')
) {
$self->whine( $start_line, "An empty L<>" );
$treelet->[$i] = 'L<>'; # just make it a text node
next; # and move on
}
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;
}
# Turn L<Foo Bar> into L</Foo Bar>.
if(!$section_name and !$link_text and @ell_content
and grep !ref($_) && m/ /s, @ell_content
) {
$section_name = [splice @ell_content];
# That's support for the now-deprecated syntax.
# (Maybe generate a warning eventually?)
# Note that it deliberately won't work on L<...|Foo Bar>
}
# Now make up the link_text
# L<Foo> -> L<Foo|Foo>
# L</Bar> -> L<"Bar"|Bar>
# L<Foo/Bar> -> L<"Bar" in Foo/Foo>
unless($link_text) {
$ell->[1]{'content-implicit'} = 'yes';
$link_text = [];
push @$link_text, '"', @$section_name, '"' if $section_name;
if(@ell_content) {
$link_text->[-1] .= ' in ' if $section_name;
push @$link_text, @ell_content;
}
}
# And the E resolver will have to deal with all our treeletty things:
if(@ell_content == 1 and !ref($ell_content[0])
and $ell_content[0] =~ m{^[^/]+[(][-a-zA-Z0-9]+[)]$}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 $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?
PK Ѯ[�b��E �E
Escapes.pmnu �[��� 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__
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PK Ѯ[{�7�zk zk InputObjects.pmnu �[��� #############################################################################
# Pod/InputObjects.pm -- package which defines objects for input streams
# and paragraphs and commands when parsing POD docs.
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::InputObjects;
use strict;
use vars qw($VERSION);
$VERSION = '1.63'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
=head1 NAME
Pod::InputObjects - objects representing POD input paragraphs, commands, etc.
=head1 SYNOPSIS
use Pod::InputObjects;
=head1 REQUIRES
perl5.004, Carp
=head1 EXPORTS
Nothing.
=head1 DESCRIPTION
B<NOTE: This module is considered legacy; modern Perl releases (5.18 and
higher) are going to remove Pod-Parser from core and use L<Pod-Simple>
for all things POD.>
This module defines some basic input objects used by B<Pod::Parser> when
reading and parsing POD text from an input source. The following objects
are defined:
=begin __PRIVATE__
=over 4
=item package B<Pod::InputSource>
An object corresponding to a source of POD input text. It is mostly a
wrapper around a filehandle or C<IO::Handle>-type object (or anything
that implements the C<getline()> method) which keeps track of some
additional information relevant to the parsing of PODs.
=back
=end __PRIVATE__
=over 4
=item package B<Pod::Paragraph>
An object corresponding to a paragraph of POD input text. It may be a
plain paragraph, a verbatim paragraph, or a command paragraph (see
L<perlpod>).
=item package B<Pod::InteriorSequence>
An object corresponding to an interior sequence command from the POD
input text (see L<perlpod>).
=item package B<Pod::ParseTree>
An object corresponding to a tree of parsed POD text. Each "node" in
a parse-tree (or I<ptree>) is either a text-string or a reference to
a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree
in the order in which they were parsed from left-to-right.
=back
Each of these input objects are described in further detail in the
sections which follow.
=cut
#############################################################################
package Pod::InputSource;
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<Pod::InputSource>
This object corresponds to an input source or stream of POD
documentation. When parsing PODs, it is necessary to associate and store
certain context information with each input source. All of this
information is kept together with the stream itself in one of these
C<Pod::InputSource> objects. Each such object is merely a wrapper around
an C<IO::Handle> object of some kind (or at least something that
implements the C<getline()> method). They have the following
methods/attributes:
=end __PRIVATE__
=cut
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<new()>
my $pod_input1 = Pod::InputSource->new(-handle => $filehandle);
my $pod_input2 = new Pod::InputSource(-handle => $filehandle,
-name => $name);
my $pod_input3 = new Pod::InputSource(-handle => \*STDIN);
my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN,
-name => "(STDIN)");
This is a class method that constructs a C<Pod::InputSource> object and
returns a reference to the new input source object. It takes one or more
keyword arguments in the form of a hash. The keyword C<-handle> is
required and designates the corresponding input handle. The keyword
C<-name> is optional and specifies the name associated with the input
handle (typically a file name).
=end __PRIVATE__
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object. Note that we default
## certain values by specifying them *before* the arguments passed.
## If they are in the argument list, they will override the defaults.
my $self = { -name => '(unknown)',
-handle => undef,
-was_cutting => 0,
@_ };
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<name()>
my $filename = $pod_input->name();
$pod_input->name($new_filename_to_use);
This method gets/sets the name of the input source (usually a filename).
If no argument is given, it returns a string containing the name of
the input source; otherwise it sets the name of the input source to the
contents of the given argument.
=end __PRIVATE__
=cut
sub name {
(@_ > 1) and $_[0]->{'-name'} = $_[1];
return $_[0]->{'-name'};
}
## allow 'filename' as an alias for 'name'
*filename = \&name;
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<handle()>
my $handle = $pod_input->handle();
Returns a reference to the handle object from which input is read (the
one used to contructed this input source object).
=end __PRIVATE__
=cut
sub handle {
return $_[0]->{'-handle'};
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<was_cutting()>
print "Yes.\n" if ($pod_input->was_cutting());
The value of the C<cutting> state (that the B<cutting()> method would
have returned) immediately before any input was read from this input
stream. After all input from this stream has been read, the C<cutting>
state is restored to this value.
=end __PRIVATE__
=cut
sub was_cutting {
(@_ > 1) and $_[0]->{-was_cutting} = $_[1];
return $_[0]->{-was_cutting};
}
##---------------------------------------------------------------------------
#############################################################################
package Pod::Paragraph;
##---------------------------------------------------------------------------
=head1 B<Pod::Paragraph>
An object representing a paragraph of POD input text.
It has the following methods/attributes:
=cut
##---------------------------------------------------------------------------
=head2 Pod::Paragraph-E<gt>B<new()>
my $pod_para1 = Pod::Paragraph->new(-text => $text);
my $pod_para2 = Pod::Paragraph->new(-name => $cmd,
-text => $text);
my $pod_para3 = new Pod::Paragraph(-text => $text);
my $pod_para4 = new Pod::Paragraph(-name => $cmd,
-text => $text);
my $pod_para5 = Pod::Paragraph->new(-name => $cmd,
-text => $text,
-file => $filename,
-line => $line_number);
This is a class method that constructs a C<Pod::Paragraph> object and
returns a reference to the new paragraph object. It may be given one or
two keyword arguments. The C<-text> keyword indicates the corresponding
text of the POD paragraph. The C<-name> keyword indicates the name of
the corresponding POD command, such as C<head1> or C<item> (it should
I<not> contain the C<=> prefix); this is needed only if the POD
paragraph corresponds to a command paragraph. The C<-file> and C<-line>
keywords indicate the filename and line number corresponding to the
beginning of the paragraph
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object. Note that we default
## certain values by specifying them *before* the arguments passed.
## If they are in the argument list, they will override the defaults.
my $self = {
-name => undef,
-text => (@_ == 1) ? shift : undef,
-file => '<unknown-file>',
-line => 0,
-prefix => '=',
-separator => ' ',
-ptree => [],
@_
};
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<cmd_name()>
my $para_cmd = $pod_para->cmd_name();
If this paragraph is a command paragraph, then this method will return
the name of the command (I<without> any leading C<=> prefix).
=cut
sub cmd_name {
(@_ > 1) and $_[0]->{'-name'} = $_[1];
return $_[0]->{'-name'};
}
## let name() be an alias for cmd_name()
*name = \&cmd_name;
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<text()>
my $para_text = $pod_para->text();
This method will return the corresponding text of the paragraph.
=cut
sub text {
(@_ > 1) and $_[0]->{'-text'} = $_[1];
return $_[0]->{'-text'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<raw_text()>
my $raw_pod_para = $pod_para->raw_text();
This method will return the I<raw> text of the POD paragraph, exactly
as it appeared in the input.
=cut
sub raw_text {
return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});
return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
$_[0]->{'-separator'} . $_[0]->{'-text'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<cmd_prefix()>
my $prefix = $pod_para->cmd_prefix();
If this paragraph is a command paragraph, then this method will return
the prefix used to denote the command (which should be the string "="
or "==").
=cut
sub cmd_prefix {
return $_[0]->{'-prefix'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<cmd_separator()>
my $separator = $pod_para->cmd_separator();
If this paragraph is a command paragraph, then this method will return
the text used to separate the command name from the rest of the
paragraph (if any).
=cut
sub cmd_separator {
return $_[0]->{'-separator'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<parse_tree()>
my $ptree = $pod_parser->parse_text( $pod_para->text() );
$pod_para->parse_tree( $ptree );
$ptree = $pod_para->parse_tree();
This method will get/set the corresponding parse-tree of the paragraph's text.
=cut
sub parse_tree {
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
}
## let ptree() be an alias for parse_tree()
*ptree = \&parse_tree;
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<file_line()>
my ($filename, $line_number) = $pod_para->file_line();
my $position = $pod_para->file_line();
Returns the current filename and line number for the paragraph
object. If called in a list context, it returns a list of two
elements: first the filename, then the line number. If called in
a scalar context, it returns a string containing the filename, followed
by a colon (':'), followed by the line number.
=cut
sub file_line {
my @loc = ($_[0]->{'-file'} || '<unknown-file>',
$_[0]->{'-line'} || 0);
return (wantarray) ? @loc : join(':', @loc);
}
##---------------------------------------------------------------------------
#############################################################################
package Pod::InteriorSequence;
##---------------------------------------------------------------------------
=head1 B<Pod::InteriorSequence>
An object representing a POD interior sequence command.
It has the following methods/attributes:
=cut
##---------------------------------------------------------------------------
=head2 Pod::InteriorSequence-E<gt>B<new()>
my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd
-ldelim => $delimiter);
my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd,
-ldelim => $delimiter);
my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd,
-ldelim => $delimiter,
-file => $filename,
-line => $line_number);
my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree);
my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree);
This is a class method that constructs a C<Pod::InteriorSequence> object
and returns a reference to the new interior sequence object. It should
be given two keyword arguments. The C<-ldelim> keyword indicates the
corresponding left-delimiter of the interior sequence (e.g. 'E<lt>').
The C<-name> keyword indicates the name of the corresponding interior
sequence command, such as C<I> or C<B> or C<C>. The C<-file> and
C<-line> keywords indicate the filename and line number corresponding
to the beginning of the interior sequence. If the C<$ptree> argument is
given, it must be the last argument, and it must be either string, or
else an array-ref suitable for passing to B<Pod::ParseTree::new> (or
it may be a reference to a Pod::ParseTree object).
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
## See if first argument has no keyword
if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) {
## Yup - need an implicit '-name' before first parameter
unshift @_, '-name';
}
## See if odd number of args
if ((@_ % 2) != 0) {
## Yup - need an implicit '-ptree' before the last parameter
splice @_, $#_, 0, '-ptree';
}
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object. Note that we default
## certain values by specifying them *before* the arguments passed.
## If they are in the argument list, they will override the defaults.
my $self = {
-name => (@_ == 1) ? $_[0] : undef,
-file => '<unknown-file>',
-line => 0,
-ldelim => '<',
-rdelim => '>',
@_
};
## Initialize contents if they haven't been already
my $ptree = $self->{'-ptree'} || new Pod::ParseTree();
if ( ref $ptree =~ /^(ARRAY)?$/ ) {
## We have an array-ref, or a normal scalar. Pass it as an
## an argument to the ptree-constructor
$ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree);
}
$self->{'-ptree'} = $ptree;
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<cmd_name()>
my $seq_cmd = $pod_seq->cmd_name();
The name of the interior sequence command.
=cut
sub cmd_name {
(@_ > 1) and $_[0]->{'-name'} = $_[1];
return $_[0]->{'-name'};
}
## let name() be an alias for cmd_name()
*name = \&cmd_name;
##---------------------------------------------------------------------------
## Private subroutine to set the parent pointer of all the given
## children that are interior-sequences to be $self
sub _set_child2parent_links {
my ($self, @children) = @_;
## Make sure any sequences know who their parent is
for (@children) {
next unless (length and ref and ref ne 'SCALAR');
if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or
UNIVERSAL::can($_, 'nested'))
{
$_->nested($self);
}
}
}
## Private subroutine to unset child->parent links
sub _unset_child2parent_links {
my $self = shift;
$self->{'-parent_sequence'} = undef;
my $ptree = $self->{'-ptree'};
for (@$ptree) {
next unless (length and ref and ref ne 'SCALAR');
$_->_unset_child2parent_links()
if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
}
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<prepend()>
$pod_seq->prepend($text);
$pod_seq1->prepend($pod_seq2);
Prepends the given string or parse-tree or sequence object to the parse-tree
of this interior sequence.
=cut
sub prepend {
my $self = shift;
$self->{'-ptree'}->prepend(@_);
_set_child2parent_links($self, @_);
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<append()>
$pod_seq->append($text);
$pod_seq1->append($pod_seq2);
Appends the given string or parse-tree or sequence object to the parse-tree
of this interior sequence.
=cut
sub append {
my $self = shift;
$self->{'-ptree'}->append(@_);
_set_child2parent_links($self, @_);
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<nested()>
$outer_seq = $pod_seq->nested || print "not nested";
If this interior sequence is nested inside of another interior
sequence, then the outer/parent sequence that contains it is
returned. Otherwise C<undef> is returned.
=cut
sub nested {
my $self = shift;
(@_ == 1) and $self->{'-parent_sequence'} = shift;
return $self->{'-parent_sequence'} || undef;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<raw_text()>
my $seq_raw_text = $pod_seq->raw_text();
This method will return the I<raw> text of the POD interior sequence,
exactly as it appeared in the input.
=cut
sub raw_text {
my $self = shift;
my $text = $self->{'-name'} . $self->{'-ldelim'};
for ( $self->{'-ptree'}->children ) {
$text .= (ref $_) ? $_->raw_text : $_;
}
$text .= $self->{'-rdelim'};
return $text;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<left_delimiter()>
my $ldelim = $pod_seq->left_delimiter();
The leftmost delimiter beginning the argument text to the interior
sequence (should be "<").
=cut
sub left_delimiter {
(@_ > 1) and $_[0]->{'-ldelim'} = $_[1];
return $_[0]->{'-ldelim'};
}
## let ldelim() be an alias for left_delimiter()
*ldelim = \&left_delimiter;
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<right_delimiter()>
The rightmost delimiter beginning the argument text to the interior
sequence (should be ">").
=cut
sub right_delimiter {
(@_ > 1) and $_[0]->{'-rdelim'} = $_[1];
return $_[0]->{'-rdelim'};
}
## let rdelim() be an alias for right_delimiter()
*rdelim = \&right_delimiter;
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<parse_tree()>
my $ptree = $pod_parser->parse_text($paragraph_text);
$pod_seq->parse_tree( $ptree );
$ptree = $pod_seq->parse_tree();
This method will get/set the corresponding parse-tree of the interior
sequence's text.
=cut
sub parse_tree {
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
}
## let ptree() be an alias for parse_tree()
*ptree = \&parse_tree;
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<file_line()>
my ($filename, $line_number) = $pod_seq->file_line();
my $position = $pod_seq->file_line();
Returns the current filename and line number for the interior sequence
object. If called in a list context, it returns a list of two
elements: first the filename, then the line number. If called in
a scalar context, it returns a string containing the filename, followed
by a colon (':'), followed by the line number.
=cut
sub file_line {
my @loc = ($_[0]->{'-file'} || '<unknown-file>',
$_[0]->{'-line'} || 0);
return (wantarray) ? @loc : join(':', @loc);
}
##---------------------------------------------------------------------------
=head2 Pod::InteriorSequence::B<DESTROY()>
This method performs any necessary cleanup for the interior-sequence.
If you override this method then it is B<imperative> that you invoke
the parent method from within your own method, otherwise
I<interior-sequence storage will not be reclaimed upon destruction!>
=cut
sub DESTROY {
## We need to get rid of all child->parent pointers throughout the
## tree so their reference counts will go to zero and they can be
## garbage-collected
_unset_child2parent_links(@_);
}
##---------------------------------------------------------------------------
#############################################################################
package Pod::ParseTree;
##---------------------------------------------------------------------------
=head1 B<Pod::ParseTree>
This object corresponds to a tree of parsed POD text. As POD text is
scanned from left to right, it is parsed into an ordered list of
text-strings and B<Pod::InteriorSequence> objects (in order of
appearance). A B<Pod::ParseTree> object corresponds to this list of
strings and sequences. Each interior sequence in the parse-tree may
itself contain a parse-tree (since interior sequences may be nested).
=cut
##---------------------------------------------------------------------------
=head2 Pod::ParseTree-E<gt>B<new()>
my $ptree1 = Pod::ParseTree->new;
my $ptree2 = new Pod::ParseTree;
my $ptree4 = Pod::ParseTree->new($array_ref);
my $ptree3 = new Pod::ParseTree($array_ref);
This is a class method that constructs a C<Pod::Parse_tree> object and
returns a reference to the new parse-tree. If a single-argument is given,
it must be a reference to an array, and is used to initialize the root
(top) of the parse tree.
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
my $self = (@_ == 1 and ref $_[0]) ? $_[0] : [];
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<top()>
my $top_node = $ptree->top();
$ptree->top( $top_node );
$ptree->top( @children );
This method gets/sets the top node of the parse-tree. If no arguments are
given, it returns the topmost node in the tree (the root), which is also
a B<Pod::ParseTree>. If it is given a single argument that is a reference,
then the reference is assumed to a parse-tree and becomes the new top node.
Otherwise, if arguments are given, they are treated as the new list of
children for the top node.
=cut
sub top {
my $self = shift;
if (@_ > 0) {
@{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
}
return $self;
}
## let parse_tree() & ptree() be aliases for the 'top' method
*parse_tree = *ptree = \⊤
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<children()>
This method gets/sets the children of the top node in the parse-tree.
If no arguments are given, it returns the list (array) of children
(each of which should be either a string or a B<Pod::InteriorSequence>.
Otherwise, if arguments are given, they are treated as the new list of
children for the top node.
=cut
sub children {
my $self = shift;
if (@_ > 0) {
@{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
}
return @{ $self };
}
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<prepend()>
This method prepends the given text or parse-tree to the current parse-tree.
If the first item on the parse-tree is text and the argument is also text,
then the text is prepended to the first item (not added as a separate string).
Otherwise the argument is added as a new string or parse-tree I<before>
the current one.
=cut
use vars qw(@ptree); ## an alias used for performance reasons
sub prepend {
my $self = shift;
local *ptree = $self;
for (@_) {
next unless length;
if (@ptree && !(ref $ptree[0]) && !(ref $_)) {
$ptree[0] = $_ . $ptree[0];
}
else {
unshift @ptree, $_;
}
}
}
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<append()>
This method appends the given text or parse-tree to the current parse-tree.
If the last item on the parse-tree is text and the argument is also text,
then the text is appended to the last item (not added as a separate string).
Otherwise the argument is added as a new string or parse-tree I<after>
the current one.
=cut
sub append {
my $self = shift;
local *ptree = $self;
my $can_append = @ptree && !(ref $ptree[-1]);
for (@_) {
if (ref) {
push @ptree, $_;
}
elsif(!length) {
next;
}
elsif ($can_append) {
$ptree[-1] .= $_;
}
else {
push @ptree, $_;
}
}
}
=head2 $ptree-E<gt>B<raw_text()>
my $ptree_raw_text = $ptree->raw_text();
This method will return the I<raw> text of the POD parse-tree
exactly as it appeared in the input.
=cut
sub raw_text {
my $self = shift;
my $text = '';
for ( @$self ) {
$text .= (ref $_) ? $_->raw_text : $_;
}
return $text;
}
##---------------------------------------------------------------------------
## Private routines to set/unset child->parent links
sub _unset_child2parent_links {
my $self = shift;
local *ptree = $self;
for (@ptree) {
next unless (defined and length and ref and ref ne 'SCALAR');
$_->_unset_child2parent_links()
if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
}
}
sub _set_child2parent_links {
## nothing to do, Pod::ParseTrees cant have parent pointers
}
=head2 Pod::ParseTree::B<DESTROY()>
This method performs any necessary cleanup for the parse-tree.
If you override this method then it is B<imperative>
that you invoke the parent method from within your own method,
otherwise I<parse-tree storage will not be reclaimed upon destruction!>
=cut
sub DESTROY {
## We need to get rid of all child->parent pointers throughout the
## tree so their reference counts will go to zero and they can be
## garbage-collected
_unset_child2parent_links(@_);
}
#############################################################################
=head1 SEE ALSO
B<Pod::InputObjects> is part of the L<Pod::Parser> distribution.
See L<Pod::Parser>, L<Pod::Select>
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt>
=cut
1;
PK Ѯ[���N� N�
Perldoc.pmnu �[��� 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.28';
#..........................................................................
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');
$self->opt_o_with('term')
unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos
|| !($ENV{TERM} && (
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
));
return;
}
#..........................................................................
sub process {
# if this ever returns, its retval will be used for exit(RETVAL)
my $self = shift;
DEBUG > 1 and print " Beginning process.\n";
DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
if(DEBUG > 3) {
print "Object contents:\n";
my @x = %$self;
while(@x) {
$x[1] = '<undef>' unless defined $x[1];
$x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
print " [$x[0]] => [$x[1]]\n";
splice @x,0,2;
}
print "\n";
}
# TODO: make it deal with being invoked as various different things
# such as perlfaq".
return $self->usage_brief unless @{ $self->{'args'} };
$self->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;
}
#..........................................................................
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_line;
my $push = 0;
my $seen_item = 0;
my $skip = 1;
while( my $line = <$fh> ) {
$line =~ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
# only start search after we hit the operator section
if ($line =~ m!^X<operator, regexp>!) {
$skip = 0;
}
next if $skip;
# strategy is to capture the previous line until we get a match on X<$thingy>
# if the current line contains X<$thingy>, then we push "=over", the previous line,
# the current line and keep pushing current line until we see a ^X<some-other-thing>,
# then we chop off final line from @$pod and add =back
#
# At that point, Bob's your uncle.
if ( $line =~ m!X<+\s*\Q$thing\E\s*>+!) {
if ( $previous_line ) {
push @$pod, "=over 8\n\n", $previous_line;
$previous_line = "";
}
push @$pod, $line;
$push = 1;
}
elsif ( $push and $line =~ m!^=item\s*.*$! ) {
$seen_item = 1;
}
elsif ( $push and $seen_item and $line =~ m!^X<+\s*[ a-z,?-]+\s*>+!) {
$push = 0;
$seen_item = 0;
last;
}
elsif ( $push ) {
push @$pod, $line;
}
else {
$previous_line = $line;
}
} #end while
# we overfilled by 1 line, so pop off final array element if we have any
if ( scalar @$pod ) {
pop @$pod;
# and add the =back
push @$pod, "\n\n=back\n";
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 {
my $formatter = $self->{'formatter_class'};
if ( $formatter->can('pager_configuration') ) {
$self->aside("About to call $formatter" . "->pager_configuration(\"$pager\")\n");
$formatter->pager_configuration($pager, $self);
}
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
PK 07�Z����G_ G_ Html.pmnu �[��� PK 07�Z�U� 8 8 ~_ Functions.pmnu �[��� PK Į[�b�_ �_ ؗ Select.pmnu �[��� PK Ʈ[�m�� � � Simple/Transcode.pmnu �[��� PK Ʈ[��f� � � Simple/Subclassing.podnu �[��� PK Ʈ[�?GK�
�
B} Simple/TiedOutFH.pmnu �[��� PK Ʈ[o��� � D� Simple/LinkSection.pmnu �[��� PK Ʈ[�h��� � �� Simple/TranscodeSmart.pmnu �[��� PK Ʈ[�U<�� � �� Simple/DumpAsText.pmnu �[��� PK Ʈ[����W �W
�� Simple/RTF.pmnu �[��� PK Ǯ[���d �d � Simple/PullParser.pmnu �[��� PK Ǯ[sҩs�
�
qi Simple/TranscodeDumb.pmnu �[��� PK Ǯ[�n]: : =t Simple/XMLOutStream.pmnu �[��� PK Ȯ[IT�� � �� Simple/Checker.pmnu �[��� PK Ȯ[Զs?6� 6� ٛ Simple/HTML.pmnu �[��� PK Ȯ[�
Qi2 2 M# Simple/PullParserStartToken.pmnu �[��� PK ɮ[�E�V�
�
�3 Simple/HTMLLegacy.pmnu �[��� PK ɮ[�<SD D �> Simple/PullParserEndToken.pmnu �[��� PK ɮ[��p �
�
gJ Simple/Methody.pmnu �[��� PK ɮ[�7wͤ � �X Simple/PullParserToken.pmnu �[��� PK ɮ[��%� g g �h Simple/XHTML.pmnu �[��� PK ɮ[ B��� � �� Simple/TextContent.pmnu �[��� PK ɮ[E�L� � � Simple/Text.pmnu �[��� PK ɮ[���М М /� Simple/HTMLBatch.pmnu �[��� PK ɮ[�tbP B� Simple/SimpleTree.pmnu �[��� PK ɮ[z/�� � �� Simple/BlackBox.pmnu �[��� PK ɮ[���n v� Simple/Debug.pmnu �[��� PK ɮ[�ɏ�#
#
�� Simple/PullParserTextToken.pmnu �[��� PK ɮ[�Y>$� $� 6� Simple/Search.pmnu �[��� PK ɮ[4��]m m �b Simple/Progress.pmnu �[��� PK ɮ[D� I� � Il Simple/DumpAsXML.pmnu �[��� PK ʮ[L�ֿ/t /t \~ Usage.pmnu �[��� PK ʮ[pJ�7: :
�� Text/Color.pmnu �[��� PK ͮ[��SJn n : Text/Overstrike.pmnu �[��� PK Ю[�����! �! �# Text/Termcap.pmnu �[��� PK Ю[���� � F Parser.pmnu �[��� PK Ю[��,j�~ �~
'G Checker.pmnu �[��� PK Ю[ ����7 �7 S� Man.pmnu �[��� PK Ю[:���c �c l� PlainText.pmnu �[��� PK Ю[ʝ0Œ7 �7
�b
Simple.podnu �[��� PK Ю[ ��� � d�
ParseLink.pmnu �[��� PK Ю[�f;9�R �R
��
ParseUtils.pmnu �[��� PK Ю[��� � Perldoc/ToXml.pmnu �[��� PK Ю[~|0^� � M Perldoc/ToTerm.pmnu �[��� PK Ю[��%�0 0 v Perldoc/GetOptsOO.pmnu �[��� PK Ю[5���� � �* Perldoc/ToText.pmnu �[��� PK Ѯ[kޛ � 4 Perldoc/ToChecker.pmnu �[��� PK Ѯ[p�!b� � �: Perldoc/ToTk.pmnu �[��� PK Ѯ[� ��� � �J Perldoc/ToPod.pmnu �[��� PK Ѯ[j�v�7 �7 �R Perldoc/ToMan.pmnu �[��� PK Ѯ[�mV!� � �� Perldoc/ToANSI.pmnu �[��� PK Ѯ[Y2��5 5 ғ Perldoc/BaseTo.pmnu �[��� PK Ѯ[`#�ke e H� Perldoc/ToRtf.pmnu �[��� PK Ѯ[_���
�
� Perldoc/ToNroff.pmnu �[��� PK Ѯ[�_���= �=
� Find.pmnu �[��� PK Ѯ[��)�e� e� � Text.pmnu �[��� PK Ѯ[��` �� �� �� Simple.pmnu �[��� PK Ѯ[�b��E �E
�U
Escapes.pmnu �[��� PK Ѯ[{�7�zk zk ��
InputObjects.pmnu �[��� PK Ѯ[���N� N�
a Perldoc.pmnu �[��� PK < < � �