#############################################################################
package Pod::Usage;
+use strict;
-use vars qw($VERSION);
-$VERSION = "1.33_01"; ## Current version of this package
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '1.36'; ## Current version of this package
require 5.005; ## requires this Perl version or later
=head1 NAME
A string representing a selection list for sections to be printed
when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
+Alternatively, an array reference of section specifications can be used:
+
+ pod2usage(-verbose => 99,
+ -sections => [ qw(fred fred/subsection) ] );
+
=item C<-output>
A reference to a filehandle, or the pathname of a file to which the
invoking script's pod documentation should be read. It defaults to the
file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
+If you are calling B<pod2usage()> from a module and want to display
+that module's POD, you can use this:
+
+ use Pod::Find qw(pod_where);
+ pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
+
=item C<-pathlist>
A list of directory paths. If the input file does not exist, then it
Please report bugs using L<http://rt.cpan.org>.
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<Pod::Text::pod2text()> written by
Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience
with re-writing this manpage.
+=head1 SEE ALSO
+
+L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find>
+
=cut
#############################################################################
-use strict;
#use diagnostics;
use Carp;
use Config;
use Exporter;
use File::Spec;
-use vars qw(@ISA @EXPORT);
@EXPORT = qw(&pod2usage);
BEGIN {
if ( $] >= 5.005_58 ) {
}
}
+require Pod::Select;
##---------------------------------------------------------------------------
%opts = ($_, @_);
}
elsif (!defined $_) {
- $_ = "";
+ $_ = '';
}
elsif (ref $_) {
## User passed a ref to a hash
}
elsif (/^[-+]?\d+$/) {
## User passed in the exit value to use
- $opts{"-exitval"} = $_;
+ $opts{'-exitval'} = $_;
}
else {
## User passed in a message to print before issuing usage.
- $_ and $opts{"-message"} = $_;
+ $_ and $opts{'-message'} = $_;
}
## Need this for backward compatibility since we formerly used
## looked like Unix command-line options.
## to be uppercase keywords)
%opts = map {
- my $val = $opts{$_};
- s/^(?=\w)/-/;
- /^-msg/i and $_ = '-message';
- /^-exit/i and $_ = '-exitval';
- lc($_) => $val;
+ my ($key, $val) = ($_, $opts{$_});
+ $key =~ s/^(?=\w)/-/;
+ $key =~ /^-msg/i and $key = '-message';
+ $key =~ /^-exit/i and $key = '-exitval';
+ lc($key) => $val;
} (keys %opts);
## Now determine default -exitval and -verbose values to use
- if ((! defined $opts{"-exitval"}) && (! defined $opts{"-verbose"})) {
- $opts{"-exitval"} = 2;
- $opts{"-verbose"} = 0;
+ if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
+ $opts{'-exitval'} = 2;
+ $opts{'-verbose'} = 0;
}
- elsif (! defined $opts{"-exitval"}) {
- $opts{"-exitval"} = ($opts{"-verbose"} > 0) ? 1 : 2;
+ elsif (! defined $opts{'-exitval'}) {
+ $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
}
- elsif (! defined $opts{"-verbose"}) {
- $opts{"-verbose"} = (lc($opts{"-exitval"}) eq "noexit" ||
- $opts{"-exitval"} < 2);
+ elsif (! defined $opts{'-verbose'}) {
+ $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
+ $opts{'-exitval'} < 2);
}
## Default the output file
- $opts{"-output"} = (lc($opts{"-exitval"}) eq "noexit" ||
- $opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR
- unless (defined $opts{"-output"});
+ $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
+ $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
+ unless (defined $opts{'-output'});
## Default the input file
- $opts{"-input"} = $0 unless (defined $opts{"-input"});
+ $opts{'-input'} = $0 unless (defined $opts{'-input'});
## Look up input file in path if it doesnt exist.
- unless ((ref $opts{"-input"}) || (-e $opts{"-input"})) {
- my ($dirname, $basename) = ('', $opts{"-input"});
- my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/) ? ";"
- : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ":");
- my $pathspec = $opts{"-pathlist"} || $ENV{PATH} || $ENV{PERL5LIB};
+ unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
+ my $basename = $opts{'-input'};
+ my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
+ : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':');
+ my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
- for $dirname (@paths) {
+ for my $dirname (@paths) {
$_ = File::Spec->catfile($dirname, $basename) if length;
- last if (-e $_) && ($opts{"-input"} = $_);
+ last if (-e $_) && ($opts{'-input'} = $_);
}
}
## Now create a pod reader and constrain it to the desired sections.
my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
- if ($opts{"-verbose"} == 0) {
- $parser->select('SYNOPSIS\s*');
+ if ($opts{'-verbose'} == 0) {
+ $parser->select('(?:SYNOPSIS|USAGE)\s*');
}
- elsif ($opts{"-verbose"} == 1) {
+ elsif ($opts{'-verbose'} == 1) {
my $opt_re = '(?i)' .
'(?:OPTIONS|ARGUMENTS)' .
'(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
- $parser->select( 'SYNOPSIS', $opt_re, "DESCRIPTION/$opt_re" );
- }
- elsif ($opts{"-verbose"} >= 2 && $opts{"-verbose"} != 99) {
- $parser->select('.*');
+ $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
}
- elsif ($opts{"-verbose"} >= 2 && $opts{"-verbose"} != 99) {
+ elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
$parser->select('.*');
}
- elsif ($opts{"-verbose"} == 99) {
- $parser->select( $opts{"-sections"} );
- $opts{"-verbose"} = 1;
+ elsif ($opts{'-verbose'} == 99) {
+ my $sections = $opts{'-sections'};
+ $parser->select( (ref $sections) ? @$sections : $sections );
+ $opts{'-verbose'} = 1;
}
## Now translate the pod document and then exit with the desired status
- if ( !$opts{"-noperldoc"}
- and $opts{"-verbose"} >= 2
- and !ref($opts{"-input"})
- and $opts{"-output"} == \*STDOUT )
+ if ( !$opts{'-noperldoc'}
+ and $opts{'-verbose'} >= 2
+ and !ref($opts{'-input'})
+ and $opts{'-output'} == \*STDOUT )
{
## spit out the entire PODs. Might as well invoke perldoc
- my $progpath = File::Spec->catfile($Config{scriptdir}, "perldoc");
- system($progpath, $opts{"-input"});
- if($?) {
- # RT16091: fall back to more if perldoc failed
- system($ENV{PAGER} || 'more', $opts{"-input"});
+ my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc');
+ print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
+ if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
+ # the perldocs back to 5.005 should all have -F
+ # without -F there are warnings in -T scripts
+ system($progpath, '-F', $1);
+ if($?) {
+ # RT16091: fall back to more if perldoc failed
+ system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
+ }
+ } else {
+ croak "Unspecified input file or insecure argument.\n";
}
}
else {
- $parser->parse_from_file($opts{"-input"}, $opts{"-output"});
+ $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
}
- exit($opts{"-exitval"}) unless (lc($opts{"-exitval"}) eq 'noexit');
+ exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
}
##---------------------------------------------------------------------------
}
sub select {
- my ($self, @res) = @_;
+ my ($self, @sections) = @_;
if ($ISA[0]->can('select')) {
- $self->SUPER::select(@_);
+ $self->SUPER::select(@sections);
} else {
- $self->{USAGE_SELECT} = \@res;
+ # we're using Pod::Simple - need to mimic the behavior of Pod::Select
+ my $add = ($sections[0] eq '+') ? shift(@sections) : '';
+ ## Reset the set of sections to use
+ unless (@sections) {
+ delete $self->{USAGE_SELECT} unless ($add);
+ return;
+ }
+ $self->{USAGE_SELECT} = []
+ unless ($add && $self->{USAGE_SELECT});
+ my $sref = $self->{USAGE_SELECT};
+ ## Compile each spec
+ for my $spec (@sections) {
+ my $cs = Pod::Select::_compile_section_spec($spec);
+ if ( defined $cs ) {
+ ## Store them in our sections array
+ push(@$sref, $cs);
+ } else {
+ carp qq{Ignoring section spec "$spec"!\n};
+ }
+ }
}
}
sub _handle_element_end {
my ($self, $element) = @_;
if ($element eq 'head1') {
- $$self{USAGE_HEAD1} = $$self{PENDING}[-1][1];
+ $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
$$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
}
- } elsif ($element eq 'head2') {
- $$self{USAGE_HEAD2} = $$self{PENDING}[-1][1];
+ } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
+ my $idx = $1 - 1;
+ $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
+ $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
}
- if ($element eq 'head1' || $element eq 'head2') {
+ if ($element =~ /^head\d+$/) {
$$self{USAGE_SKIPPING} = 1;
- my $heading = $$self{USAGE_HEAD1};
- $heading .= '/' . $$self{USAGE_HEAD2} if defined $$self{USAGE_HEAD2};
- for (@{ $$self{USAGE_SELECT} }) {
- if ($heading =~ /^$_\s*$/) {
- $$self{USAGE_SKIPPING} = 0;
- last;
- }
+ if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
+ $$self{USAGE_SKIPPING} = 0;
+ } else {
+ my @headings = @{$$self{USAGE_HEADINGS}};
+ for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
+ my $match = 1;
+ for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) {
+ $headings[$i] = '' unless defined $headings[$i];
+ my $regex = $section_spec->[$i];
+ my $negated = ($regex =~ s/^\!//);
+ $match &= ($negated ? ($headings[$i] !~ /${regex}/)
+ : ($headings[$i] =~ /${regex}/));
+ last unless ($match);
+ } # end heading levels
+ if ($match) {
+ $$self{USAGE_SKIPPING} = 0;
+ last;
+ }
+ } # end sections
}
# Try to do some lowercasing instead of all-caps in headings, and use
$$self{PENDING}[-1][1] = $_;
}
}
- if ($$self{USAGE_SKIPPING}) {
+ if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) {
pop @{ $$self{PENDING} };
} else {
$self->SUPER::_handle_element_end($element);
}
}
+# required for Pod::Simple API
sub start_document {
my $self = shift;
$self->SUPER::start_document();
print $out_fh "$msg\n";
}
+# required for old Pod::Parser API
sub begin_pod {
my $self = shift;
$self->SUPER::begin_pod(); ## Have to call superclass
https://perl5.git.perl.org / perl5.git / blobdiff