File Coverage

blib/lib/Getargs/Long.pm

Criterion	Covered	Total	%
statement	197	217	90.7
branch	117	152	76.9
condition	36	47	76.6
subroutine	18	20	90.0
pod	4	4	100.0
total	372	440	84.5

# -*- Mode: perl -*-

use strict;
use 5.005;

package Getargs::Long;

use vars qw($VERSION @ISA @EXPORT);
$VERSION = sprintf "%d.%02d%02d", q/1.10.12/ =~ /(\d+)/g;

BEGIN
{
  die "This module is known to exercise a bug in 5.6.0. Please upgrade your perl.\n"
    if $] eq '5.006';
}

use Log::Agent;
use Data::Dumper;

require Exporter;
use vars qw(@EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(getargs cgetargs xgetargs cxgetargs);

#
# %ignore
#
# Cache whether argument names are to be handled case-insensitively or not,
# on a package basis.  Default is case-sensitive processing.
#
my %ignore = ();

#
# ->import
#
# Trap Exporter's one to handle 'ignorecase' here (or lack thereof).
# Then use ->export_to_level() to tell Exporter to continue the export
# as if its import method had been called directly via inheritance.
#
sub import {
	my $module = shift;
	my @syms = grep($_ ne 'ignorecase', @_);
	my $callpkg = caller;

	if (@syms == @_) {			# There was no "ignorecase" seen
		delete $ignore{$callpkg};
		logdbg 'info', "will process arguments case-sensitively in $callpkg";
	} else {
		$ignore{$callpkg} = 1;
		logdbg 'info', "will process arguments case-insensitively in $callpkg";
	}

	Getargs::Long->export_to_level(1, $module, @syms);
}

#
# %subcache
#
# Cache validation routine, indexed by "package::routine".
#
my %subcache = ();

#
# getargs
#
# Parse arguments for subroutine, and validate them if typechecking requested.
# Optional arguments with no default return undef.  Mandatory arguments cannot
# be undefined.
#
sub getargs (\@@) { _getargs(scalar(caller), 0, "", @_) } ## no critic (ProhibitSubroutinePrototypes)

#
# cgetargs
#
# Same as getargs, but cache data for next call.
#
# When called from within an eval, caching is not possible, so this routine
# must not be called.
#
sub cgetargs (\@@) { ## no critic (ProhibitSubroutinePrototypes)
	my $sub = (caller(1))[3];	# Anomaly in caller(), will also get pkg name
	logcroak "can't call cgetargs from within an eval"
		if $sub =~ /^\(eval/;
	_getargs(scalar(caller), 0, $sub, @_)
}

#
# xgetargs
#
# Like getargs(), but with extended specifications allowing to specify
# defaults for non-mandatory arguments.
#
sub xgetargs (\@@) { _getargs(scalar(caller), 1, "", @_) } ## no critic (ProhibitSubroutinePrototypes)

#
# cxgetargs
#
# Like cgetargs(), but with extended specifications allowing to specify
# defaults for non-mandatory arguments.  Be careful: those defaults are
# deep-cloned and "frozen", so to speak.
#
# When called from within an eval, caching is not possible, so this routine
# must not be called.
#
sub cxgetargs (\@@) { ## no critic (ProhibitSubroutinePrototypes)
	my $sub = (caller(1))[3];	# Anomaly in caller(), will also get pkg name
	logcroak "can't call cxgetargs from within an eval"
		if $sub =~ /^\(eval/;
	_getargs(scalar(caller), 1, $sub, @_)
}

#
# _getargs
#
# Factorized work for *getargs() routines
#
# Our signature is:
#
#    _getargs(
#		# arguments added by our wrappers
#		$callpkg, $extended, $subname,
#		# argument list to parse
#		\@x,
#		# optional switches
#		{
#			-strict			=> 1,		# unknown switches are fatal
#			-inplace		=> 1,		# edit \@x inplace: remove parsed args
#			-ignorecase		=> 1,		# override package's global
#			-extra			=> 0,		# suppress return of extra arguments
#		},
#		# argument definition list
#
#	);
#
# With:
#   $callpkg        Calling package
#   $extended       Are they using x*getargs()?
#   $subname        Cache key, if we use it
#
# Returns the list of values in the same order given in the definition list
# (the  part), followed by the extra arguments we did not recognize,
# with leading '-' removal and transformation to lowercase if ignorecase is on.
#
sub _getargs {
	my ($callpkg, $extended, $subname, $args) = splice(@_, 0, 4);

	logconfess "first argument must be a reference to the argument list"
		unless ref $args eq 'ARRAY';

	#
	# Check cache if told to do so.
	#

	if ($subname ne '') {
		my $sref = $subcache{$subname};
		if (defined $sref) {
			logdbg 'info', "calling cached subroutine $sref";
			return &$sref($args);
		} else {
			logdbg 'info', "no cached subroutine yet for $subname";
		}
	}

	#
	# Nothing in cache, or cache was disabled.
	#

	my $case_insensitive = $ignore{$callpkg} ? 1 : 0;
	logdbg 'info', "case_insensitive=$case_insensitive for package $callpkg";

	#
	# If next argument is a HASH, then it's a set of extra switches that
	# may alter our behaviour.  Parse them manually.
	#
	# Following are the defaults:
	#

	my $strict = 1;			# Fatal error on unknown switches
	my $inplace = 0;		# No inplace editing of arguments
	my $extra;				# Don't return extra args by default

	if (ref $_[0] eq 'HASH') {
		my $swref = shift;

		my %set = (
			-strict			=> \$strict,
			-ignorecase		=> \$case_insensitive,
			-inplace		=> \$inplace,
			-extra			=> \$extra,
		);

		while (my ($sw, $val) = each %$swref) {
			my $vset = $set{lc($sw)};
			logcroak "unknown switch $sw" unless ref $vset;
			$$vset = $val;
		}

		#
		# If they did not set -extra, compute suitable default: false
		# when -strict, true otherwise.
		#

		$extra = $strict ? 0 : 1 unless defined $extra;

		#
		# If strict, we ignore true settings for -inplace and -extra
		#

		if ($strict) {
			if ($inplace) {
				logcarp "ignoring -inplace when -strict";
				$inplace = 0;
			}
			if ($extra) {
				logcarp "ignoring -extra when -strict";
				$extra = 0;
			}
		}
	}

	#
	# If we have one argument, it may be '[list]' or 'x'.
	# In extended mode, we must have an even amount of arguments.
	#

	my @specs;				# User specification list
	my $all_optional = 0;	# True if all arguments are optional

	if (@_ == 1 && ref $_[0]) {
		logcroak "must use an array reference for optional args"
			unless ref $_[0] eq 'ARRAY';
		@specs = @{$_[0]};
		$all_optional = 1;
	} else {
		@specs = @_;
		logcroak "must supply an even amount of arguments in extend mode"
			if $extended && (@specs % 2);
	}

	#
	# Parse our argument list and compile it into @args
	#

	my %seen;
	my @args;				# List of [name, type, is_optional, default]

	for (my $i = 0, my $step = $extended ? 2 : 1; $i < @specs; $i += $step) {
		my $arg = $specs[$i];
		my ($name, $type, $optional, $dflt);
		if ($extended) {
			$name = $arg;
			my $spec = $specs[$i+1];
			if (ref $spec) {
				# Given as an array ref -> optional, with possible default
				logcroak "specs for optional '$name' are $spec, expected ARRAY"
					unless ref $spec eq 'ARRAY';
				($type, $dflt) = @$spec;
				$optional = 1;
			} else {
				# simple scalar is type, argument is mandatory
				$type = $spec;
				$optional = 0;
			}
		} else {
			# Can be either "name" or "name=Type"
			($name, $type) = $arg =~ /^-?(\w+)=(\S+)/;
			$name = $arg unless defined $name;
			$optional = $all_optional;
		}

		$name = lc($name) if $case_insensitive;
		$name =~ s/^-//;

		logcroak "argument name cannot be empty" if $name eq '';
		logcroak "argument name must be scalar, not $name" if ref $name;
		logcroak "duplicate argument definition for '$name'" if $seen{$name}++;

		push(@args, [
			$name,
			defined($type) ? $type : undef,
			$optional,
			defined($dflt) ? $dflt : undef
		]);
	}

	#
	# If caching, generate the subroutine that will perform the checks.
	#
	# We use logxcroak to report errors to the caller of the caller
	# of *getargs, i.e. the caller of the routine for which we're checking
	# the arguments.
	#

	if ($subname ne '') {
		my $lc = $case_insensitive ? 'lc' : '';
		my $sub = &_q(<<'EOS');
:sub {
:	my $aref_orig = shift;
:	my @result;
:	my $cur;
:	my $isthere;
:	my $ctype;
:	local $Getargs::Long::dflt;
:	my $i = 0;
EOS
		$sub .= &_q(<
:	logxcroak 3, "expected an even number of arguments" if \@\$aref_orig % 2;
:
:	my \%args = map {
:		(\$i++ % 2) ? \$_ : $lc(/^-/ ? substr(\$_, 1) : \$_) } \@\$aref_orig;
EOS

		# Sanity check: no argument can be given twice
		$sub .= &_q(<
:	_spot_dups(\$aref_orig, $case_insensitive, 3)
:		if 2 * scalar(keys \%args) != \@\$aref_orig;
:
EOS
		# Work on a copy if extra and no inplace
		if ($extra && !$inplace) {
			$sub .= &_q(<<'EOS');
:	my $aref = [@$aref_orig];
EOS
		} else {
			$sub .= &_q(<<'EOS');
:	my $aref = $aref_orig;
EOS
		}

		# Index arguments if inplace editing or extra
		if ($inplace || $extra) {
			$sub .= &_q(<<'EOS');
:
:	my $idx;
:	my %idx;
:	for (my $j = 0; $j < @$aref; $j += 2) {
:		my $key = $aref->[$j];
:		$key =~ s/^-//;
EOS
			$sub .= &_q(<<'EOS') if $case_insensitive;
:		$key = lc($key);
EOS
			$sub .= &_q(<<'EOS');
:		$idx{$key} = $j;
:	}
:
EOS
		}

		foreach my $arg (@args) {
			my ($name, $type, $optional, $dflt) = @$arg;
			my $has_default = defined $dflt;
			local $^W = 0;		# Shut up Test::Harness
			$sub .= &_q(<
:	# Argument [name=$name, type=$type, optional=$optional, dflt=$dflt]
:	\$cur = undef;
:	\$isthere = 0;
:	if (exists \$args{$name}) {
:		\$isthere = 1;
:		my \$val = delete \$args{$name};
:		\$cur = \\\$val;
EOS
			$sub .= &_q(<
:		# Splice argument out
:		\$idx = \$idx{$name};
EOS
			$sub .= &_q(<<'EOS') if $inplace || $extra;
:		splice(@$aref, $idx, 2);
:		while (my ($k, $v) = each %idx) {
:			$idx{$k} -= 2 if $v > $idx;
:		}
EOS
			$sub .= &_q(<<'EOS');
:	}
EOS
			if ($optional) {
				if ($has_default) {
					$sub .= &_q(<
:	else {
:		eval {
:			package Getargs::Long::_;
:			no strict;
:			\$Getargs::Long::dflt =
EOS
					my $obj = Data::Dumper->new([$dflt], []);
					$obj->Purity(1);
					$sub .= $obj->Dumpxs;
					$sub .= &_q(<<'EOS');
:		};
:		$cur = \$Getargs::Long::dflt;
:	}
EOS
				}
			} else {
				$sub .= &_q(<
:	logxcroak 3, "mandatory argument '$name' missing" unless \$isthere;
EOS
			}
			if ($type ne '') {
				if ($optional) {
					$sub .= &_q(<
:	logxcroak 3, "argument '$name' cannot be undef"
:		if \$isthere && !defined \$\$cur;
EOS
				} else {
					$sub .= &_q(<
:	logxcroak 3, "argument '$name' cannot be undef" unless defined \$\$cur;
EOS
				}
				my $opt_is_there = $optional ? "\$isthere &&" : "";
				if ($type =~ /^[isn]$/) {		# Make sure it's a scalar
					# XXX Check that i is integer, s string and n natural
					$sub .= &_q(<
:	logxcroak 3,
:		"argument '$name' must be scalar (type '$type') but is \$\$cur"
:		if $opt_is_there ref \$\$cur;
EOS
				} else {
					$sub .= &_q(<
:	\$ctype = \$isthere ? ref \$\$cur : undef;
:	logxcroak 3, "argument '$name' must be of type $type but is \$ctype"
:		if $opt_is_there (UNIVERSAL::isa(\$\$cur, 'UNIVERSAL') ?
:			!\$\$cur->isa('$type') :
:			\$ctype ne '$type');
EOS
				}
			}
			$sub .= &_q(<<'EOS');
:	push(@result, defined($cur) ? $$cur : undef);
:
EOS
		}

		# If we're strict, we must report unprocessed switches
		$sub .= &_q(<<'EOS') if $strict;
:
:	_spot_unknown(\%args, 3) if scalar keys %args;
:
EOS

		# Add extra unprocessed switches to the result list
		$sub .= &_q(<<'EOS') if $extra;
:	push(@result, @$aref);
EOS
		$sub .= &_q(<<'EOS');
:	return @result;
:}
EOS
		logdbg 'debug', "anonymous subroutine: $sub";
		my $code = eval $sub; ## no critic (ProhibitStringyEval)
		if (chop($@)) {
			logerr "can't create subroutine for checking args of $subname: $@";
			logwarn "ignoring caching directive for $subname";
		} else {
			$subcache{$subname} = $code;
			logdbg 'info', "calling newly built subroutine $code";
			return &$code($args);
		}
	}

	#
	# No caching made, perform validation by interpreting the structure
	#
	# There is some unfortunate code duplication between the following checks
	# and the above routine-construction logic.  Some place are identical,
	# but the main argument processing loop is noticeably different, even
	# though the same logic is used.
	#

	logdbg 'info', "interpreting structure to validate arguments";

	my @result;
	my $cur;
	my $ctype;

	my $i = 0;
	my %args;

	$args = [@$args] if $extra && !$inplace;	# Work on a copy

	logxcroak 2, "expected an even number of arguments" if @$args % 2;

	if ($case_insensitive) {
		%args = map { ($i++ % 2) ? $_ : lc(/^-/ ? substr($_, 1) : $_) } @$args;
	} else {
		%args = map { ($i++ % 2) ? $_ :   (/^-/ ? substr($_, 1) : $_) } @$args;
	}

	# Sanity check: no argument can be given twice
	_spot_dups($args, $case_insensitive, 2)
		if 2 * scalar(keys %args) != @$args;

	# Index arguments if inplace editing or extra
	my %idx;
	if ($inplace || $extra) {
		for (my $j = 0; $j < @$args; $j += 2) {
			my $key = $args->[$j];
			$key =~ s/^-//;
			$key = lc($key) if $case_insensitive;
			$idx{$key} = $j;
		}
	}

	# Process each argument
	foreach my $arg (@args) {
		my ($name, $type, $optional, $dflt) = @$arg;
		my $cur;
		my $isthere = 0;
		if (exists $args{$name}) {
			$isthere = 1;
			my $val = delete $args{$name};
			$cur = \$val;

			# Splice argument out if requested
			if ($inplace || $extra) {
				my $idx = $idx{$name};
				splice(@$args, $idx, 2);
				while (my ($k, $v) = each %idx) {
					$idx{$k} -= 2 if $v > $idx;
				}
			}
		} elsif ($optional) {
			$cur = \$dflt if defined $dflt;
		} else {
			logxcroak 2, "mandatory argument '$name' missing";
		}

		push(@result, defined($cur) ? $$cur : undef);
		next if !defined $type || $type eq '';

		if ($optional) {
			logxcroak 2, "argument '$name' cannot be undef"
				if $isthere && !defined $$cur;
		} else {
			logxcroak 2,
				"argument '$name' cannot be undef" unless defined $$cur;
		}

		# XXX Check that i is integer, s string and n natural
		if ($type =~ /^[isn]$/) {		# Make sure it's a scalar
			logxcroak 2,
				"argument '$name' must be scalar (type '$type') but is $$cur"
				if (!$optional || $isthere) && ref $$cur;
		} else {
			my $ctype = $isthere ? ref $$cur : undef;
			logxcroak 2, "argument '$name' must be of type $type but is $ctype"
				if (!$optional || $isthere) &&
					(UNIVERSAL::isa($$cur, 'UNIVERSAL') ?
						!$$cur->isa($type) :
						$ctype ne $type);
		}
	}

	# If we're strict, we must report unprocessed switches
	_spot_unknown(\%args, 2) if $strict && scalar keys %args;

	# Add extra unprocessed switches to the result list
	push(@result, @$args) if $extra;

	return @result;
}

#
# _spot_dups
#
# Given a list of arguments in $aref, where we know there are duplicate "keys",
# identify them and croak by listing the culprits.
#
sub _spot_dups {
	my ($aref, $ignorecase, $level) = @_;
	my %seen;
	my @duplicates;
	for (my $i = 0; $i < @$aref; $i += 2) {
		my $key = $ignorecase ? lc($aref->[$i]) : $aref->[$i];
		$key =~ s/^-//;
		push(@duplicates, "-$key") if $seen{$key}++;
	}
	logconfess "bug in Getargs::Long -- should have found duplicates"
		unless @duplicates;
	logxcroak ++$level,
		"multiple switches given for: " . join(", ", @duplicates);
}

#
# _spot_unknown
#
# Report keys held in supplied hashref as unknown switches.
#
sub _spot_unknown {
	my ($href, $level) = @_;
	my @unprocessed = map { "-$_" } keys %$href;
	my $es = @unprocessed == 1 ? '' : 'es';
	logxcroak ++$level, "unknown switch$es: " . join(", ", @unprocessed);
}

sub _q {
	local $_ = shift;
	s/^://gm;
	return $_;
}

1;

__END__