package Getopt::Long::EvenLess;

our $DATE = '2015-06-19'; # DATE
our $VERSION = '0.04'; # VERSION

use 5.010001;
use strict 'subs', 'vars';
# IFUNBUILT
# use warnings;
# END IFUNBUILT

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 =
                    if (length $val_in_opt) {
                        $code_set_val->($opt, $val_in_opt);
                    } else {
                        warn "Option $used_name requires an argument\n";
                        $success = 0;
                        next ELEM;
                    }
                } 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.04 of Getopt::Long::EvenLess (from Perl distribution Getopt-Long-EvenLess), released on 2015-06-19.

=head1 DESCRIPTION

B<EXPERIMENTAL WORK>.

This module is a reimplementation of L<Getopt::Long>, but with much less
features. It's an even more stripped down version of L<Getopt::Long::less> 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 Getopt::Long.

Compared to Getopt::Long and Getopt::Long::Less, it:

=over

=item * does not have Configure()

Nothing to configure, no different modes of operation.

=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

Sample startup overhead benchmark:

                            Rate     load_gl      run_gl run_gl_less run_gl_evenless load_gl_evenless load_gl_less   perl
 load_gl            76.8+-0.17/s          --       -0.7%      -50.0%          -64.0%           -67.3%       -69.2% -88.2%
 run_gl             77.3+-0.18/s 0.66+-0.32%          --      -49.6%          -63.8%           -67.1%       -69.0% -88.1%
 run_gl_less        153.5+-3.5/s  99.9+-4.5%  98.6+-4.5%          --          -28.1%           -34.7%       -38.4% -76.3%
 run_gl_evenless      213.5+-2/s   178+-2.7% 176.2+-2.7%  39.1+-3.4%              --            -9.2%       -14.3% -67.1%
 load_gl_evenless   235.2+-1.1/s 206.2+-1.6% 204.2+-1.6%  53.2+-3.5%      10.2+-1.2%               --        -5.6% -63.7%
 load_gl_less     249.14+-0.82/s 224.4+-1.3% 222.3+-1.3%  62.3+-3.7%      16.7+-1.2%      5.94+-0.62%           -- -61.6%
 perl               648.3+-1.9/s   744.2+-3% 738.7+-3.1% 322.4+-9.6%       203.7+-3%      175.7+-1.6%  160.2+-1.1%     --
 
 Average times:
   perl            :     1.5425ms
   load_gl_less    :     4.0138ms
   load_gl_evenless:     4.2517ms
   run_gl_evenless :     4.6838ms
   run_gl_less     :     6.5147ms
   run_gl          :    12.9366ms
   load_gl         :    13.0208ms

=for Pod::Coverage .+

=head1 SEE ALSO

L<Getopt::Long>

L<Getopt::Long::Less>

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

perlancar <perlancar@cpan.org>

=head1 COPYRIGHT AND LICENSE

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