File Coverage

blib/lib/Getopt/O2.pm

Criterion	Covered	Total	%
statement	256	270	94.8
branch	129	138	93.4
condition	29	35	82.8
subroutine	32	32	100.0
pod	5	12	41.6
total	451	487	92.6

##------------------------------------------------------------------------------
## $Id: O2.pm 887 2016-08-29 12:57:34Z schieche $
##------------------------------------------------------------------------------
package Getopt::O2;

use 5.010;
use strict;
use warnings;

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

our $VERSION = '1.0.20';
##------------------------------------------------------------------------------
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->parseRules();

		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};
				next PROCESS_ARGUMENTS;
			} elsif(!defined $rule->type) {
				$arg = undef;
			} else {
				$arg = $self->getValue();
				$self->error('Option "--%s" needs a mandatory value.', $rule->long)
					unless defined $arg;

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

				$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}});
					}
					next PROCESS_ARGUMENTS;
				}
			}

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

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

		%$dest = %{$self->{'options'}};
		@$args = @arguments if ref $args;
		$self->{'options'} = {};
		return $self
	}
##------------------------------------------------------------------------------
sub error
	{
		return shift->usage(1, shift(), @_);
	}
##------------------------------------------------------------------------------
sub getProgram
	{
		my $program = $ENV{_};
		$program =~ s{.*/([^/]+)$}{$1};
		$program = $PROGRAM_NAME if 'perl' eq $program;
		return $program;
	}
##------------------------------------------------------------------------------
sub getProgramDescription
	{
		my $class = ref $_[0];
		return qq{another example of this programmer's lazyness: it forgot the description (and should implement ${class}::getProgramDescription())}
	}
##------------------------------------------------------------------------------
sub getValue
	{
		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 getOptionRules
	{
		my $self = shift;

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

		## 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 showOptionDefaultValues
	{
		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->getProgram(), $self->getProgramDescription();
		}

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

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

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

		$show_default = $self->showOptionDefaultValues();

		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 wrapString($rule->help($show_default), length $line, $USAGE_OPTIONS_LENGTH, $USAGE_MARGIN);
		}

		print STDERR "\n";
		exit $exitCode;
	}
##------------------------------------------------------------------------------
sub wrapString
	{
		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 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'} = 1 if $options{'negatable'};
		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);
		}

		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;

		unless (defined $self->{'type'}) { # flags
			return $self->{'help'};
		} elsif ('?' ne $self->{'type'}) { # anything but ENUM
			my $helpstr = $self->{'help'};

			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 $self->{'help'} . (sprintf ' (ARG must be %s or %s)%s',
				(join ', ', @values[0..$#values-1]), $values[-1], $default_value);
		}
	}
##------------------------------------------------------------------------------
1;
__END__