File Coverage

blib/lib/Getopt/Auto.pm

Criterion	Covered	Total	%
statement	392	433	90.5
branch	131	166	78.9
condition	34	48	70.8
subroutine	48	50	96.0
pod	0	2	0.0
total	605	699	86.5

#! /usr/bin/perl

#===============================================================================
#
#         FILE:  Auto.pm
#
#        USAGE:  use Getopt::Auto
#
#  DESCRIPTION:  Processes the command line when your Perl script is executed,
#                looking for the options you define in your POD.
#
#      OPTIONS:  --- None
# REQUIREMENTS:  --- See Build.PL
#         BUGS:  --- Hah!
#       AUTHOR:  Geoffrey Leach (), [e-mail]
#      VERSION:  2.0
#     REVISION:  ---
#===============================================================================

#  Copyright (C) 2003-2009, Simon Cozens
#  Copyright (C) 2010-2011, Geoffrey Leach

package Getopt::Auto;

use 5.006;
use strict;
use warnings;

use Carp;

use File::Basename;
use File::Spec;
use Readonly;

Readonly::Scalar my $SPACE   => q{ };
Readonly::Scalar my $EMPTY   => q{};
Readonly::Scalar my $DASH    => q{-};
Readonly::Scalar my $DDASH   => q{--};
Readonly::Scalar my $BARE    => 0;
Readonly::Scalar my $SHORT   => 1;
Readonly::Scalar my $LONG    => 2;
Readonly::Array my @TYPES    => qw( bare short long );
Readonly::Array my @PREFIXES => ( $EMPTY, $DASH, $DDASH );

our $VERSION = '2.0';

# Perlcritic complains about print to STDOUT. As this is merely for
# diagnostic purposes, it seems futile to fix them.

## no critic (RequireCheckedSyscalls)

# Initialized by import(), used throughout
# Successive calls to import add to it, allowing code to work off
# of a particular script or module
# Each element is a list of
# 0: [package, file], as returned by caller() in import()
# 1: The package's options hash (our %options), or main::options
# 2: Hash of controls as given in call of Getopt::Auto
#    nobare, noshort, nolong, trace, init, findsub
my @callers;

# $caller is the current value of @callers when iterating and is
# used by subroutines that do not have a way to get it via a parameter
our $caller;    ## no critic (ProhibitPackageVars)

# User-requested global behaviors
# 'test' is intentionally undocumented
# It is used to avoid exiting on errors for test purposes
my %config = (
    'trace'    => undef,
    'noshort'  => undef,
    'nolong'   => undef,
    'nobare'   => undef,
    'nohelp'   => undef,
    'nobundle' => undef,
    'oknotreg' => undef,
    'okerror'  => undef,
    'findsub'  => undef,
    'init'     => undef,
    'test'     => undef,
);

my $errors = 0;

# CHECK is a specially-named block, that is executed by Perl at the _completion_ of compillation.
# This is critical, because _parse_pod() depends (indirectly, see Getopt::Auto::PodExtract)
# on the existence of subroutines to process the options. It's only executed _once_, however
# many times "use Getopt::Auto" has appeared. We've accumulated those packages; now we'll
# process them.

CHECK {

    #$DB::single = 2;    ## no critic (ProhibitPackageVars)
    if ($errors) {
        if ( not defined $config{'test'} ) { exit 1; }
    }
    _parse_pod();
}

# INIT is a specially-named block that is executed immediatly preceding the
# start of the program.

INIT {

    #$DB::single = 2;    ## no critic (ProhibitPackageVars)
    _parse_args();
    if ($errors) {
        if (   ( not defined $config{'okerror'} )
            && ( not defined $config{'test'} ) )
        {
            exit 1;
        }
    }
}

# Executed when the Perl program is about to exit
# Retained for compabilility with V 1.0; I've no idea what it does

END {
    if ( exists &main::default ) { main::default() }
}

# Please note: subroutine names that begin with an underscore are internal.
# Calling sequence and/or existence is not guaranteed for future versions.

# $their_version is managed by Getopt::Auto::PodExtract::preprocess_line()
# _set_their_version() assigns and _get_their_version() reports.
# their_version is the value of $VERSION in the source POD.

