File Coverage

blib/lib/Getopt/O2.pm

Criterion	Covered	Total	%
statement	275	302	91.0
branch	132	160	82.5
condition	33	42	78.5
subroutine	34	34	100.0
pod	6	14	42.8
total	480	552	86.9

##------------------------------------------------------------------------------
package Getopt::O2;

use 5.010;
use strict;
use warnings;

no if $] >= 5.017011, warnings => 'experimental::smartmatch';

our $VERSION = '1.1.0';
##------------------------------------------------------------------------------
use English '-no_match_vars';
use Readonly;
Readonly my $USAGE_MARGIN => 80;
Readonly my $USAGE_OPTIONS_LENGTH => 29;

use Carp 'confess';
use Scalar::Util 'looks_like_number';
##------------------------------------------------------------------------------
sub new
{
	my $class = ref $_[0] ? ref $_[0] : $_[0];
	my $self = bless {
		shortOptions => {},
		longOptions => {},
		options => {}
	}, $class;

	return $self
}
##------------------------------------------------------------------------------
sub getopt ## no critic (Subroutines::ProhibitExcessComplexity)
{
	my $self = shift;
	my $dest = shift;
	my $args = shift;
	my ($arg,$key,$rule,%context,@arguments);

	$self->{'options'} = {%$dest};
	$self->parse_rules();

	PROCESS_ARGUMENTS: while (@ARGV) {
		$arg = shift @ARGV;

		if (!defined $arg || !length $arg || '-' eq $arg || $arg !~ /^-/) {
			push @arguments, $arg;
			next PROCESS_ARGUMENTS;
		} elsif ('--' eq $arg) {
			push @arguments, @ARGV;
			last PROCESS_ARGUMENTS;
		}

		if ($arg !~ /^--/) {
			$key = (substr $arg, 1, 1);
			$rule = $self->{'shortOptions'}->{$key};
			$self->error('No such option "-%s"', $key)
				unless defined $rule;
			$rule = $self->{'longOptions'}->{$rule};

			if (length $arg > 2) {
				if ($rule->type) { ## no critic (ControlStructures::ProhibitDeepNests)
					unshift @ARGV, (substr $arg, 2);
				} else {
					unshift @ARGV, '-'.(substr $arg, 2);
				}
			}
		} else {
			$key = (substr $arg, 2);

			if (~(index $key, '=')) {
				($key,$arg) = (split /=/, $key, 2);
				unshift @ARGV, $arg;
			}

			$rule = $self->{'longOptions'}->{$key};
			unless (defined $rule) {
				$self->error('No such option "--%s"', $key)
					if 0 != (index $key, 'no-');
				$key = (substr $key, 3);
				$rule = $self->{'longOptions'}->{$key};

				$self->error('No such option "--no-%s" or negatable "--%s"', $key, $key)
					unless defined $rule && $rule->negatable;
				$rule->{'_negate'} = 1;
			}
		}

		if (defined $rule->context) {
			foreach (@{$rule->context->{'need'}}) {
				$self->error('Option "--%s" cannot be used in this context.', $rule->long)
					unless exists $context{$_};
			}

			delete $context{$_} foreach @{$rule->context->{'clear'}};
			$context{$_} = 1 foreach @{$rule->context->{'set'}};
		}

		if ($rule->multiple) {
			$self->{'options'}->{$rule->long} = 0
				unless exists $self->{'options'}->{$rule->long};
			++$self->{'options'}->{$rule->long};
			$rule->mark_used;
			next PROCESS_ARGUMENTS;
		}

		unless (defined $rule->type) {
			$arg = undef;
		} else {
			$arg = $self->get_value();
			$self->error('Option "--%s" requires a value.', $rule->long)
				unless defined $arg;

			delete $self->{'options'}->{$rule->long}
				if $rule->is_unused;

			$self->{'options'}->{$rule->long} = []
				if $rule->is_list && !defined $self->{'options'}->{$rule->long};

			given($rule->type) {
				when('s') {
				}

				when('i') {
					$self->error('Argument "%s" to "--%s" isn\'t numeric', $arg, $rule->long)
						unless looks_like_number($arg);
					$arg = int $arg;
				}

				when('?') {
					$self->error('Value "%s" to argument "--%s" is invalid.', $arg, $rule->long)
						unless $arg ~~ @{$rule->values || []};
				}
			}

			if ($rule->is_list) {
				if ('?' ne $rule->type) { ## no critic (ControlStructures::ProhibitDeepNests)
					push @{$self->{'options'}->{$rule->long}}, $arg;
				} else {
					push @{$self->{'options'}->{$rule->long}}, $arg
						unless ($rule->keep_unique && $arg ~~ @{$self->{'options'}->{$rule->long}});
				}

				$rule->mark_used;
				next PROCESS_ARGUMENTS;
			}
		}

		$rule->mark_used;

		if (defined $rule->action) {
			$arg = $rule->action->($arg, $key, $rule);
		} else {
			$arg = $rule->{'_negate'} ? '' : 1
				unless defined $arg;
		}

		$self->{'options'}->{$rule->long} = $arg;
	}

	$self->check_rule_obligations(%context);

	%$dest = %{$self->{'options'}};
	@$args = @arguments if ref $args;
	$self->{'options'} = {};
	return $self
}
##------------------------------------------------------------------------------
sub error
{
	return shift->usage(1, shift(), @_);
}
##------------------------------------------------------------------------------
# Returns program name for display in usage
sub get_program
{
	my $program = $ENV{_};
	$program =~ s{.*/([^/]+)$}{$1};
	$program = $PROGRAM_NAME if 'perl' eq $program;
	return $program;
}
##------------------------------------------------------------------------------
# Return short program description string; displayed in usage
sub get_program_description
{
	my $class = ref $_[0];
	return qq{another example of this programmer's lazyness: it forgot the description (and should implement ${class}::get_program_description())}
}
##------------------------------------------------------------------------------
sub get_value
{
	return unless @ARGV;
	my $value = $ARGV[0];
	return shift @ARGV
		if !defined $value || !length $value || '-' eq $value || $value !~ /^-/;
	return if $value ne '--';
	shift @ARGV;
	return unless @ARGV;
	$value = shift @ARGV;
	unshift @ARGV, '--';
	return $value;
}
##------------------------------------------------------------------------------
sub get_option_rules
{
	my $self = shift;

	return
		'h|help' => ['Display this help message', sub {$self->usage(0)}],
		'v|verbose+' => 'Increase program verbosity',
	undef
}
##------------------------------------------------------------------------------
sub parse_rules ## no critic (Subroutines::ProhibitExcessComplexity)
{
	my $self = shift;
	my @rules = $self->get_option_rules();

	## Perl Critic false positive on "$}" at the end of the reg-ex
	## no critic (Variables::ProhibitPunctuationVars)
	state $pattern = qr{^
	(?:(?P!))?
	(?:(?P[[:alpha:]])[|])?
	(?P[[:alpha:]](?:[[:alpha:]-]*)[[:alpha:]])
	(?:
		(?:=(?P[si?]@?))
		|
		(?P[+])
	)?
		$}x;
	## use critic

	my ($arg,$opt,@parsed);

	while (@rules) {
		$arg = shift @rules;
		unless (defined $arg) {
			push @parsed, undef if wantarray;
			next;
		}
		$opt = $arg;
		confess('Not enough rules') unless @rules;
		$arg = shift @rules;

		$arg = [$arg] unless ref $arg;
		confess("Invalid rule pattern '$opt'") if $opt !~ $pattern;
		my $rule = Getopt::O2::Rule->new($arg, %LAST_PAREN_MATCH);

		confess(sprintf q{Option spec '%s' redefines long option '%s'}, $opt, $rule->long)
			if exists $self->{'longOptions'}->{$rule->long};

		if (defined $rule->short) {
			confess(sprintf q{Option spec '%s' redefines short option '%s'}, $opt, $rule->short)
				if exists $self->{'shortOptions'}->{$rule->short};
			$self->{'shortOptions'}->{$rule->short} = $rule->long;
		}

		if (defined $rule->default) {
			$self->{'options'}->{$rule->long} = $rule->default;
		}

		$self->{'longOptions'}->{$rule->long} = $rule;
		push @parsed, $rule if wantarray
	}

	return $self unless wantarray;
	return @parsed;
}
##------------------------------------------------------------------------------
sub show_option_default_values
{
	return 1;
}
##------------------------------------------------------------------------------
sub check_rule_obligations
{
	my $self = shift;
	my %context = @_;
	my @missing = sort grep {
		is_rule_missing($self->{'longOptions'}->{$_}, %context)
	} keys %{$self->{'longOptions'}};

	return $self unless @missing;
	@missing = map {"`$_`"} @missing;
	my $one = 1 == scalar @missing;
	my $missing = $one
		? $missing[0]
		: sprintf '%s and %s', join(', ', @missing[0..$#missing-1]), $missing[-1];

	return $self->usage(1, 'Missing required option%s %s.', $one ? '' : 's', $missing);
}
##------------------------------------------------------------------------------
sub is_rule_missing
{
	my $rule = shift;
	my %context = @_;

	return unless $rule->required;
	return unless $rule->is_unused;
	return 1 unless $rule->context;

	foreach (@{$rule->context->{'need'}}) {
		return 1 if $context{$_};
	}

	return;
}
##------------------------------------------------------------------------------
sub usage ## no critic (Subroutines::ProhibitExcessComplexity)
{
	my $self = shift;
	my ($exitCode,$message,@args) = @_;

	if (defined $message) {
		$message = sprintf "Error: $message", @args;
	} else {
		$message = sprintf '%s - %s', $self->get_program(), $self->get_program_description();
	}

	print STDERR "$_\n"
		foreach wrap_string($message, 0, 8, $USAGE_MARGIN);
	printf STDERR "\nUsage: %s [options...]\n\nValid options:\n\n", $self->get_program();

	## no critic (Variables::ProhibitLocalVars)
	local $self->{'longOptions'} = undef;
	local $self->{'shortOptions'} = undef;
	## use critic

	my @rules = $self->parse_rules();
	my ($rule,$line,$long,$len,$show_default,$have_required);

	$show_default = $self->show_option_default_values();
	$have_required = 0;

	PROCESS_RULES: while (@rules) {
		#@type Getopt::O2::Rule
		$rule = shift @rules;

		unless (defined $rule) {
			print STDERR "\n";
			next PROCESS_RULES;
		}

		$line = '  ';
		$long = $rule->long;
		$long = "(no-)$long" if $rule->negatable;

		unless (defined $rule->short) {
			$long = "--$long";
		} else {
			$long = " [--$long]";
			$line .= '-'.$rule->short;
		}

		$line = "$line$long";
		$line .= ' ARG' if defined $rule->type;

		$line .= ' ' x ($USAGE_OPTIONS_LENGTH - $len)
			if $USAGE_OPTIONS_LENGTH > ($len = length($line) + 2);
		$line = "$line: ";
		print STDERR $line;

		print STDERR "$_\n"
			foreach wrap_string($rule->help($show_default), length $line, $USAGE_OPTIONS_LENGTH, $USAGE_MARGIN);
		$have_required ||= $rule->required;
	}

	print STDERR "\n";
	print STDERR "Options marked with '*' are required options.\n\n" if 0 != $have_required;
	exit $exitCode;
}
##------------------------------------------------------------------------------
sub wrap_string
{
	my ($string,$firstIndent,$leftIndent,$wrapAt) = @_;
	my (@lines,$len,$pos,$nChars);

	for ($nChars = $wrapAt - $firstIndent; length $string; $nChars = $wrapAt - $leftIndent) {
		$len = length $string;

		if ($len < $nChars) {
			push @lines, $string;
			last;
		}

		$pos = strrpos((substr $string, 0, $nChars), ' ');
		if (-1 == $pos) {
			push @lines, (substr $string, 0, $nChars);
			$string = (substr $string, $nChars);
		} else {
			push @lines, (substr $string, 0, $pos);
			$string = (substr $string, $pos + 1);
		}
	}

	if (@lines > 1) {
		my $indent = ' ' x $leftIndent;
		$lines[$_] = "$indent$lines[$_]" foreach (1..$#lines);
	}

	return @lines
}
##------------------------------------------------------------------------------
sub strrpos
{
	my ($string,$find) = @_;
	my ($length) = length $find;

	for (my $pos = length($string) - 1; $pos >= 0; --$pos) {
		return $pos if $find eq (substr $string, $pos, $length);
	}

	return -1
}
##------------------------------------------------------------------------------
package Getopt::O2::Rule; ## no critic (Modules::ProhibitMultiplePackages)

use strict;
use warnings;
use feature ':5.10';

use Carp 'confess';

BEGIN {
	## no critic (TestingAndDebugging::ProhibitNoStrict)
	no strict 'refs';
	foreach my $method (qw(action context default is_list keep_unique long multiple negatable required short type values)) {
		*{__PACKAGE__."::$method"} = sub {shift->{$method}}
	}
	## use critic
}

sub new ## no critic (Subroutines::ProhibitExcessComplexity)
{
	my $class = shift;
	my ($arg, %options) = @_;
	my (%rule);

	$rule{'long'} = $options{'long'};
	$rule{'short'} = $options{'short'} if exists $options{'short'};

	$rule{'negatable'} = $options{'negatable'} // 0;

	if ($options{'multiple'}) {
		$rule{'multiple'} = 1
	} elsif ($options{'type'}) {
		$rule{'type'} = (substr $options{'type'}, 0, 1);
		$rule{'is_list'} = ~(index $options{'type'}, '@');
		$rule{'keep_unique'} = $options{'keep_unique'} // 1
		if $rule{'is_list'};
	}

	$rule{'help'} = shift @$arg;
	$rule{'help'} =~ s/^\s+|\s+$//g;
	$rule{'help'} =~ s/\s+/ /g;
	$rule{'help'} .= '.' if $rule{'help'} !~ /[.]$/;

	if (@$arg) {
		$rule{'action'} = shift @$arg
		if 'CODE' eq ref $arg->[0];
		confess('Invalid rule options; the remainder is a list with uneven members')
		if 0 != (@$arg % 2);
		%rule = (%rule, @$arg);
	}

	$rule{'required'} //= 0;

	if ($rule{'required'}) {
		confess 'A rule cannot be required and have a default value' if exists $rule{'default'};
		confess 'A flag-rule cannot be required' unless exists $rule{'type'};
	}

	if (defined $rule{'context'}) {
		$rule{'context'} = [split /,/, $rule{'context'}];
		$rule{'context'} = {
			set => [map {(substr $_, 1)} grep {/^[+]/} @{$rule{'context'}}],
			clear => [map {(substr $_, 1)} grep {/^-/} @{$rule{'context'}}],
			need => [grep {/^[^+-]/} @{$rule{'context'}}],
		};
	}

	$rule{'_used'} = 0;

	return bless \%rule, $class
}
##------------------------------------------------------------------------------
sub is_unused
{
	return !shift->{'_used'};
}
##------------------------------------------------------------------------------
sub mark_used
{
	my $self = shift;
	$self->{'_used'} = 1;
	return $self;
}
##------------------------------------------------------------------------------
sub help
{
	my $self = shift;
	my $show_default = shift;
	my $obligation_suffix = $self->required ? ' *' : '';
	my $helpstr = $self->{'help'} . $obligation_suffix;

	unless (defined $self->{'type'}) { # flags
		return $helpstr;
	} elsif ('?' ne $self->{'type'}) { # anything but ENUM
		return $helpstr unless $show_default && defined $self->{'default'};

		$helpstr =~ s/\s*[.]\s*$//;
		return sprintf '%s (default: "%s").', $helpstr, $self->{'default'};
	} else {
		my @values = map {qq{"$_"}} @{$self->values};
		my $default_value = ($show_default && defined $self->{'default'})
			? (sprintf ' [default: "%s"]', $self->{'default'})
			: '';
		return $helpstr . (sprintf ' (ARG must be %s or %s)%s',
			(join ', ', @values[0..$#values-1]), $values[-1], $default_value);
	}
}
##------------------------------------------------------------------------------
1;
__END__