Getopt::Long alternative prototype

GetoptSubset.pm

package GetoptSubset;
# Copyright 2017 Lukas Atkinson
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

use strict;
use warnings;

# This module is a lightweight alternative to Getopt::Long.
# Because we provide much less functionality it can be faster.
#
# A call to getopt() is more or less equivalent to:
#
#   my ($array, $opts) = map { ref $_[0] eq 'ARRAY' ? shift : $_ } \@ARGV, [];
#   $opts = [qw(default no_auto_abbrev no_ignore_case), @$opts];
#   state $require_once = require Getopt::Long;
#   my $save = Getopt::Long::Configure(@$opts);
#   Getopt::Long::GetOptionsFromArray($array, @_);
#   Getopt::Long::Configure($save);
#
# Supported types: foo! bool, foo=s string, foo=i int
#
# Supported Getopt::Long configuration flags: auto_abbrev pass_through ignore_case

use Carp ();

sub getopt {
  my $argv = ref $_[0] eq 'ARRAY' ? shift : \@ARGV;
  my $options = ref $_[0] eq 'ARRAY' ? shift : [];
  my %raw_spec = @_;

  return unless @$argv;

  my %opts;
  for my $opt (@$options) {
    if ($opt eq 'default') {
      %opts = (
        auto_abbrev => 1,
        ignore_case => 1,
        pass_through => 0,
      );
    }
    elsif ($opt =~ s/^no_//) {
      $opts{$opt} = 0;
    }
    else {
      $opts{$opt} = 1;
    }
  }

  my $opt_debug         = 0;
  my $opt_auto_abbrev   = delete $opts{auto_abbrev}     // 0;
  my $opt_ignore_case   = delete $opts{ignore_case}     // 0;
  my $opt_pass_through  = delete $opts{pass_through}    // 0;

  if (my @keys = sort keys %opts) {
    Carp::croak qq(getopt_fast: unsupported options: @keys);
  }

  my %type;
  my %short_handler;
  my %long_handler;
  my %known_types;

  _parse_specs(
    \%raw_spec, \%type, \%short_handler, \%long_handler, \%known_types,
    $opt_ignore_case, $opt_debug);

  $opt_debug and warn "# DEBUG args ", (join " " => map "[$_]", @$argv), "\n";

  my @passed_through;

  FLAG:
  while (defined(my $flag = shift @$argv)) {
    $opt_debug and warn "# DEBUG getopt flag: $flag\n";

    if ($flag eq '--') {
      push @passed_through, $flag if $opt_pass_through;
      last FLAG;
    }

    my $orig_flag = $flag;

    if ($flag =~ s/^(--[-\w]+)=//s) {
      my ($name, $value) = ($1, $flag);
      $name = lc $name if $opt_ignore_case;
      $name = _search_abbrev($name => \%long_handler) if $opt_auto_abbrev;

      my $handler = $long_handler{$name};
      my $type = $type{$name};

      unless ($handler) {
        Carp::croak qq(Unknown option $name) unless $opt_pass_through;
        push @passed_through, $orig_flag;
        last FLAG;
      }

      Carp::croak qq($name does not take a value)
      if $type eq '!';

      $opt_debug and warn "# DEBUG getopt flag resolved to $name = $type\n";
      $known_types{$type}->($name => $value);
      $handler->($name => $value);
      next FLAG;
    }
    elsif ($flag =~ /^--/) {
      my $name = $flag;
      $name = lc $name if $opt_ignore_case;
      $name = _search_abbrev($name => \%long_handler) if $opt_auto_abbrev;

      my $handler = $long_handler{$name};
      my $type = $type{$name};

      unless ($handler) {
        Carp::croak qq(Unknown option $name) unless $opt_pass_through;
        push @passed_through, $orig_flag;
        last FLAG;
      }

      $opt_debug and warn "# DEBUG getopt flag resolved to $name = $type\n";

      if ($type eq '!') {
        $handler->($name => 1);
        next FLAG;
      }

      my $value = shift @$argv;

      Carp::croak qq($name expected argument)
        unless defined $value and $value ne '--';

      $known_types{$type}->($name => $value);
      $handler->($name => $value);
      next FLAG;
    }
    elsif ($flag =~ s/^-(?=\w)//) {
      my @effects;

      SHORTFLAG:
      while (length $flag) {
        my $name = '-' . substr $flag, 0, 1;
        $flag = substr $flag, 1;
        $name = lc $name if $opt_ignore_case;

        my $handler = $short_handler{$name};
        my $type = $type{$name};

        unless ($handler) {
          Carp::croak qq(Unknown option $name) unless $opt_pass_through;
          push @passed_through, $orig_flag;
          last FLAG;
        }

        $opt_debug and warn "# DEBUG getopt flag resolved to $name = $type\n";

        if ($type eq '!') {
          push @effects, [$handler => $name => 1];
          next SHORTFLAG;
        }

        my $value = $flag;
        if (not length $value) {
          $value = shift @$argv;
          Carp::croak qq($name expected argument)
            unless defined $value and $value ne '--';
        }

        $known_types{$type}->($name => $value);
        push @effects, [$handler => $name => $value];
      }

      for my $effect (@effects) {
        my ($handler, $name, $value) = @$effect;
        $handler->($name => $value);
      }

      next FLAG;
    }

    push @passed_through, $orig_flag;
    last FLAG unless $opt_pass_through;
  }

  unshift @$argv, @passed_through;

  return;
}

sub _parse_specs {
  my ($raw_spec,
      $types,
      $short_handler,
      $long_handler,
      $known_types,
      $opt_ignore_case,
      $opt_debug) = @_;

  %$known_types = (
    '!' => sub { },
    's' => sub { },
    'i' => sub {
      my ($name, $value) = @_;
      $value =~ /^(?:0|-?[1-9][0-9]*)$/
        or Carp::croak qq($name must have integer value);
    },
  );

  while (my ($spec, $target) = each %$raw_spec) {
    $opt_debug and warn "# DEBUG parsing specifier $spec\n";

    my ($names, $type) = $spec =~ /^([\w\|\-]+)(?:=([!si]))?$/
      or Carp::croak qq(Unknown getopt specifier format: $spec);

    $type = '!' unless length $type;
    Carp::croak qq(Unknown type $type in getopt specifier "$spec")
      unless $known_types->{$type};

    my @names = split /\|/, $names
      or Carp::croak qq(Expected names in getopt specifier "$spec");

    my $cb;
    if (ref $target eq 'CODE'  ) {
      $cb = $target;
    }
    elsif (ref $target eq 'ARRAY' ) {
      $cb = sub {
        my ($name, $value) = @_;
        push @$target, $value;
      };
    }
    elsif (ref $target eq 'SCALAR') {
      $cb = sub {
        my ($name, $value) = @_;
        $$target = $value;
      };
    }
    else {
      Carp::croak qq(Unknown assignment target for getopt specifier "$spec");
    }

    if ($opt_debug) {
      my $actual_cb = $cb;
      $cb = sub { warn "# DEBUG assign @_\n"; $actual_cb->(@_) };
    }

    for my $name (@names) {
      $name = lc $name if $opt_ignore_case;

      if (length($name) == 1) {
        $types->{"-$name"} = $type;
        $short_handler->{"-$name"} = $cb;
      }
      else {
        $types->{"--$name"} = $type;
        $long_handler->{"--$name"} = $cb;
        if ($type eq '!') {
          my $negated_cb = sub { $cb->(shift, 0) };
          $types->{$_} = '!', $long_handler->{$_} = $negated_cb
            for "--no$name", "--no-$name";
        }
      }
    }
  }

  if ($opt_debug) {
    warn "# DEBUG registered $_ = $types->{$_}\n" for sort keys %$long_handler;
    warn "# DEBUG registered $_ = $types->{$_}\n" for sort keys %$short_handler;
  }
}


sub _search_abbrev {
  my ($name, $options) = @_;

  # return exact matches immediately
  return $name if $options->{$name};

  # search for match
  my @candidates = keys %$options;
  my @matches = grep { $name eq substr $_, 0, length $name } @candidates;

  return $name if !@matches;  # error produced later
  return shift @matches if @matches == 1;

  @matches = sort @matches;
  Carp::croak qq(Abbreviated option $name is ambiguous: @matches);
};


1;

__END__