my $their_version;

sub _set_their_version {
    $their_version = shift;
    return;
}

sub _get_their_version {
    return $their_version;
}

# Carries the content of Getopt::Auto(...)
our @spec;    ## no critic (ProhibitPackageVars)
Readonly::Scalar my $SPEC_NAME  => 0;
Readonly::Scalar my $SPEC_SHORT => 1;
Readonly::Scalar my $SPEC_LONG  => 2;
Readonly::Scalar my $SPEC_CODE  => 3;
Readonly::Scalar my $SPEC_SIZE  => 4;

sub _get_spec_ref {
    return \@spec;
}

# Allows user to say what style to prefer
# Values are 'short', 'long', 'bare', default 'long' or 'undef' meaning use the POD;
my $help_p = $LONG;

# %options contains the option registration data extracted from the POD
# (or from the use Getopt::Auto statement). It's loaded by _parse_pod()
# and used by _parse_args() when an option is discovered on the run-time command.

our %options;    ## no critic (ProhibitPackageVars)

# This sub is intended for testing only. Absence of leading '_' is only to
# satisfy perlcritic.
sub test_option {
    my $query = shift;
    return exists $options{$query} && !_is_restricted($query);
}

sub _get_options_ref {
    return \%options;
}

sub _trace {
    if ( not defined $config{'trace'} ) {
        return;
    }
    my $arg = shift;
    chomp $arg;
    print "Getopt::Auto trace: $arg\n";
    return;
}

sub _trace_spec {
    if ( not defined $config{'trace'} ) {
        return;
    }
    my $spec = shift;
    print "Getopt::Auto trace: Spec for $spec->[$SPEC_NAME]: ";
    print length $spec->[$SPEC_SHORT]
        ? "$spec->[$SPEC_SHORT], "
        : "no short help, ";
    print defined $spec->[$SPEC_LONG]
        ? "$spec->[$SPEC_LONG], "
        : "no long help, ";
    print defined $spec->[$SPEC_CODE]
        ? "$spec->[$SPEC_CODE]"
        : "no code";
    print "\n";
    return;
}

sub _trace_argv {
    if ( not defined $config{'trace'} ) {
        return;
    }
    _trace( 'Getopt::Auto trace: ARGV now: (' . join( ', ', @ARGV ) . ')' );
    return;
}

sub get_errors {
    return $errors;
}

sub _error {
    my $msg = shift;
    print {*STDERR} 'Getopt::Auto: ', $msg, "\n";
    $errors++;
    return;
}

# Modifies $name to make it an acceptable subrotine name.

sub _clean_func {
    my $func = shift;
    $func =~ s{\A-+}{}smx;
    $func =~ s{-}{_}smgx;
    return $func;
}

# Checks $pkg to see if there's a subroutine $name.
# $name will be an option, that is for --foo we look to
# see if there's a sub foo() Return it if so.

sub _check_func {
    my ( $name, $pkg ) = @_;
    if ( not defined $caller ) {
        return;
    }
    if ( not defined $pkg ) {
        $pkg = qq{$caller->[0][0]::};
    }

    my $func = _clean_func($name);
    if ( exists &{"$pkg$func"} ) {
        _trace("For $name code is $func()");
        _trace("$pkg$func exists");
        no strict 'refs';    ## no critic (ProhibitNoStrict)
        return *{"$pkg$func"}{'CODE'};
    }
    else {
        _trace("There is no $pkg$func");
        return;
    }
    return;
}

# Look in all packages for a sub $name. If so, return it
# and store it in %options for future use. Note that
# at the point where this sub is called, we've determined
# that the option is not 'registered' and we wish to avoid
# registering the option by accident
# An nregistered option is something like --foo, where --foo
# did not appear in a =head line in the POD.

sub _check_all_sub {
    my $name = shift;
    _trace("Checking for sub $name");

    if (    ( exists $options{$name} )
        and ( exists $options{$name}{'code'} ) )
    {
        return $options{$name}{'code'};
    }

    # Check in all packages
    foreach my $caller_local (@callers) {
        my $sub = _check_func( $name, qq{$caller_local->[0][0]::} );
        if ( defined $sub ) {
            $options{$name}{'code'} = $sub;
            return $sub;
        }
    }
    return;
}

