File Coverage

blib/lib/Script/Toolbox/Util/Opt.pm

Criterion	Covered	Total	%
statement	83	170	48.8
branch	24	76	31.5
condition	9	15	60.0
subroutine	16	23	69.5
pod	0	5	0.0
total	132	289	45.6

package Script::Toolbox::Util::Opt;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Getopt::Long;
use IO::File;

require Exporter;

@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.
@EXPORT = qw(
);
#$VERSION = '';


# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

#------------------------------------------------------------------------------
# Create a new Opt object.
#------------------------------------------------------------------------------
sub new
{
	my $classname = shift;
	my $optDef	  = shift; # options definition
	my $caller	  = shift; # may be omited

	$optDef = {}	if( !defined $optDef );
	$optDef = {}	if( ref $optDef ne 'HASH' );
	$optDef = {}	if( scalar keys %{$optDef} == 0  );
	_addDefaultOptions( \$optDef );
	return	undef	if( _invalidOptDef( $optDef ));
	my $self = {};
	bless( $self, $classname );
	$self->_instCaller($caller);

	my $rc = $self->_init( $optDef, @_ );
	exit $rc if( $rc != 0 );

	return $self;
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _invalidOptDef($)
{
	my ($optDef) = @_;

	foreach my $val ( values %{$optDef} )
	{
		return 1	if( ref $val ne 'HASH' );
		return 1	if( scalar keys %{$val} == 0 );
		foreach my $key ( keys %{$val} )
		{
			return 1 if( $key ne 'mod' 	&& $key ne 'desc'&&
						 $key ne 'mand'	&& $key ne 'default' );
		}
	}
	return 0;
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _instCaller(@)
{
	my ($self, $call) = @_;

	my @caller = caller();
	$self->{'caller'} = defined $call ? $call : \@caller;
}

#------------------------------------------------------------------------------
# Get the options definition as input. Read the options from command line.
# Write usage message to STDERR if missing mandatory options.
#------------------------------------------------------------------------------
sub _init()
{
	my ( $self, $ops, $addUsage ) = @_;

	$self->{'opsDef'} 	= _normalize($ops);
	$self->{'addUsage'}	= defined $addUsage ? $addUsage :''; # additional usage text
	return $self->_processCmdLine();
}

#------------------------------------------------------------------------------
# Used for compatibility with old $ops format (array).
#------------------------------------------------------------------------------
sub _normalize($)
{
	my ($ops) = @_;

	return $ops		if( ref $ops eq 'HASH' );

	my %o;
	foreach my $old ( @{$ops} )
	{
		my $op = $old->{'op'};
		my $mod= $op;
		   $mod=~ s/^[^:=]+//;
		   $op =~ s/[:=].*$//;
		my %oo;
		$oo{'mod'}		= $mod				if( $mod ne '' );
		$oo{'desc'}		= $old->{'desc'}	if( defined $old->{'desc'});
		$oo{'mand'}		= $old->{'mand'}	if( defined $old->{'mand'});
		$oo{'default'}	= $old->{'default'}	if( defined $old->{'default'});

		$o{$op} = \%oo;
	}
	return \%o;
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _addDefaultOptions
{
	my ($optDef) = @_;

	if( ! defined $$optDef->{'help'} )
	{
		$$optDef->{help} = {desc=>'Print online docu.'};
	}
}

#------------------------------------------------------------------------------
# Return the value of an option.
#------------------------------------------------------------------------------
sub get($)
{
	my ( $self, $key ) = @_;

	return $self->{$key};
}

#------------------------------------------------------------------------------
# Set the value of an option.
#------------------------------------------------------------------------------
sub set($)
{
	my ( $self, $key, $val ) = @_;

	my $old = $self->{$key};

	$self->{$key} = $val;

	return $old;
}

#------------------------------------------------------------------------------
# Read options from command line and start checking of the options.
# Exit with 1 if GetOptions found an internal error.
#------------------------------------------------------------------------------
sub _processCmdLine($)
{
	my ( $self ) = @_;
	my @opt = _mkOps( $self->{'opsDef'} );

	my $rc = GetOptions( $self, (@opt) );
	$self->usage(), exit 1  if( ! $rc );

    $rc = $self->_checkOps();
	return $rc;
}

#------------------------------------------------------------------------------
# Print usage message if missing any mandatory option and exit.
# Call perldoc of main programm if option -help is found.
# Exit with 2 if a mandatory option is missing.
#------------------------------------------------------------------------------
sub _checkOps($)
{
    my ( $self ) = @_;

	my $rc=0;
    my $errMsg;

	if( defined $self->{'help'} )
	{
		my $hasPerldoc = system("type perldoc >/dev/null 2>&1") / 256;
		my $hasNroff   = system("type nroff   >/dev/null 2>&1") / 256;
		if( $hasPerldoc == 0 && $hasNroff == 0 )
		{
			my $fh = new IO::File "perldoc $0 |";
			while( <$fh> ) { print STDERR $_; }
			$rc = 1;
		}else{
			$errMsg .= "Can't display online manual. Missing nroff and/or perldoc.\n";
		}
	}

    foreach ( keys %{$self->{'opsDef'}} )
    {
        $errMsg .= "Missing mandatory option '$_'.\n"
            if( ! $self->setDefaults( $_ ));
    }

    if( defined $errMsg )
    {
        print STDERR $errMsg;
        $self->usage();
        $rc = 2;
    }
	return $rc;
}

#------------------------------------------------------------------------------
# Set option to default value if option is missing and default value defined.
# Return 0 if option is mandatory, not set on comand line and no default value
# available. Otherwise return 1;
#------------------------------------------------------------------------------
sub setDefaults($$)
{
	my ($self, $opt) = @_;

	# We are happy, found the option on command line
	return 1	if( defined $self->{$opt} );

	# Nothing to do, option not found on command line but not mandatory
	return 1	if(! $self->{'opsDef'}{$opt}{'mand'} );

	# WOW!! We found an error!
	# Option not on comand line, mandatory and no default defined
	return 0	if(!defined $self->{'opsDef'}{$opt}{'default'} &&
							$self->{'opsDef'}{$opt}{'mand'}  );

	# Option not on comand line, mandatory and default defined
	# -> so we can use the default value
	$self->{$opt} = $self->{'opsDef'}{$opt}{'default'};
	return 1;


}

#------------------------------------------------------------------------------
# Print an usage message to STDERR.
#------------------------------------------------------------------------------
sub usage($$)
{
	my ( $self, $addMsg ) = @_;

	my $call = $self->{'caller'}->[1];
	   $call =~ s/^.*\///;

	my $cols = _getCols(); my $col2 = $cols/2-6;
	printf STDERR "\nUsage: %s  %s\n%s %s %s\n",
					$call,
					$self->{'addUsage'},
					'-' x $col2, 'Options', '-' x $col2;

	my ($form, $max) = _calcForm( $self->{'opsDef'} );

	foreach my $key ( sort keys %{$self->{'opsDef'}} )
	{
		my $val = $self->{'opsDef'}{$key};
		printf STDERR "$form\n", _getOpDesc( $val, $max, $cols );
	}
	printf STDERR "%s\n%s\n", '-' x ($cols-3),
					defined $addMsg ? "$addMsg\n" : "\n";
}

#-----------------------------------------------------------------------------
# Compute the number of columns of then contoling terminal.
#-----------------------------------------------------------------------------
sub _getCols
{
	my $line = `stty -a 2>/dev/null`;
	   return 80	if( !defined $line );
	   $line =~ /(.*columns[^0-9]+)([0-9]+)/;
	   return defined $2 ? $2 : 80;
}

#------------------------------------------------------------------------------
# Calculate format template for usage message.
#------------------------------------------------------------------------------
sub _calcForm($)
{
	my ( $ops ) = @_;

	_prepUsage( $ops );
	my ($form, $max) = ( '', 0 );
	foreach my $op ( values %{$ops} )
	{
		my $ln = length $op->{'usage'};
		my $ad = _optionaly($op) ? 2 : 0;

		$max = $ln+$ad > $max ? $ln+$ad : $max;
	}

	$form = "%${max}s - %s";
	return ($form, $max+3);
}

#------------------------------------------------------------------------------
# Prepare usage message using [] for optional options and <> for input values.
#------------------------------------------------------------------------------
sub _prepUsage($)
{
	my ( $ops ) = @_;

	foreach my $op ( keys %{$ops} )
	{
		my $o = $ops->{$op}{'mod'};
		   $o = ''	if( !defined $o );
		   $o =~ s/=s.*/ /;
		   $o =~ s/:s.*/ []/;
		   $o =~ s/=i.*/ /;
		   $o =~ s/:i.*/ []/;
		   $o =~ s/=f.*/ /;
		   $o =~ s/:f.*/ []/;

		$ops->{$op}{'usage'} = "-$op$o";
	}
}
#------------------------------------------------------------------------------
# Build the description of an option.
#------------------------------------------------------------------------------
sub _getOpDesc($)
{
	my ( $op, $max, $cols ) = @_;

	my $rc;
	if( _optionaly($op) )
	{
		$rc = '[' . $op->{'usage'} . ']';
	}else{
		$rc = $op->{'usage'};
	}
	my $desc = _insertNL( $op,  $max, $cols );
	return ( $rc, $desc );
}
#-----------------------------------------------------------------------------
#  Return false if the option is madatory and has no default value.
#  Return true otherwise.
#-----------------------------------------------------------------------------
sub _optionaly($)
{
    my ($op) = @_;

    if( defined $op->{'mand'})
    {
        return 1 if( ! $op->{'mand'} );
        return 0 if( ! defined $op->{'default'} );
    }
    return 1
}


#-----------------------------------------------------------------------------
# Fold line into two lines if line length exceeds number of columns .
#-----------------------------------------------------------------------------
sub _insertNL
{
	my ($op, $max, $cols) = @_;

	my $l='';
	my $line='';
	$op->{'desc'} = '--no description--'	if( !defined $op->{'desc'} );

	foreach my $x ( split /\s+/, $op->{'desc'} )
	{
		if( length($l) + length($x) + $max >= $cols )
		{
			$line .= sprintf "%s\n%s", $l, ' ' x $max;
			$l = '';
		}
		$l .= "$x ";
	}
	$line .= $l;
	$line .= sprintf "\n%s(default=%s)", ' ' x $max,$op->{'default'}
											if( defined $op->{'default'} );
	return $line;
}

#------------------------------------------------------------------------------
# Prepare the option hash for Getopt::Long::GetOptions().
#------------------------------------------------------------------------------
sub _mkOps()
{
	my ( $ops ) = @_;
	my @OPS;

	my $mod;
	foreach my $opt ( keys %{$ops} )
	{
		$mod = defined $ops->{$opt}{'mod'} ? $ops->{$opt}{'mod'} : '';
		push @OPS, $opt . $mod;
	}
	return @OPS;
}
##############################################################################
1;
__END__