—

              
## no critic: Modules::ProhibitAutomaticExportation
package Getopt::Long::More;
our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-04-08'; # DATE
our $DIST = 'Getopt-Long-More'; # DIST
our $VERSION = '0.007'; # VERSION
use strict;
use Exporter qw(import);
our @EXPORT    = qw(GetOptions optspec OptSpec);
our @EXPORT_OK = qw(HelpMessage VersionMessage Configure
                    GetOptionsFromArray GetOptionsFromString
                    OptionsPod);
sub optspec {
    Getopt::Long::More::OptSpec->new(@_);
}
# synonym for convenience
sub OptSpec {
    Getopt::Long::More::OptSpec->new(@_);
}
sub VersionMessage {
    require Getopt::Long;
    goto &Getopt::Long::VersionMessage;
}
sub Configure {
    require Getopt::Long;
    goto &Getopt::Long::Configure;
}
# copied verbatim from Getopt::Long, with a bit of modification (add my)
sub GetOptionsFromString(@) {
    my ($string) = shift;
    require Text::ParseWords;
    my $args = [ Text::ParseWords::shellwords($string) ];
    local $Getopt::Long::caller ||= (caller)[0];
    my $ret = GetOptionsFromArray($args, @_);
    return ( $ret, $args ) if wantarray;
    if ( @$args ) {
        $ret = 0;
        warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
    }
    $ret;
}
# copied verbatim from Getopt::Long
sub GetOptions(@) {
    # Shift in default array.
    unshift(@_, \@ARGV);
    # Try to keep caller() and Carp consistent.
    goto &GetOptionsFromArray;
}
my $_cur_opts_spec = [];
sub GetOptionsFromArray {
    require Getopt::Long;
    my $ary = shift;
    local $Getopt::Long::caller ||= (caller)[0];  # grab and set this asap.
    my @go_opts_spec;
    if ( ref($_[0]) ) {
      require Scalar::Util;
      if ( Scalar::Util::reftype ($_[0]) eq 'HASH') {
        push @go_opts_spec, shift;  # 'hash-storage' is now directly supported
      }
    }
    my @opts_spec = @_;
    # provide explicit --help|?, for completion. also, we need to override the
    # option destination to use our HelpMessage.
    if ($Getopt::Long::auto_help) {
        unshift @opts_spec, 'help|?' => optspec(
            destination => sub { HelpMessage() },
            summary => 'Print help message and exit',
        );
    }
    local $Getopt::Long::auto_help = 0;
    # provide explicit --version, for completion
    if ($Getopt::Long::auto_version) {
        unshift @opts_spec, 'version' => optspec(
            destination => sub { VersionMessage() },
            summary => 'Print program version and exit',
        );
    }
    local $Getopt::Long::auto_version = 0;
    # to allow our HelpMessage to generate usage/help based on options spec
    $_cur_opts_spec = [@opts_spec];
    # strip the optspec objects
    my $prev;
    my $has_arg_handler;
    my $arg_handler_accessed;
  MAPPING:  # Resulting in the complete EVAPORATION of OptSpec objects, replaced by their destination, if one exists.
      for my $e (@opts_spec) {
        unless ( ref($e) eq 'Getopt::Long::More::OptSpec' ) {
          push @go_opts_spec, $e;
          next;
        }
        next unless exists $e->{destination};
        if ( $prev  eq '<>' ) {
          $has_arg_handler++;
          push @go_opts_spec, sub {
            $arg_handler_accessed++;
            $e->{destination}->(@_);
          };
        } else {
          push @go_opts_spec, $e->{destination};
        }
    } continue {
      $prev = $e;
    }
    # if in completion mode, do completion instead of parsing options
  COMPLETION: {
        my $shell;
        if ($ENV{COMP_SHELL}) {
            ($shell = $ENV{COMP_SHELL}) =~ s!.+/!!;
        } elsif ($ENV{COMMAND_LINE}) {
            $shell = 'tcsh';
        } else {
            $shell = 'bash';
        }
        if ($ENV{COMP_LINE} || $ENV{COMMAND_LINE}) {
            my ($words, $cword);
            if ($ENV{COMP_LINE}) {
                require Complete::Bash;
                ($words,$cword) = @{ Complete::Bash::parse_cmdline(undef, undef, {truncate_current_word=>1}) };
                ($words,$cword) = @{ Complete::Bash::join_wordbreak_words($words, $cword) };
            } elsif ($ENV{COMMAND_LINE}) {
                require Complete::Tcsh;
                $shell //= 'tcsh';
                ($words, $cword) = @{ Complete::Tcsh::parse_cmdline() };
            }
            my %opt_completions;
            my $arg_completion;
            for (my $i=0; $i < @opts_spec; $i++) {
                if ($i % 2 == 0) {
                    my $o = $opts_spec[$i];
                    my $os = $opts_spec[$i+1];
                    if (ref($os) eq 'Getopt::Long::More::OptSpec') {
                        my $completion = $os->{completion};
                        next unless $completion;
                        if (ref $completion eq 'ARRAY') {
                            $completion = sub {
                                require Complete::Util;
                                my %args = @_;
                                Complete::Util::complete_array_elem(
                                    word => $args{word},
                                    array => $os->{completion},
                                );
                            };
                        }
                        if ($o eq '<>') {
                            $arg_completion = $completion;
                        } else {
                            $opt_completions{$o} = $completion;
                        }
                    }
                }
            }
            my $comp = sub {
                my %args = @_;
                if ($args{type} eq 'optval' && $opt_completions{ $args{ospec} }) {
                    return $opt_completions{ $args{ospec} }->(%args);
                } elsif ($args{type} eq 'arg' && $arg_completion) {
                    return $arg_completion->(%args);
                }
                undef;
            };
            require Complete::Getopt::Long;
            shift @$words; $cword--; # strip program name
            my $compres = Complete::Getopt::Long::complete_cli_arg(
                words => $words, cword => $cword, getopt_spec => {@go_opts_spec},
                completion => $comp,
                bundling => $Gteopt::Long::bundling,
            );
            if ($shell eq 'bash') {
                require Complete::Bash;
                print Complete::Bash::format_completion(
                    $compres, {word=>$words->[$cword], workaround_with_wordbreaks=>0});
            } elsif ($shell eq 'fish') {
                require Complete::Fish;
                print Complete::Bash::format_completion(
                    $compres, {word=>$words->[$cword]});
            } elsif ($shell eq 'tcsh') {
                require Complete::Tcsh;
                print Complete::Tcsh::format_completion($compres);
            } elsif ($shell eq 'zsh') {
                require Complete::Zsh;
                print Complete::Zsh::format_completion($compres);
            } else {
                die "Unknown shell '$shell'";
            }
            exit 0;
        }
    }
    my $res = Getopt::Long::GetOptionsFromArray($ary, @go_opts_spec);
    my $i = -1;
    for (@opts_spec) {
        $i++;
        if ($i > 0 && ref($_) eq 'Getopt::Long::More::OptSpec') {
            my $osname = $opts_spec[$i-1];
            # check required
            if ($_->{required}) {
                if ($osname eq '<>') {
                    if ($has_arg_handler) {
                        unless ($arg_handler_accessed) {
                            die "Missing required command-line argument\n";
                        }
                    } else {
                        unless (@{ $ary }) {
                            die "Missing required command-line argument\n";
                        }
                    }
                } elsif ( exists $_->{destination} ) {
                    if (ref($_->{destination}) eq 'SCALAR'
                            && !defined(${$_->{destination}})) {
                        die "Missing required option $osname\n";
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'ARRAY' &&
                                 !@{$_->{destination}}) {
                        die "Missing required option $osname\n";
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'HASH'
                                 && !keys(%{$_->{destination}})) {
                        die "Missing required option $osname\n";
                    }
                } else {
                    die "Can't enforce 'required' status without also knowing the 'destination' for option '$osname'. "
                        . "You need to provide a 'destination' to optspec() in order to benefit from that feature\n";
                }
            }
            # supply default value
            if (defined $_->{default}) {
                if ($osname eq '<>') {
                    # currently ignored
                } elsif ( exists $_->{destination} ) {
                    if (ref($_->{destination}) eq 'SCALAR'
                            && !defined(${$_->{destination}})) {
                        ${$_->{destination}} = $_->{default};
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'ARRAY' &&
                                 !@{$_->{destination}}) {
                        $_->{destination} = [@{ $_->{default} }]; # shallow copy
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'HASH' &&
                                 !keys(%{$_->{destination}})) {
                        $_->{destination} = { %{ $_->{default} } }; # shallow copy
                    }
                } else {
                    die "Can't assign 'default' without also knowing the 'destination' for option '$osname'. "
                        . "You need to provide a 'destination' to optspec() in order to benefit from that feature\n";
                }
            }
        }
    }
    $res;
}
sub HelpMessage {
    my $opts_spec = @_ ? [@_] : $_cur_opts_spec;
    my $i = -1;
    my @entries;
    my $max_opt_spec_len = 0;
    for (my $i=0; $i < @$opts_spec; $i++) {
        if ($i % 2 == 0) {
            # normalize dashes at the front
            my $osname = $opts_spec->[$i];
            next if $osname eq '<>';
            $osname =~ s/^-+//;
            (my $oname = $osname) =~ s/[=|].*//;
            $osname = length($oname) > 1 ? "--$osname" : "-$osname";
            push @entries, [$osname, "", "", 0, undef]; # [opt, summary, desc, required?, default]
            my $len = length($osname);
            $max_opt_spec_len = $len if $max_opt_spec_len < $len;
            my $os = $opts_spec->[$i+1];
            if (ref($os) eq 'Getopt::Long::More::OptSpec') {
                $entries[-1][1] ||= $os->{summary};
                $entries[-1][3] = 1 if $os->{required};
                $entries[-1][4] = $os->{default};
            }
        }
    }
    my $prog = $0;
    $prog =~ s!.+[/\\]!!;
    print join(
        "",
        "Usage: $prog [options]\n",
        "Options (* marks required option):\n",
        map {
            sprintf("  %-${max_opt_spec_len}s%s  %s%s\n",
                    $_->[0],
                    $_->[3] ? "*" : " ",
                    $_->[1],
                    defined($_->[4]) ? " (default: $_->[4])" : "",
                )
        } @entries,
    );
    exit 0;
}
sub OptionsPod {
    my $opts_spec = @_ ? [@_] : $_cur_opts_spec;
    my $i = -1;
    my @entries;
    for (my $i=0; $i < @$opts_spec; $i++) {
        if ($i % 2 == 0) {
            # normalize dashes at the front
            my $osname = $opts_spec->[$i];
            next if $osname eq '<>';
            $osname =~ s/^-+//;
            (my $oname = $osname) =~ s/[=|].*//;
            $osname = length($oname) > 1 ? "--$osname" : "-$osname";
            push @entries, [$osname, "", "", 0, undef]; # [opt, summary, desc, required?, default]
            my $os = $opts_spec->[$i+1];
            if (ref($os) eq 'Getopt::Long::More::OptSpec') {
                $entries[-1][1] ||= $os->{summary};
                $entries[-1][2] ||= $os->{description};
                $entries[-1][3] = 1 if $os->{required};
                $entries[-1][4] = $os->{default};
            }
        }
    }
    my @res;
    push @res, "=head1 OPTIONS\n\n";
    for (@entries) {
        my @notes;
        if ($_->[3]) { push @notes, "required" }
        if (defined $_->[4]) { push @notes, "default: $_->[4]" }
        push @res, "=head2 $_->[0]", (@notes ? " (".join(", ", @notes).")" : ""), "\n\n";
        push @res, "$_->[1]\n\n" if length $_->[1];
        push @res, "$_->[2]\n\n" if length $_->[2];
    }
    join("", @res);
}
package # hide from PAUSE indexer
    Getopt::Long::More::Internal::Util;
