| ############################################################################# |
| # Pod/Usage.pm -- print usage messages for the running script. |
| # |
| # Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. |
| # This file is part of "PodParser". PodParser is free software; |
| # you can redistribute it and/or modify it under the same terms |
| # as Perl itself. |
| ############################################################################# |
| |
| package Pod::Usage; |
| use strict; |
| |
| use vars qw($VERSION @ISA @EXPORT); |
| $VERSION = '1.51'; ## Current version of this package |
| require 5.005; ## requires this Perl version or later |
| |
| =head1 NAME |
| |
| Pod::Usage, pod2usage() - print a usage message from embedded pod documentation |
| |
| =head1 SYNOPSIS |
| |
| use Pod::Usage |
| |
| my $message_text = "This text precedes the usage message."; |
| my $exit_status = 2; ## The exit status to use |
| my $verbose_level = 0; ## The verbose level to use |
| my $filehandle = \*STDERR; ## The filehandle to write to |
| |
| pod2usage($message_text); |
| |
| pod2usage($exit_status); |
| |
| pod2usage( { -message => $message_text , |
| -exitval => $exit_status , |
| -verbose => $verbose_level, |
| -output => $filehandle } ); |
| |
| pod2usage( -msg => $message_text , |
| -exitval => $exit_status , |
| -verbose => $verbose_level, |
| -output => $filehandle ); |
| |
| pod2usage( -verbose => 2, |
| -noperldoc => 1 ) |
| |
| =head1 ARGUMENTS |
| |
| B<pod2usage> should be given either a single argument, or a list of |
| arguments corresponding to an associative array (a "hash"). When a single |
| argument is given, it should correspond to exactly one of the following: |
| |
| =over 4 |
| |
| =item * |
| |
| A string containing the text of a message to print I<before> printing |
| the usage message |
| |
| =item * |
| |
| A numeric value corresponding to the desired exit status |
| |
| =item * |
| |
| A reference to a hash |
| |
| =back |
| |
| If more than one argument is given then the entire argument list is |
| assumed to be a hash. If a hash is supplied (either as a reference or |
| as a list) it should contain one or more elements with the following |
| keys: |
| |
| =over 4 |
| |
| =item C<-message> |
| |
| =item C<-msg> |
| |
| The text of a message to print immediately prior to printing the |
| program's usage message. |
| |
| =item C<-exitval> |
| |
| The desired exit status to pass to the B<exit()> function. |
| This should be an integer, or else the string "NOEXIT" to |
| indicate that control should simply be returned without |
| terminating the invoking process. |
| |
| =item C<-verbose> |
| |
| The desired level of "verboseness" to use when printing the usage |
| message. If the corresponding value is 0, then only the "SYNOPSIS" |
| section of the pod documentation is printed. If the corresponding value |
| is 1, then the "SYNOPSIS" section, along with any section entitled |
| "OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the |
| corresponding value is 2 or more then the entire manpage is printed. |
| |
| The special verbosity level 99 requires to also specify the -sections |
| parameter; then these sections are extracted (see L<Pod::Select>) |
| and printed. |
| |
| =item C<-sections> |
| |
| A string representing a selection list for sections to be printed |
| when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. |
| |
| Alternatively, an array reference of section specifications can be used: |
| |
| pod2usage(-verbose => 99, |
| -sections => [ qw(fred fred/subsection) ] ); |
| |
| =item C<-output> |
| |
| A reference to a filehandle, or the pathname of a file to which the |
| usage message should be written. The default is C<\*STDERR> unless the |
| exit value is less than 2 (in which case the default is C<\*STDOUT>). |
| |
| =item C<-input> |
| |
| A reference to a filehandle, or the pathname of a file from which the |
| invoking script's pod documentation should be read. It defaults to the |
| file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>). |
| |
| If you are calling B<pod2usage()> from a module and want to display |
| that module's POD, you can use this: |
| |
| use Pod::Find qw(pod_where); |
| pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) ); |
| |
| =item C<-pathlist> |
| |
| A list of directory paths. If the input file does not exist, then it |
| will be searched for in the given directory list (in the order the |
| directories appear in the list). It defaults to the list of directories |
| implied by C<$ENV{PATH}>. The list may be specified either by a reference |
| to an array, or by a string of directory paths which use the same path |
| separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for |
| MSWin32 and DOS). |
| |
| =item C<-noperldoc> |
| |
| By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is |
| specified. This does not work well e.g. if the script was packed |
| with L<PAR>. The -noperldoc option suppresses the external call to |
| L<perldoc> and uses the simple text formatter (L<Pod::Text>) to |
| output the POD. |
| |
| =back |
| |
| =head2 Pass-through options |
| |
| The following options are passed through to the underlying text formatter |
| (L<Pod::Text> or L<Pod::PlainText> for Perl versions E<lt> 5.005_58). See |
| the manual pages of these modules for more information. |
| |
| alt code indent loose margin quotes sentence stderr utf8 width |
| |
| =head1 DESCRIPTION |
| |
| B<pod2usage> will print a usage message for the invoking script (using |
| its embedded pod documentation) and then exit the script with the |
| desired exit status. The usage message printed may have any one of three |
| levels of "verboseness": If the verbose level is 0, then only a synopsis |
| is printed. If the verbose level is 1, then the synopsis is printed |
| along with a description (if present) of the command line options and |
| arguments. If the verbose level is 2, then the entire manual page is |
| printed. |
| |
| Unless they are explicitly specified, the default values for the exit |
| status, verbose level, and output stream to use are determined as |
| follows: |
| |
| =over 4 |
| |
| =item * |
| |
| If neither the exit status nor the verbose level is specified, then the |
| default is to use an exit status of 2 with a verbose level of 0. |
| |
| =item * |
| |
| If an exit status I<is> specified but the verbose level is I<not>, then the |
| verbose level will default to 1 if the exit status is less than 2 and |
| will default to 0 otherwise. |
| |
| =item * |
| |
| If an exit status is I<not> specified but verbose level I<is> given, then |
| the exit status will default to 2 if the verbose level is 0 and will |
| default to 1 otherwise. |
| |
| =item * |
| |
| If the exit status used is less than 2, then output is printed on |
| C<STDOUT>. Otherwise output is printed on C<STDERR>. |
| |
| =back |
| |
| Although the above may seem a bit confusing at first, it generally does |
| "the right thing" in most situations. This determination of the default |
| values to use is based upon the following typical Unix conventions: |
| |
| =over 4 |
| |
| =item * |
| |
| An exit status of 0 implies "success". For example, B<diff(1)> exits |
| with a status of 0 if the two files have the same contents. |
| |
| =item * |
| |
| An exit status of 1 implies possibly abnormal, but non-defective, program |
| termination. For example, B<grep(1)> exits with a status of 1 if |
| it did I<not> find a matching line for the given regular expression. |
| |
| =item * |
| |
| An exit status of 2 or more implies a fatal error. For example, B<ls(1)> |
| exits with a status of 2 if you specify an illegal (unknown) option on |
| the command line. |
| |
| =item * |
| |
| Usage messages issued as a result of bad command-line syntax should go |
| to C<STDERR>. However, usage messages issued due to an explicit request |
| to print usage (like specifying B<-help> on the command line) should go |
| to C<STDOUT>, just in case the user wants to pipe the output to a pager |
| (such as B<more(1)>). |
| |
| =item * |
| |
| If program usage has been explicitly requested by the user, it is often |
| desirable to exit with a status of 1 (as opposed to 0) after issuing |
| the user-requested usage message. It is also desirable to give a |
| more verbose description of program usage in this case. |
| |
| =back |
| |
| B<pod2usage> doesn't force the above conventions upon you, but it will |
| use them by default if you don't expressly tell it to do otherwise. The |
| ability of B<pod2usage()> to accept a single number or a string makes it |
| convenient to use as an innocent looking error message handling function: |
| |
| use Pod::Usage; |
| use Getopt::Long; |
| |
| ## Parse options |
| GetOptions("help", "man", "flag1") || pod2usage(2); |
| pod2usage(1) if ($opt_help); |
| pod2usage(-verbose => 2) if ($opt_man); |
| |
| ## Check for too many filenames |
| pod2usage("$0: Too many files given.\n") if (@ARGV > 1); |
| |
| Some user's however may feel that the above "economy of expression" is |
| not particularly readable nor consistent and may instead choose to do |
| something more like the following: |
| |
| use Pod::Usage; |
| use Getopt::Long; |
| |
| ## Parse options |
| GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); |
| pod2usage(-verbose => 1) if ($opt_help); |
| pod2usage(-verbose => 2) if ($opt_man); |
| |
| ## Check for too many filenames |
| pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") |
| if (@ARGV > 1); |
| |
| As with all things in Perl, I<there's more than one way to do it>, and |
| B<pod2usage()> adheres to this philosophy. If you are interested in |
| seeing a number of different ways to invoke B<pod2usage> (although by no |
| means exhaustive), please refer to L<"EXAMPLES">. |
| |
| =head1 EXAMPLES |
| |
| Each of the following invocations of C<pod2usage()> will print just the |
| "SYNOPSIS" section to C<STDERR> and will exit with a status of 2: |
| |
| pod2usage(); |
| |
| pod2usage(2); |
| |
| pod2usage(-verbose => 0); |
| |
| pod2usage(-exitval => 2); |
| |
| pod2usage({-exitval => 2, -output => \*STDERR}); |
| |
| pod2usage({-verbose => 0, -output => \*STDERR}); |
| |
| pod2usage(-exitval => 2, -verbose => 0); |
| |
| pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR); |
| |
| Each of the following invocations of C<pod2usage()> will print a message |
| of "Syntax error." (followed by a newline) to C<STDERR>, immediately |
| followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and |
| will exit with a status of 2: |
| |
| pod2usage("Syntax error."); |
| |
| pod2usage(-message => "Syntax error.", -verbose => 0); |
| |
| pod2usage(-msg => "Syntax error.", -exitval => 2); |
| |
| pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR}); |
| |
| pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR}); |
| |
| pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0); |
| |
| pod2usage(-message => "Syntax error.", |
| -exitval => 2, |
| -verbose => 0, |
| -output => \*STDERR); |
| |
| Each of the following invocations of C<pod2usage()> will print the |
| "SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to |
| C<STDOUT> and will exit with a status of 1: |
| |
| pod2usage(1); |
| |
| pod2usage(-verbose => 1); |
| |
| pod2usage(-exitval => 1); |
| |
| pod2usage({-exitval => 1, -output => \*STDOUT}); |
| |
| pod2usage({-verbose => 1, -output => \*STDOUT}); |
| |
| pod2usage(-exitval => 1, -verbose => 1); |
| |
| pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT}); |
| |
| Each of the following invocations of C<pod2usage()> will print the |
| entire manual page to C<STDOUT> and will exit with a status of 1: |
| |
| pod2usage(-verbose => 2); |
| |
| pod2usage({-verbose => 2, -output => \*STDOUT}); |
| |
| pod2usage(-exitval => 1, -verbose => 2); |
| |
| pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT}); |
| |
| =head2 Recommended Use |
| |
| Most scripts should print some type of usage message to C<STDERR> when a |
| command line syntax error is detected. They should also provide an |
| option (usually C<-H> or C<-help>) to print a (possibly more verbose) |
| usage message to C<STDOUT>. Some scripts may even wish to go so far as to |
| provide a means of printing their complete documentation to C<STDOUT> |
| (perhaps by allowing a C<-man> option). The following complete example |
| uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these |
| things: |
| |
| use Getopt::Long; |
| use Pod::Usage; |
| |
| my $man = 0; |
| my $help = 0; |
| ## Parse options and print usage if there is a syntax error, |
| ## or if usage was explicitly requested. |
| GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); |
| pod2usage(1) if $help; |
| pod2usage(-verbose => 2) if $man; |
| |
| ## If no arguments were given, then allow STDIN to be used only |
| ## if it's not connected to a terminal (otherwise print usage) |
| pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); |
| __END__ |
| |
| =head1 NAME |
| |
| sample - Using GetOpt::Long and Pod::Usage |
| |
| =head1 SYNOPSIS |
| |
| sample [options] [file ...] |
| |
| Options: |
| -help brief help message |
| -man full documentation |
| |
| =head1 OPTIONS |
| |
| =over 8 |
| |
| =item B<-help> |
| |
| Print a brief help message and exits. |
| |
| =item B<-man> |
| |
| Prints the manual page and exits. |
| |
| =back |
| |
| =head1 DESCRIPTION |
| |
| B<This program> will read the given input file(s) and do something |
| useful with the contents thereof. |
| |
| =cut |
| |
| =head1 CAVEATS |
| |
| By default, B<pod2usage()> will use C<$0> as the path to the pod input |
| file. Unfortunately, not all systems on which Perl runs will set C<$0> |
| properly (although if C<$0> isn't found, B<pod2usage()> will search |
| C<$ENV{PATH}> or else the list specified by the C<-pathlist> option). |
| If this is the case for your system, you may need to explicitly specify |
| the path to the pod docs for the invoking script using something |
| similar to the following: |
| |
| pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); |
| |
| In the pathological case that a script is called via a relative path |
| I<and> the script itself changes the current working directory |
| (see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will |
| fail even on robust platforms. Don't do that. |
| |
| =head1 AUTHOR |
| |
| Please report bugs using L<http://rt.cpan.org>. |
| |
| Marek Rouchal E<lt>marekr@cpan.orgE<gt> |
| |
| Brad Appleton E<lt>bradapp@enteract.comE<gt> |
| |
| Based on code for B<Pod::Text::pod2text()> written by |
| Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> |
| |
| =head1 ACKNOWLEDGMENTS |
| |
| Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience |
| with re-writing this manpage. |
| |
| =head1 SEE ALSO |
| |
| B<Pod::Usage> is part of the L<Pod::Parser> distribution. |
| |
| L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find> |
| |
| =cut |
| |
| ############################################################################# |
| |
| #use diagnostics; |
| use Carp; |
| use Config; |
| use Exporter; |
| use File::Spec; |
| |
| @EXPORT = qw(&pod2usage); |
| BEGIN { |
| if ( $] >= 5.005_58 ) { |
| require Pod::Text; |
| @ISA = qw( Pod::Text ); |
| } |
| else { |
| require Pod::PlainText; |
| @ISA = qw( Pod::PlainText ); |
| } |
| } |
| |
| require Pod::Select; |
| |
| ##--------------------------------------------------------------------------- |
| |
| ##--------------------------------- |
| ## Function definitions begin here |
| ##--------------------------------- |
| |
| sub pod2usage { |
| local($_) = shift; |
| my %opts; |
| ## Collect arguments |
| if (@_ > 0) { |
| ## Too many arguments - assume that this is a hash and |
| ## the user forgot to pass a reference to it. |
| %opts = ($_, @_); |
| } |
| elsif (!defined $_) { |
| $_ = ''; |
| } |
| elsif (ref $_) { |
| ## User passed a ref to a hash |
| %opts = %{$_} if (ref($_) eq 'HASH'); |
| } |
| elsif (/^[-+]?\d+$/) { |
| ## User passed in the exit value to use |
| $opts{'-exitval'} = $_; |
| } |
| else { |
| ## User passed in a message to print before issuing usage. |
| $_ and $opts{'-message'} = $_; |
| } |
| |
| ## Need this for backward compatibility since we formerly used |
| ## options that were all uppercase words rather than ones that |
| ## looked like Unix command-line options. |
| ## to be uppercase keywords) |
| %opts = map { |
| my ($key, $val) = ($_, $opts{$_}); |
| $key =~ s/^(?=\w)/-/; |
| $key =~ /^-msg/i and $key = '-message'; |
| $key =~ /^-exit/i and $key = '-exitval'; |
| lc($key) => $val; |
| } (keys %opts); |
| |
| ## Now determine default -exitval and -verbose values to use |
| if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { |
| $opts{'-exitval'} = 2; |
| $opts{'-verbose'} = 0; |
| } |
| elsif (! defined $opts{'-exitval'}) { |
| $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; |
| } |
| elsif (! defined $opts{'-verbose'}) { |
| $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || |
| $opts{'-exitval'} < 2); |
| } |
| |
| ## Default the output file |
| $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || |
| $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR |
| unless (defined $opts{'-output'}); |
| ## Default the input file |
| $opts{'-input'} = $0 unless (defined $opts{'-input'}); |
| |
| ## Look up input file in path if it doesnt exist. |
| unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { |
| my $basename = $opts{'-input'}; |
| my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' |
| : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); |
| my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; |
| |
| my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); |
| for my $dirname (@paths) { |
| $_ = File::Spec->catfile($dirname, $basename) if length; |
| last if (-e $_) && ($opts{'-input'} = $_); |
| } |
| } |
| |
| ## Now create a pod reader and constrain it to the desired sections. |
| my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); |
| if ($opts{'-verbose'} == 0) { |
| $parser->select('(?:SYNOPSIS|USAGE)\s*'); |
| } |
| elsif ($opts{'-verbose'} == 1) { |
| my $opt_re = '(?i)' . |
| '(?:OPTIONS|ARGUMENTS)' . |
| '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; |
| $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); |
| } |
| elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { |
| $parser->select('.*'); |
| } |
| elsif ($opts{'-verbose'} == 99) { |
| my $sections = $opts{'-sections'}; |
| $parser->select( (ref $sections) ? @$sections : $sections ); |
| $opts{'-verbose'} = 1; |
| } |
| |
| ## Now translate the pod document and then exit with the desired status |
| if ( !$opts{'-noperldoc'} |
| and $opts{'-verbose'} >= 2 |
| and !ref($opts{'-input'}) |
| and $opts{'-output'} == \*STDOUT ) |
| { |
| ## spit out the entire PODs. Might as well invoke perldoc |
| my $progpath = File::Spec->catfile($Config{scriptdirexp} |
| || $Config{scriptdir}, 'perldoc'); |
| print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); |
| if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { |
| # the perldocs back to 5.005 should all have -F |
| # without -F there are warnings in -T scripts |
| system($progpath, '-F', $1); |
| if($?) { |
| # RT16091: fall back to more if perldoc failed |
| system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); |
| } |
| } else { |
| croak "Unspecified input file or insecure argument.\n"; |
| } |
| } |
| else { |
| $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); |
| } |
| |
| exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); |
| } |
| |
| ##--------------------------------------------------------------------------- |
| |
| ##------------------------------- |
| ## Method definitions begin here |
| ##------------------------------- |
| |
| sub new { |
| my $this = shift; |
| my $class = ref($this) || $this; |
| my %params = @_; |
| my $self = {%params}; |
| bless $self, $class; |
| if ($self->can('initialize')) { |
| $self->initialize(); |
| } else { |
| # pass through options to Pod::Text |
| my %opts; |
| for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) { |
| my $val = $params{USAGE_OPTIONS}{"-$_"}; |
| $opts{$_} = $val if defined $val; |
| } |
| $self = $self->SUPER::new(%opts); |
| %$self = (%$self, %params); |
| } |
| return $self; |
| } |
| |
| sub select { |
| my ($self, @sections) = @_; |
| if ($ISA[0]->can('select')) { |
| $self->SUPER::select(@sections); |
| } else { |
| # we're using Pod::Simple - need to mimic the behavior of Pod::Select |
| my $add = ($sections[0] eq '+') ? shift(@sections) : ''; |
| ## Reset the set of sections to use |
| unless (@sections) { |
| delete $self->{USAGE_SELECT} unless ($add); |
| return; |
| } |
| $self->{USAGE_SELECT} = [] |
| unless ($add && $self->{USAGE_SELECT}); |
| my $sref = $self->{USAGE_SELECT}; |
| ## Compile each spec |
| for my $spec (@sections) { |
| my $cs = Pod::Select::_compile_section_spec($spec); |
| if ( defined $cs ) { |
| ## Store them in our sections array |
| push(@$sref, $cs); |
| } else { |
| carp qq{Ignoring section spec "$spec"!\n}; |
| } |
| } |
| } |
| } |
| |
| # Override Pod::Text->seq_i to return just "arg", not "*arg*". |
| sub seq_i { return $_[1] } |
| |
| # This overrides the Pod::Text method to do something very akin to what |
| # Pod::Select did as well as the work done below by preprocess_paragraph. |
| # Note that the below is very, very specific to Pod::Text. |
| sub _handle_element_end { |
| my ($self, $element) = @_; |
| if ($element eq 'head1') { |
| $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; |
| if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { |
| $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; |
| } |
| } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 |
| my $idx = $1 - 1; |
| $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); |
| $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; |
| } |
| if ($element =~ /^head\d+$/) { |
| $$self{USAGE_SKIPPING} = 1; |
| if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { |
| $$self{USAGE_SKIPPING} = 0; |
| } else { |
| my @headings = @{$$self{USAGE_HEADINGS}}; |
| for my $section_spec ( @{$$self{USAGE_SELECT}} ) { |
| my $match = 1; |
| for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) { |
| $headings[$i] = '' unless defined $headings[$i]; |
| my $regex = $section_spec->[$i]; |
| my $negated = ($regex =~ s/^\!//); |
| $match &= ($negated ? ($headings[$i] !~ /${regex}/) |
| : ($headings[$i] =~ /${regex}/)); |
| last unless ($match); |
| } # end heading levels |
| if ($match) { |
| $$self{USAGE_SKIPPING} = 0; |
| last; |
| } |
| } # end sections |
| } |
| |
| # Try to do some lowercasing instead of all-caps in headings, and use |
| # a colon to end all headings. |
| if($self->{USAGE_OPTIONS}->{-verbose} < 2) { |
| local $_ = $$self{PENDING}[-1][1]; |
| s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; |
| s/\s*$/:/ unless (/:\s*$/); |
| $_ .= "\n"; |
| $$self{PENDING}[-1][1] = $_; |
| } |
| } |
| if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { |
| pop @{ $$self{PENDING} }; |
| } else { |
| $self->SUPER::_handle_element_end($element); |
| } |
| } |
| |
| # required for Pod::Simple API |
| sub start_document { |
| my $self = shift; |
| $self->SUPER::start_document(); |
| my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; |
| my $out_fh = $self->output_fh(); |
| print $out_fh "$msg\n"; |
| } |
| |
| # required for old Pod::Parser API |
| sub begin_pod { |
| my $self = shift; |
| $self->SUPER::begin_pod(); ## Have to call superclass |
| my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; |
| my $out_fh = $self->output_handle(); |
| print $out_fh "$msg\n"; |
| } |
| |
| sub preprocess_paragraph { |
| my $self = shift; |
| local $_ = shift; |
| my $line = shift; |
| ## See if this is a heading and we arent printing the entire manpage. |
| if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { |
| ## Change the title of the SYNOPSIS section to USAGE |
| s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; |
| ## Try to do some lowercasing instead of all-caps in headings |
| s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; |
| ## Use a colon to end all headings |
| s/\s*$/:/ unless (/:\s*$/); |
| $_ .= "\n"; |
| } |
| return $self->SUPER::preprocess_paragraph($_); |
| } |
| |
| 1; # keep require happy |