sub _is_restricted {
    my $arg      = shift;
    my $arg_type = _option_type($arg);
    if (( ( $arg_type == $BARE ) && ( defined $config{'nobare'} ) )
        || (   ( $arg_type == $SHORT )
            && ( defined $config{'noshort'} ) )
        || (   ( $arg_type == $LONG )
            && ( defined $config{'nolong'} ) )
        )
    {
        return 1;
    }
    return 0;
}

# The specs parameter is assumed to be a ref to a 4-element array
# The elementts are options found either in the POD or the use Getopt::Auto

sub _load_options {
    my ( $specs, $caller_local ) = @_;
    foreach my $spec ( @{$specs} ) {
        my $name = $spec->[$SPEC_NAME];

        $options{$name}{'shorthelp'}  = $spec->[$SPEC_SHORT];
        $options{$name}{'longhelp'}   = $spec->[$SPEC_LONG];
        $options{$name}{'package'}    = $caller_local->[0][0];
        $options{$name}{'options'}    = $caller_local->[1];
        $options{$name}{'registered'} = 1;

        # Avoid creating a code reference that's undefined
        if ( defined $spec->[$SPEC_CODE] ) {
            $options{$name}{'code'} = $spec->[$SPEC_CODE];
        }
        _trace_spec($spec);
    }
    return;
}

# Check a spec that's been given us by the user.

sub _check_spec {
    my ( $spec_ref, $caller_local ) = @_;

    foreach my $spec ( @{$spec_ref} ) {

        # Each spec has the following members:
        #   The option name: we need to check it for consistency.
        #   The short help phrase, from the POD =item or =head
        #   The long help message, from the POD paragraph that follows
        #   The code (sub reference) to be called for the option

        if ( not( ref $spec eq 'ARRAY' ) ) {
            _error(qq{Option specification $spec must be a reference});
            return;
        }

        if ( @{$spec} != $SPEC_SIZE ) {
            _error(qq{Option list is incompletly specified});
            return;
        }

        push @spec, $spec;
    }

    _load_options( \@spec, $caller_local );

    return 1;
}

# Called by Perl at the time of processing 'use' but _not_ of processing 'require'

sub import {
    my $class = shift;    # Getopt::Auto
    #$DB::single = 2;     ## no critic (ProhibitPackageVars)

    my @caller = caller;
    pop @caller;

    my $opt = "$caller[0]::options";
    if ( not defined $opt ) {

        # Which may not exist either, but that's OK.
        $opt = q{main::options};
    }

    # So it's easy to turn off the trace from the environment
    if ( exists $ENV{'GETOPT_AUTO_TRACE'} ) {
        $config{'trace'} = $ENV{'GETOPT_AUTO_TRACE'} == 1 ? 1 : undef;
    }

    my $ctls;
    while ( my $arg = shift ) {
        if ( ref $arg eq 'HASH' ) {
            foreach my $opt ( keys %{$arg} ) {
                if ( exists $config{$opt} ) { $config{$opt} = 1; }
                else {
                    _error(qq{Option '$opt' is unknown});
                }
            }
            $ctls = $arg;
        }
        elsif ( ref $arg eq 'ARRAY' ) {
            $ctls = {};
            _check_spec( $arg, [ \@caller, $opt, $ctls ] );
        }
        else {
            _error(
                qq{Must be use-d with: no args, an HASH ref or an ARRAY ref}
            );
            return;
        }
    }

    #$config{'trace'}  = 1; # debugging
    push @callers, [ \@caller, $opt, $ctls ];
    _trace("Tracing ...");
    _trace("Package: $callers[-1][0][0], File: $callers[-1][0][1]");
    return;
}

sub _option_type {
    my $option = shift;
    return $BARE if not defined $option;
    $option =~ m{\A$DDASH}smx and return $LONG;
    $option =~ m{\A$DASH}smx  and return $SHORT;
    $option =~ m{\A\w}smx     and return $BARE;
    return $BARE;
}

# Process the files in the script looking for option registrations
# and build the global @spec array