# TAU: Named this <GLM>::Internal::Util because <GLM>::Util was already taken on CPAN.
our @CARP_NOT = qw( Getopt::Long::More Getopt::Long::More::Internal::Util  Getopt::Long::More::OptSpec);
# The subroutines here (::Util) are intended to be pretty generic
# and so could also be used elsewhere later on.
sub map_args {
  my %o = %{; shift || {} };  # shallow copy
  my %p = (@_);
  my ($deprecated, $aliases,
      $deprecated_aliases) =  map {; $_ || {} } @p{qw/deprecated aliases deprecated_aliases/};
  my %deprecations =  ( %$deprecated, %$deprecated_aliases );
  my %synonyms     =  ( %$aliases,    %$deprecated_aliases );
  # Deprecated => warn
  while ( my ($k, $canon) = each %deprecations )  {
    next unless exists $o{$k};
    require Carp;
    Carp::carp( "'$k' is deprecated!",
                ( defined($canon) ? " You should use '$canon' instead." : () ),
                "\n"
              );
  }
  # Synonym => map to canonical key.
  while ( my ($k, $canon) = each %synonyms ) {
    next unless exists $o{$k};
    my $v = delete $o{$k};
    next unless defined $canon; #  if $canon key is undefined => disregard
    if  ( exists $o{$canon} ) {
      require Carp;
      Carp::croak( "'$k' may only be used as a synonym for '$canon'; not alongside it.", "\n" );
    }
    $o{$canon} = $v;
  }
  wantarray ? (%o) : \%o;
}
package # hide from PAUSE indexer
    Getopt::Long::More::OptSpec;
