File Coverage

blib/lib/Getopt/Std/WithCheck.pm

Criterion	Covered	Total	%
statement	12	38	31.5
branch	0	4	0.0
condition			n/a
subroutine	4	6	66.6
pod	2	2	100.0
total	18	50	36.0

package Getopt::Std::WithCheck;

use 5.008004;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Getopt::Std::WithCheck ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.04';

##############################################################################
## Some modules required #####################################################
##############################################################################
use Getopt::Std;

##############################################################################
## Ok, methods here ##########################################################
##############################################################################

my $usage = '';

my $checkHArg = sub
    {
    if ($_[0])
        {
        print STDERR usage();
        exit 0;
        };
    return 0;
    };

my $checkHOpt = sub
	{
	my ($opts) = @_;

	foreach my $opt (@{$opts})
		{
		if ($opt->[0] eq 'h')
			{ return; };
		};
	unshift(@{$opts}, ['h', 0, 0, 'Print help notice, and exit', $checkHArg]);
	};

my $addLF = sub
	{ return $_[0].($_[0] =~ m/\n$/ ? '' : "\n"); };

my $makeOpts = sub
	{
	my ($opts) = @_;

	my $result = '';
	foreach my $opt (@{$opts})
		{ $result .= $opt->[0].($opt->[1] ? ':' : ''); };
	return $result;
	};

my $makeCfg = sub
	{
	my ($opts) = @_;

	my %result = ();
	foreach my $opt (@{$opts})
		{ $result{$opt->[0]} = $opt->[2]; };
	return \%result;
	};

my $defaultCheck = sub
	{ return $_[0]; };

my $makeChk = sub
	{
	my ($opts) = @_;

	my %result = ();
	foreach my $opt (@{$opts})
		{ $result{$opt->[0]} = defined($opt->[4]) ? $opt->[4] : $defaultCheck; };
	return %result;
	};

my $makeUsage = sub
	{
	my ($opts) = @_;

	my $result = '';

	foreach my $opt (@{$opts})
		{
		$result .= sprintf("-%s: %s\t%s\n",
		                   $opt->[0],
		                   &{$addLF}($opt->[3]),
		                   defined($opt->[2]) ? 'Default is \''.($opt->[1] ? $opt->[2] : ($opt->[2] ? 'Yes' : 'No')).'\'' : 'Parameter required'
		                  );
		};
	return $result;
	};


my $setUsage = sub
	{
	my ($name, $descr, $opts) = @_;
	$usage = &{$addLF}($name).&{$addLF}($descr).&{$addLF}(&{$makeUsage}($opts)).($^W ? "\ngetops string is '".&{$makeOpts}($opts)."'\n" : '');
	};

my $checkOpts = sub
	{
	my ($opts) = @_;

	if (ref($opts) eq 'HASH')
		{
		my @tmpOpts = ();
		while(my ($key, $val) = each(%{$opts}))
			{
			push(@tmpOpts, [$key,
			                $val->{'argument'},
			                $val->{'default'},
			                $val->{'description'},
			                $val->{'checkRoutine'},
			               ]
			    );
			};
		$opts = \@tmpOpts;
		};

	&{$checkHOpt}($opts);

	return $opts;
	};

sub getOpts($$$)
	{
	my ($name, $descr, $opts) = @_;

	my $self = undef;

	$opts = &{$checkOpts}($opts);

	&{$setUsage}($name, $descr, $opts);

	my $conf  = &{$makeCfg}($opts);
	my %check = &{$makeChk}($opts);

	Getopt::Std::getopts(&{$makeOpts}($opts), $conf);

	foreach my $key (keys(%{$conf}))
		{
		if (!defined($conf->{$key}))
			{ die "Required param '".$key."' is not set\n\n".usage(); };

		$conf->{$key} = &{$check{$key}}($conf->{$key});
		};

	return $conf;
	};

sub usage
	{
	my ($name, $descr, $opts) = @_;
	if (scalar(@_) > 0)
		{
		$opts = &{$checkOpts}($opts);
		&{$setUsage}($name, $descr, $opts);
		};
	return $usage;
	};


1;
__END__