sub _parse_pod {

    foreach my $caller_local (@callers) {

        # We're doing magic!

        # Do the parsing. The -want_nonPODs causes Pod::Parser (the base) to
        # call the preprocess_line() sub with all input, so we can scan for
        # an assignment to $VERSION. Overhead is negligable.

        # The $caller global is used indirectly by PodExtract, via _check_func()
        $caller = $caller_local;

        my $pod = Getopt::Auto::PodExtract->new( -want_nonPODs => 1 );

        my $filename
            = File::Spec->rel2abs( $caller_local->[0][1] );
        my ( $name, $path, $suffix )
            = fileparse( $filename, qw( .t .pm .pl ) );
        my @filenames = $filename;

        # Add a possible POD extra file
        push @filenames, "$path$name.pod";

        foreach my $file (@filenames) {
            _trace("Processing POD in: $file");
            if ( not -r $file ) {
                _trace("$file not readable");
                next;
            }

            # Pod::Parser method that does the work,
            # calling the functions that fill 'funcs'
            $pod->parse_from_file( $file, '/dev/null' );
            last if defined $pod->{'funcs'};
            _trace("No POD in $file");
        }

        if ( not defined $pod->{'funcs'} ) {

          # Strangely, this is OK. _parse_args checks for would-be option subs
            _trace( "No POD in " . join $SPACE, @filenames );
            return;
        }

        # Now move what the POD processing found into a useful format.
        # $pod ($self in Getopt::Auto::PodExtract subs) has, if we've found
        # any =item or =head[2|3|4] lines that parse out as being option
        # registrations.

        # This code builds the @spec global array as a stack of spec definitions
        # which will be used later on in option processing.
        #
        # Correction 1.9.0 => 1.9.2 courtesy of Bruce Gray
        my @this_spec;
        foreach my $n ( sort keys %{ $pod->{'funcs'} } ) {
            my $spec = $pod->{'funcs'}{$n};

            if ( exists $spec->{'longhelp'} ) {
                $spec->{'longhelp'} =~ s{\n+\z}{\n}smx;
            }
            push @this_spec,
                [
                $n,                  $spec->{'shorthelp'},
                $spec->{'longhelp'}, $spec->{'code'}
                ];
        }

        _load_options( \@this_spec, $caller_local );

        # Global list '@spec' is assigned here
        push @spec, @this_spec;
    }

    return;
}

sub _set_option {
    my ( $arg, $caller_local ) = @_;

    my ( $opt, $pkg );

    # This is sort of backwards.
    # If the arg is known to be a registered option,
    # then we don't need the caller.
    # Otherwise, $caller_local is used to determine options and package.

    if ( defined $caller_local ) {
        $opt = qq{$caller_local->[1]};
    }
    else {
        $opt = $options{$arg}{'options'};
    }
    # At this point $opt is the hash defined by "our %options" (or main::options)
    # in the _user's_ code. That's a different entity form %options in this code
    # which saves the registration info we collected by parsing the POD

    # This is true for our --help and --version
    if ( not defined $opt ) { return 0; }

    # Warning -- if opption_type is BARE, this should only be called if the
    # op -- arg is registered.
    _trace("Bumping $opt for $arg");
    no strict 'refs';    ## no critic (ProhibitNoStrict)
    # And here we bump the use count for the option
    ${$opt}{$arg}++;

    return 1;
}

sub _split_arg {
    my ( $arg, $args ) = @_;

    if ( defined $config{'nobundle'} ) {
        $args->{$arg} = 1;
        return $arg;
    }

    # This applies only to SHORT options
    if ( _option_type($arg) != $SHORT ) { return $arg; }
    if ( length $arg == 2 )             { return $arg; }

    # Builtin help/version meets this criteria
    if (    ( exists $options{$arg} )
        and ( exists $options{$arg}{'registered'} ) )
    {
        return $arg;
    }

    _trace("Splitting $arg into its components");

    my @args;
    foreach my $char ( split m{}smx, substr $arg, 1 ) {
        $char = "-$char";
        push @args, $char;
        $args->{$char}++;
        $args->{$arg}++;
    }
    return @args;
}

sub _is_registered {
    my $arg = shift;

    return ( ( exists $options{$arg} )
        and ( exists $options{$arg}{'registered'} ) );
}

