File Coverage

blib/lib/Getopt/Long/EvenLess.pm

Criterion	Covered	Total	%
statement	105	112	93.7
branch	47	58	81.0
condition	3	3	100.0
subroutine	5	6	83.3
pod	3	3	100.0
total	163	182	89.5

package Getopt::Long::EvenLess;

our $DATE = '2017-08-09'; # DATE
our $VERSION = '0.110'; # VERSION

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

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

my $config = {
    pass_through => 0,
};

sub Configure {
    my $old_config = { %$config };

    if (ref($_[0]) eq 'HASH') {
        for (keys %{$_[0]}) {
            $config->{$_} = $_[0]{$_};
        }
    } else {
        for (@_) {
            if ($_ eq 'pass_through') {
                $config->{pass_through} = 1;
            } elsif ($_ eq 'no_pass_through') {
                $config->{pass_through} = 0;
            } else {
                die "Unknown configuration '$_'";
            }
        }
    }
    $old_config;
}

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) {
            unless ($config->{pass_through}) {
                warn "Unknown option: $wanted\n";
                $success = 0;
            }
            return undef; # means unknown
        } elsif (@candidates > 1) {
            unless ($config->{pass_through}) {
                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)) {
                # unknown option
                push @remaining, $argv->[$i];
                next ELEM;
            } elsif (!length($opt)) {
                push @remaining, $argv->[$i];
                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;
            my $remaining_pushed;
          SHORT_OPT:
            while ($str =~ s/(.)//) {
                my $used_name = $1;
                my $short_opt = $1;
                my $opt = $code_find_opt->($short_opt, 'short');
                if (!defined $opt) {
                    # unknown short option
                    push @remaining, "-" unless $remaining_pushed++;
                    $remaining[-1] .= $short_opt;
                    next SHORT_OPT;
                } elsif (!length $opt) {
                    # ambiguous short option
                    push @remaining, "-" unless $remaining_pushed++;
                    $remaining[-1] .= $short_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
                            unless ($config->{pass_through}) {
                                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__