## 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__

=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