sub _notreg {
    my $text = shift;
    if ( defined $config{'oknotreg'} ) { return; }
    _error(qq{$text is not a registered option});

    if ( defined $config{'nohelp'} ) { return; }

    # Make an attempt to add useful info
    # If user has not provided help, this will be the builtin version
    if ( exists $options{'--help'}{'code'} ) {
        _do_option_action('--help');
        return;
    }

    # If user has not provided help, this will be the builtin version
    if ( exists $options{'-h'}{'code'} ) {
        _do_option_action('-h');
        return;
    }

    # Well get here iff the user has provided non-fatal help
    # Or, 'test' is configured
    return;
}

sub _do_option_action {
    my ( $arg, $arg_eq ) = @_;

    if ( defined $options{$arg} ) {

        # Registered option
        # Check for sub to execute
        if ( exists $options{$arg}{'code'} ) {
            _trace("Running code $options{$arg}{'code'}");
            no strict 'refs';    ## no critic (ProhibitNoStrict)
            $options{$arg}{'code'}->();
            return 1;
        }

        # No sub, registered option, so assign %options
        # unless it's an assignment-type option, which must have a sub
        if ( defined $arg_eq ) { return 0; }

        _set_option($arg);
        return 1;
    }
}

sub _check_help {
    my @perfs;
    foreach my $op ( keys %options ) {
        if ( exists $options{$op}{'restrict'} ) { next; }
        $perfs[ _option_type($op) ]++;
    }

    $help_p = $LONG;
    my $max_p = 0;
    foreach my $i ( $BARE .. $LONG ) {
        if ( ( defined $perfs[$i] ) && ( $perfs[$i] > $max_p ) ) {
            $help_p = $i;
        }
    }

    my $help = "$PREFIXES[$help_p]help";
    my $vers = "$PREFIXES[$help_p]version";
    if ( not exists $options{$help} ) {
        $options{$help}{'code'}       = \&_help;
        $options{$help}{'registered'} = 1;
        $options{$help}{'shorthelp'}  = 'This text';
    }
    if ( not exists $options{$vers} ) {
        $options{$vers}{'code'}       = \&_version;
        $options{$vers}{'registered'} = 1;
        $options{$vers}{'shorthelp'}  = 'Prints the version number';
    }

    return;
}

my @not_option;

sub _not_option {
    my ( $arg, $eq ) = @_;

    # The param $eq indicates that we're undoing an arg of the
    # form -foo=22. The 22 is in @ARGV, but there was no sub
    # to consume it, so we move it off.
    if ( defined $eq ) { $arg .= qq{=$eq}; shift @ARGV; }
    push @not_option, $arg;
    return;
}