# Poor man's import....
*map_args = \&Getopt::Long::More::Internal::Util::map_args;
sub new {
    my $class = shift;
    my $obj   = map_args( { @_ }, deprecated_aliases => { handler => 'destination' } );
    for (keys %$obj) {
        next if /\A(x|x\..+|_.*)\z/;
        unless (/\A(required|default|summary|description|destination|completion)\z/) {
            die "Unknown optspec property '$_'";
        }
    }
    bless $obj, $class;
}
1;
# ABSTRACT: Like Getopt::Long, but with more stuffs
__END__
HideShow 273 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
Getopt::Long::More - Like Getopt::Long, but with more stuffs
=head1 VERSION
This document describes version 0.007 of Getopt::Long::More (from Perl distribution Getopt-Long-More), released on 2020-04-08.
=head1 SYNOPSIS
 use Getopt::Long::More; # imports GetOptions as well as optspec; you can also
                         # explicitly import Configure, GetOptionsFromArray,
                         # GetOptionsFromString
 my %opts;
 GetOptions(
     # just like in Getopt::Long
     'foo=s' => \$opts{foo},
     'bar'   => sub { ... },
     # but if you want to specify extra stuffs...
     'baz'   => optspec(
         # will be passed to Getopt::Long
         destination => \$opts{baz},
         # specify that this option is required
         required => 1,
         # specify this for default value
         default => 10,
         # specify this if you want nicer usage message
         summary => 'Blah blah blah',
         # specify longer (multiparagraphs) of text for POD, in POD format
         description => <<'_',
Blah blah ...
blah
Blah blah ...
blah blah
_
         # provide completion from a list of strings
         # completion => [qw/apple apricot banana/],
         # provide more advanced completion routine
         completion => sub {
             require Complete::Util;
             my %args = @_;
             Complete::Util::complete_array_elem(
                 word => $args{word},
                 array => [ ... ],
             );
         },
         # other properties: x or x.* or _* are allowed
         'x.debug' => 'blah',
         _app_code => {foo=>1},
     ),
 );
