package Getopt::Long::EvenLess;

our $DATE = '2016-12-03'; # DATE
our $VERSION = '0.07'; # VERSION

# let's be minimalistic
#use strict 'subs', 'vars';
#use warnings;

our @EXPORT   = qw(GetOptions);
our @EXPORT_OK = qw(GetOptionsFromArray);

sub import {
    my $pkg = shift;
    my $caller = caller;
    my @imp = @_ ? @_ : @EXPORT;
    for my $imp (@imp) {
        if (grep {$_ eq $imp} (@EXPORT, @EXPORT_OK)) {
            *{"$caller\::$imp"} = \&{$imp};
        } else {
            die "$imp is not exported by ".__PACKAGE__;
        }
    }
}

sub GetOptionsFromArray {
    my ($argv, %spec) = @_;

    my $success = 1;

    my %spec_by_opt_name;
    for (keys %spec) {
        my $orig = $_;
        s/=[fios]\@?\z//;
        s/\|.+//;
        $spec_by_opt_name{$_} = $orig;
    }

    my $code_find_opt = sub {
        my ($wanted, $short_mode) = @_;
        my @candidates;
      OPT_SPEC:
        for my $spec (keys %spec) {
            $spec =~ s/=[fios]\@?\z//;
            my @opts = split /\|/, $spec;
            for my $o (@opts) {
                next if $short_mode && length($o) > 1;
                if ($o eq $wanted) {
                    # perfect match, we immediately go with this one
                    @candidates = ($opts[0]);
                    last OPT_SPEC;
                } elsif (index($o, $wanted) == 0) {
                    # prefix match, collect candidates first
                    push @candidates, $opts[0];
                    next OPT_SPEC;
                }
            }
        }
        if (!@candidates) {
            warn "Unknown option: $wanted\n";
            $success = 0;
            return undef; # means unknown
        } elsif (@candidates > 1) {
            warn "Option $wanted is ambiguous (" .
                join(", ", @candidates) . ")\n";
            $success = 0;
            return ''; # means ambiguous
        }
        return $candidates[0];
    };

    my $code_set_val = sub {
        my $name = shift;

        my $spec_key = $spec_by_opt_name{$name};
        my $handler  = $spec{$spec_key};

        $handler->({name=>$name}, @_ ? $_[0] : 1);
    };

    my $i = -1;
    my @remaining;
  ELEM:
    while (++$i < @$argv) {
        if ($argv->[$i] eq '--') {

            push @remaining, @{$argv}[$i+1 .. @$argv-1];
            last ELEM;

        } elsif ($argv->[$i] =~ /\A--(.+?)(?:=(.*))?\z/) {

            my ($used_name, $val_in_opt) = ($1, $2);
            my $opt = $code_find_opt->($used_name);
            if (!defined($opt)) {
                push @remaining, $argv->[$i];
                next ELEM;
            } elsif (!length($opt)) {
                next ELEM; # ambiguous
            }

            my $spec = $spec_by_opt_name{$opt};
            # check whether option requires an argument
            if ($spec =~ /=[fios]\@?\z/) {
                if (defined $val_in_opt) {
                    # argument is taken after =
                    $code_set_val->($opt, $val_in_opt);
                } else {
                    if ($i+1 >= @$argv) {
                        # we are the last element
                        warn "Option $used_name requires an argument\n";
                        $success = 0;
                        last ELEM;
                    }
                    $i++;
                    $code_set_val->($opt, $argv->[$i]);
                }
            } else {
                $code_set_val->($opt);
            }

        } elsif ($argv->[$i] =~ /\A-(.*)/) {

            my $str = $1;
          SHORT_OPT:
            while ($str =~ s/(.)//) {
                my $used_name = $1;
                my $opt = $code_find_opt->($1, 'short');
                next SHORT_OPT unless defined($opt) && length($opt);

                my $spec = $spec_by_opt_name{$opt};
                # check whether option requires an argument
                if ($spec =~ /=[fios]\@?\z/) {
                    if (length $str) {
                        # argument is taken from $str
                        $code_set_val->($opt, $str);
                        next ELEM;
                    } else {
                        if ($i+1 >= @$argv) {
                            # we are the last element
                            warn "Option $used_name requires an argument\n";
                            $success = 0;
                            last ELEM;
                        }
                        # take the next element as argument
                        $i++;
                        $code_set_val->($opt, $argv->[$i]);
                    }
                } else {
                    $code_set_val->($opt);
                }
            }

        } else { # argument

            push @remaining, $argv->[$i];
            next;

        }
    }

  RETURN:
    splice @$argv, 0, ~~@$argv, @remaining; # replace with remaining elements
    return $success;
}