sub _parse_args {    ## no critic (ProhibitExcessComplexity)
    @not_option = ();

    _trace_argv();

    # Check that builtin help is defined according to the option type
    _check_help();

    # Check each script/module for an init sub to execute
    # If the user has defined one, its in the @callers array at [2].
    foreach my $caller_local (@callers) {
        my $init_sub = $caller_local->[2]{'init'};
        if ( defined $init_sub ) {
            _trace("Executing code for init_sub");
            no strict 'refs';    ## no critic (ProhibitNoStrict)
            $init_sub->();
        }
    }

    while ( my $argv = shift @ARGV ) {

        my $op_type = _option_type($argv);

        _trace("Considering $argv, option type is $TYPES[$op_type]");
        _trace_argv();

        # Check cease and desist
        if ( $argv =~ m{\A-{1,2}\z}smx ) {
            _trace("Option end $argv, scanning ends");

            # Marker is not replaced
            last;
        }

        # Check restricted option
        if ( _is_restricted($argv) ) {
            _trace("Option $argv is restricted, skipping");
            _not_option($argv);
            next;
        }

        # Check --foo=bar syntax use
        my $arg_eq;
        if ( $argv =~ m{=}smx ) {

            # Assign-type option: --foo=bar
            ( $argv, $arg_eq ) = split m{=}smx, $argv;
            unshift @ARGV, $arg_eq;
            _trace("Option $argv has assignment");
            _trace_argv();
        }

        # Process $argv as directed by %options, or push it back onto @ARGV

        if ( _is_registered($argv) ) {

            # Registered option, the simple case
            if ( _do_option_action( $argv, $arg_eq ) ) { next; }

            # _do_option_action returns 0 iff $arg_eq and no sub
            _error(qq{To use $argv with "=", a subroutine must be provided});
            _not_option( $argv, $arg_eq );
            next;
        }

        _trace("$argv is not registered");

        # Well, what we have in $argv is not registered

        if ( defined $config{'findsub'} ) {
            my $sub = _check_all_sub($argv);
            if ( defined $sub ) {
                _trace("Running code $sub");
                no strict 'refs';    ## no critic (ProhibitNoStrict)
                $sub->();
                next;
            }
            if ( _do_option_action( $argv, $arg_eq ) ) { next; }
        }

        # $argv is not registered.
        # Perhaps its a concatiation of single-letter SHORTs?
        if ( ( $op_type == $SHORT ) && ( length $argv > 2 ) ) {
            my %args;
            my @args = _split_arg( $argv, \%args );

            foreach my $arg (@args) {
                if ( _is_registered($arg) ) {
                    _do_option_action($arg);
                    $args{$arg}--;
                    $args{$argv}--;
                }
                else {
                    _trace("$arg is not registered");
                }
            }

        # Generate error messages for unregistered arg(s)
        # $argv is not registered iff _none_ of its components are registered
        # We know this because none of the components caused a decrement above
            if ( $args{$argv} == @args ) {
                _notreg($argv);
                _trace("$argv is not an option");
                _not_option( $argv, $arg_eq );
                next;
            }

            # Report all components of $argv that are not registered
            foreach my $arg (@args) {
                if ( $args{$arg} == 0 ) { next; }
                _notreg(qq{$arg (from $argv)});
                _trace("$arg is not an option");
                _not_option($arg);
            }
            next;
        }

        # Provide a warning for non-bare options
        if ( $op_type != $BARE ) { _notreg($argv); }

       # Save an element of @ARGV that did not meet the criteria for an option
        _trace("$argv is not an option");
        _not_option( $argv, $arg_eq );
    }

    # Give the user what's left
    unshift @ARGV, @not_option;
    _trace("Scanning ends");
    _trace_argv();

    return;
}

sub _sort_sub {
    my ( $A, $B ) = ( $a, $b );
    $A =~ s{\A-*}{}smx;
    $B =~ s{\A-*}{}smx;
    return $A cmp $B;
}

sub _version {
    print STDERR "This is $callers[0][0][1]";
    if ( defined $their_version and length $their_version ) {
        print STDERR " version $their_version";
    }
    else {
        print STDERR " (no version is specified)";
    }
    print STDERR "\n\n";
    return;
}

sub _help {
    _version();

    # Are we being asked for *specific* help?
    if ( my @help = grep { exists $options{$_} } @ARGV ) {
        my $what = shift @ARGV;
        if ( exists $options{$what}{'shorthelp'} ) {
            print STDERR
                "$callers[0][0][1] $what - $options{$what}{'shorthelp'}\n\n";
            if ( defined $options{$what}{'longhelp'} ) {
                print STDERR $options{$what}{'longhelp'}, "\n";
            }
        }
        else {
            print STDERR "No help available for $what\n";
        }
    }
    else {

        my $and_there_s_more = 0;
        foreach ( sort _sort_sub keys %options ) {
            print STDERR "$callers[0][0][1] $_";
            if ( defined $options{$_}{'shorthelp'}
                and ( $options{$_}{'shorthelp'} =~ m{\S}smx ) )
            {
                print STDERR " - $options{$_}{'shorthelp'}";
            }
            if ( defined $options{$_}{'longhelp'}
                and ( $options{$_}{'longhelp'} =~ m{\S}smx ) )
            {
                $and_there_s_more++;
                print STDERR q{ [*]};
            }
            print STDERR "\n";
        }

        if ($and_there_s_more) {
            print STDERR <<"EOF";

More help is available on the topics marked with [*]
Try $callers[0][0][1] $PREFIXES[$help_p]help $PREFIXES[$help_p]foo
EOF
        }
    }
    print STDERR qq{This is the built-in help, exiting\n};
    if ( not defined $config{'test'} ) { exit 0; }
    return;
}