=head1 DESCRIPTION
This module is a wrapper and drop-in replacement for L<Getopt::Long>. It
provides the same interface as Getopt::Long and, unlike other wrappers like
L<Getopt::Long::Complete> or L<Getopt::Long::Modern> it does not change default
configuration and all Getopt::Long configuration are supported. In fact,
Getopt::Long::More behaves much like Getopt::Long until you start to use optspec
object as one or more option destinations.
=for Pod::Coverage ^(OptSpec)$
=head1 OPTSPEC OBJECT
In addition to using scalarref, arrayref, hashref, or coderef as the option
destination as Getopt::Long allows, Getopt::Long::More also allows using
optspec object as the destination. This enables you to specify more stuffs.
Optspec object is created using the C<optspec> function which accepts a list of property
name-property value pairs:
 '--fruit=s' => optspec(
     destination => \$opts{fruit},
     default => 'apple',
     summary => 'Supply name of fruit to order',
     completion => [qw/apple apricot banana/],
     ...
 )
All properties are optional.
=head2 destination =>  ScalarRef / ArrayRef / HashRef /  CodeRef
The C<destination> property, if present, will be passed to Getopt::Long when parsing options.
Note that, in previous versions of this module, C<destination> was referred to as C<handler>,
which is now B<deprecated>. At this time C<handler> is still being accepted as an
I<alias> for C<destination>, but do NOT count on that forever.
The name C<handler> will be discontinued at one point. You have been B<warned>.
In addition to C<destination>, these other properties
are also recognized:
=head2 required => bool
Set this to 1 to specify that the option is required.
=head2 default => any
Provide default for the option.
=head2 summary => str
Provide a short summary message for the option. This is used when generating
usage/help message.
=head2 description => str
Provide a longer (multiparagraph) text, in POD format. Will be used to generate
POD.
=head2 completion => array|code
Provide completion routine. Can also be a simple array of strings.
Completion routine will be passed a hash argument, with at least the following
keys: C<word> (str, the word to be completed). It is expected to return a
completion answer structure (see L<Complete> for mor edetails) which is usually
just an array of strings.
=head2 x, x.*, _* => any
You are allowed to have properties named C<x> or anything that begins with C<x.>
or C<_>. These are ignored by Getopt::Long::More. You can use store comments or
whatever additional information here.
=head1 FUNCTIONS
=head2 Configure
See Getopt::Long documentation.
=head2 GetOptionsFromArray
See Getopt::Long documentation.
=head2 GetOptionsFromString
See Getopt::Long documentation.
=head2 GetOptions
See Getopt::Long documentation.
=head2 HelpMessage(@opts_spec) => str
Will print a usage/help message and exit. Sample result:
 myapp [options]
 Options:
   --fruit=s     Supply name of fruit to order (default: apple)
   --debug       Enable debug mode
   --help|?      Print help message and exit
   --version     Print usage message and exit
