| Server IP : 170.10.162.208 / Your IP : 216.73.216.181 Web Server : LiteSpeed System : Linux altar19.supremepanel19.com 4.18.0-553.69.1.lve.el8.x86_64 #1 SMP Wed Aug 13 19:53:59 UTC 2025 x86_64 User : deltahospital ( 1806) PHP Version : 7.4.33 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : ON | Sudo : OFF | Pkexec : OFF Directory : /home/deltahospital/.cagefs/tmp/ |
Upload File : |
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
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
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
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
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
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
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
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
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
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
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
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
# 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:
#############################################################################
# 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
#############################################################################
# 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
# 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