sub GetOptions {
    GetOptionsFromArray(\@ARGV, @_);
}

1;
# ABSTRACT: Like Getopt::Long::Less, but with even less features

__END__

=pod

=encoding UTF-8

=head1 NAME

Getopt::Long::EvenLess - Like Getopt::Long::Less, but with even less features

=head1 VERSION

This document describes version 0.07 of Getopt::Long::EvenLess (from Perl distribution Getopt-Long-EvenLess), released on 2016-12-03.

=head1 DESCRIPTION

B<EXPERIMENTAL WORK>.

This module (GLEL for short) is a reimplementation of L<Getopt::Long> (GL for
short), but with much less features. It's an even more stripped down version of
L<Getopt::Long::Less> (GLL for short) and is perhaps less convenient to use for
day-to-day scripting work.

The main goal is minimum amount of code and small startup overhead. This module
is an experiment of how little code I can use to support the stuffs I usually do
with GL.

Compared to GL and GLL, it:

=over

=item * does not have Configure()

Nothing to configure, no different modes of operation. GLEL is equivalent to GL
in this mode: bundling, no_ignore_case, no_getopt_compat, gnu_compat, permute.

=item * does not support increment (C<foo+>)

=item * no type checking (C<foo=i>, C<foo=f>, C<foo=s> all accept any string)

=item * does not support optional value (C<foo:s>), only no value (C<foo>) or required value (C<foo=s>)

=item * does not support desttypes (C<foo=s@>)

=item * does not support handler other than coderef (so no C<< "foo=s" => \$scalar >>, C<< "foo=s" => \@ary >>, only C<< "foo=s" => sub { ... } >>)

Also, in coderef handler, code will get a simple hash instead of a "callback"
object as its first argument.

=item * does not support hashref as first argument

=item * does not support bool/negation (no C<foo!>, so you have to declare both C<foo> and C<no-foo> manually)

=back

The result?

B<Amount of code>. GLEL is about 175 lines of code, while GL is about 1500.
Sure, if you I<really> want to be minimalistic, you can use this single line of
code to get options:

 @ARGV = grep { /^--([^=]+)(=(.*))?/ ? ($opts{$1} = $2 ? $3 : 1, 0) : 1 } @ARGV;

and you're already able to extract C<--flag> or C<--opt=val> from C<@ARGV> but
you also lose a lot of stuffs like autoabbreviation, C<--opt val> syntax support
syntax (which is more common, but requires you specify an option spec), custom
handler, etc.

B<Startup overhead>. Here's a sample startup overhead benchmark:

                            Rate      run_gl     load_gl   run_gl_less  load_gl_less run_gl_evenless load_gl_evenless   perl
 run_gl            76.33+-0.31/s          --       -1.2%        -67.0%        -67.6%          -80.7%           -80.9% -87.5%
 load_gl           77.29+-0.31/s 1.26+-0.58%          --        -66.6%        -67.2%          -80.5%           -80.6% -87.4%
 run_gl_less      231.56+-0.31/s 203.4+-1.3% 199.6+-1.3%            --         -1.8%          -41.4%           -42.0% -62.1%
 load_gl_less     235.76+-0.29/s 208.9+-1.3%   205+-1.3%   1.81+-0.19%            --          -40.4%           -41.0% -61.4%
 run_gl_evenless    395.4+-2.2/s   418+-3.5% 411.5+-3.5%  70.74+-0.96%   67.7+-0.94%              --            -1.0% -35.3%
 load_gl_evenless   399.4+-1.1/s 423.2+-2.6% 416.7+-2.5%  72.48+-0.53%  69.41+-0.51%     1.02+-0.62%               -- -34.7%
 perl               611.2+-1.1/s 700.7+-3.6% 690.8+-3.5% 163.95+-0.61% 159.25+-0.58%     54.59+-0.9%     53.03+-0.51%     --
 
 Average times:
   perl            :     1.6361ms
   load_gl_evenless:     2.5038ms
   run_gl_evenless :     2.5291ms
   load_gl_less    :     4.2416ms
   run_gl_less     :     4.3185ms
   load_gl         :    12.9383ms
   run_gl          :    13.1010ms

=for Pod::Coverage .+

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Getopt-Long-EvenLess>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Getopt-Long-EvenLess>.

=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-EvenLess>

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>

L<Getopt::Long::Less>

If you want I<more> features intead of less, try L<Getopt::Long::More>.

=head1 AUTHOR

perlancar <perlancar@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 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