=head2 VersionMessage
See Getopt::Long documentation.
=head2 OptionsPod(@opts_spec) => str
Will generate a POD containing list of options. The text will be taken from the
C<summary> and C<description> properties of optspec objects. Example result:
 =head1 OPTIONS
 =head2 --fruit|f=s
 Supply name of fruit to order.
 Blah blah blah
 blah blah ...
 =head2 --debug
 =head2 --version
 Display program version and exit.
 =head2 --help
 Display help message and exit.
=head2 optspec(%props) => obj
Create optspec object. See L</"OPTSPEC OBJECT">.
=head1 COMPLETION
Getopt::Long::Mode supports shell tab completion. To activate tab completion,
put your script (e.g. C<myapp.pl>) in C<PATH> and in bash shell type:
 % complete -C myapp.pl myapp.pl
You can then complete option names (or option values or command-line arguments
too, if you provide C<completion> properties). You can also use L<shcompgen> to
activate shell completion; shcompgen supports several shells and various
modules.
Tab completion functionality is provided by L<Complete::Getopt::Long>. Note that
this module assumes C<no_ignore_case> and does not support things like
C<getopt_compat> (starting option with C<+> instead of C<-->).
=head1 FAQ
=head2 How do I provide completion for command-line arguments:
Use the option spec C<< <> >>:
 GetOptions(
     ...
     '<>' => optspec(
         destination => \&process,
         completion => sub {
             ...
         },
     ),
 );
=head1 HOMEPAGE
Please visit the project's homepage at L<https://metacpan.org/release/Getopt-Long-More>.
=head1 SOURCE
Source repository is at L<https://github.com/perlancar/perl-Getopt-Long-More>.
=head1 BUGS
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Long-More>
When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.
=head1 SEE ALSO
L<Getopt::Long>
Other Getopt::Long wrappers that provide extra features:
L<Getopt::Long::Complete>, L<Getopt::Long::Descriptive>.
If you want I<less> features instead of more: L<Getopt::Long::Less>,
L<Getopt::Long::EvenLess>.
=head1 AUTHOR
perlancar <perlancar@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020, 2019, 2016 by perlancar@cpan.org.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut