Skip to content

Instantly share code, notes, and snippets.

@latk latk/GetoptSubset.pm
Created Sep 19, 2017

Embed
What would you like to do?
Getopt::Long alternative prototype
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__
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.