1;

# This package exists to provide replacement for the default subs (of the same name)
# provided by Pod::Parser
# The way it works is that they are called at appropriate times to extract the
# information we need to support the options.
# The sub names are determined by Pod::Parser, so don't meddle.

## no critic (ProhibitMultiplePackages)
package Getopt::Auto::PodExtract;
use base 'Pod::Parser';

## no critic (ProtectPrivateSubs)

# Called when Pod::Parser finds '^=...'
sub command {
    my ( $self, $command, $text, $line_num ) = @_;

    # Cancel text grabs; whatever we've got, we've got.
    $self->{'copying'} = 0;

    # Process only "=item" and "=head2, =head3 and =head4"
    if ( $command eq 'item' || $command =~ m{^head(?:2|3|4)}smx ) {

        # Sometimes more han one newline, which I don't understand
        while ( chomp $text ) { }

        Getopt::Auto::_trace("Parsing =$command $text");

        my $shorthelp;
        $text =~ s{\s+-+\s+(.*)}{}smx;
        if ( defined $1 ) {
            $shorthelp = $1;
        }

        # No qualifying dash, or no space after dash
        # The RE fails, leaving $t unchanged
        if ( not defined $shorthelp ) {
            Getopt::Auto::_trace('No shorthelp, not an option');
            return;
        }

        Getopt::Auto::_trace("Shorthelp is: $shorthelp");

        # This suports options of the form "-f, --foo"
        my $sub;
        my @nosub;
        my @opts = split m{,\s*}smx, $text;
        foreach my $name (@opts) {
            $name =~ s{\A(\w<)?([\w_-]+)>?}{$2}smx;
            if ( $name =~ m{\s}smx ) {
                Getopt::Auto::_trace("$name dropped, has spaces");
                next;
            }

            Getopt::Auto::_trace("Option is $name");
            $self->{'funcs'}{$name} = { 'shorthelp' => $shorthelp, };
            $self->{'copying'}      = 1;
            $self->{'latest'}       = $name;
            my $sub_found = Getopt::Auto::_check_func($name);
            if ( defined $sub_found ) {
                $self->{'funcs'}{$name}{'code'} = $sub_found;
                $sub = $sub_found;
            }
            else {
                push @nosub, $name;
            }
        }

        # Options that had no defined sub get the last-defined sub
        foreach my $name (@nosub) {
            $self->{'funcs'}{$name}{'code'} = $sub;
        }
    }
    return;
}

# Called when text that begins with spaces (or tabs) is discovered inside POD text.
# As implied by the name, verbatum text is taken 'as is'.
# We save it only if we're inside of =item or =head ($self->{copying})

sub verbatim {
    my ( $self, $paragraph, $line_num ) = @_;
    if ( $self->{'copying'} ) {
        $self->{'funcs'}{ $self->{'latest'} }{'longhelp'} .= $paragraph;
        Getopt::Auto::_trace("verbatim - longhelp is: $paragraph");
    }
    return;
}

# Called when text that does not begin with spaces (or tabs) is discovered inside POD text.
# The semantics of text blocks require that 'interior sequences' (e.g.: B) be expanded.
# That's what the Pod::Parser sub interpolate() does.
# We save it only if we're inside of =item or =head ($self->{copying})

sub textblock {
    my ( $self, $paragraph, $line_num ) = @_;
    if ( $self->{'copying'} ) {
        $self->{'funcs'}{ $self->{'latest'} }{'longhelp'}
            .= $self->interpolate( $paragraph, $line_num );
        Getopt::Auto::_trace("textblock - longhelp is: $paragraph");
    }
    return;
}

sub preprocess_line {
    my ( $self, $text, $line_num ) = @_;

    defined Getopt::Auto::_get_their_version() and return $text;

    if ( $text =~ m{\$VERSION}smx ) {
        my ($tv) = $text =~ m{([\d\.]+)}smx;
        Getopt::Auto::_set_their_version($tv);
        Getopt::Auto::_trace("Extracted version $tv from $text");
    }
    return $text;
}

1;

__END__