package CmdArguments;

use strict;

use vars qw($VERSION);

$VERSION = '1.00';

=head1 NAME

CmdArguments - Module to process arguments passed on command line

=head1 SYNOPSIS

    # program name args.pl
    use CmdArguments;

    my $var1 = 10;          # initialize variable
    my $var2 = 0;           # with default values.
    my @var3 = ( 1, 2, 3);  # well, if you like to.
    my @var4;               # but, not necessary

    my $parse_ref = [
                     [ "arg1", \$var1 ], # argTypeScalar is assumed
                     [ "arg2", \$var2,
                       {TYPE => argTypeSwitch}], # explicit argTypeSwitch
                     [ "arg3", \@var3 ], # argTypeArray assumed
                     [ "arg4", \@var4,
                       {UNIQUE => 1}], # argTypeArray assumed
                    ];

    CmdArguments::parse(@ARGV, $parse_ref);

    print "var1 = $var1\n";
    print "var2 = $var2\n";
    print "var3 = @var3\n";
    print "var4 = @var4\n";

    exit 0;

test command ...

    args.pl -arg1 23 -arg2 -arg3 2 4 3 2 5 -arg4 2 4 3 2 4

should generate following output...

    var1 = 23
    var2 = 1
    var3 = 2 4 3 2 5
    var4 = 2 4 3

=head1 DESCRIPTION

This module provides some handy functions to process
command line options.

When this module is included it introduces following
constants in the calling program namespace...

    argTypeScalar = 0
    argTypeArray  = 1
    argTypeSwitch = 2

=cut

sub BEGIN {
    use constant argTypeScalar => 0;
    use constant argTypeArray  => 1;
    use constant argTypeSwitch => 2;
    use constant argTypeHash   => 3;

    my $pkg = caller;
    no strict 'refs';
    *{"${pkg}::argTypeScalar"} = sub () { argTypeScalar };
    *{"${pkg}::argTypeArray"}  = sub () { argTypeArray };
    *{"${pkg}::argTypeSwitch"} = sub () { argTypeSwitch };
    *{"${pkg}::argTypeHash"}   = sub () { argTypeHash };
}

=over 1

=item B<CmdArguments::parse>

Simplest way to use this program is to call B<parse> (static function).

Calling syntax is...

I<parse(L<@arguments|@arguments>, L<$array_ref|$array_ref>,
I<L<$text_or_func1|$text_or_func1>>, I<L<$text_or_func2|$text_or_func2>>)>

=over 2

=item I<@arguments>

array of command line arguments. So, @ARGV could be passed instead.

=item I<$array_ref>

reference to an array containing information about how to
parse data in @arguments.

basic structure of $array_ref is...

$array_ref = [ I<$array_ref_for_individual_tag>, ...];

$array_ref_for_individual_tag = [I<L<$option_tag|$option_tag>>
, I<L<$ref_of_variable|$ref_of_variable>>,
I<L<$hash_ref|$hash_ref>>]; # $hash_ref is optional

=over 3

=item I<$hash_ref>

reference to a hash containing supplementary information about $option_tag

  $hash_ref = {
    TYPE   => argType..., # argTypeSwitch
                          # argTypeArray or argTypeScalar

    UNIQUE => 1,          # 1 or 0

    USAGE  => "help information", # try giving -h or -help
                                  # on command line

    FUNC   => sub { eval $_[0] }
  };

=over 4

=item TYPE

this specifies what kind of variable reference is passed in
$ref_of_variable. If TYPE is argTypeScalar or argTypeSwitch
it assumes reference to a scalar. If TYPE is argTypeArray it
assumes reference to an array.

if TYPE tag is not provided then ...

1. I<argTypeScalar> is assumed if $ref_of_variable is a scalar reference

2. I<argTypeArray> is assumed if $ref_of_variable is an array reference

=over 5

=item What is argType...?

=over 6

=item argTypeSwitch

on command line you can not provide value for an option.

=item argTypeScalar

on command line you must provide one and only one value

=item argTypeArray

on command line you can provide zero or more values

=back 6

=back 5

=item UNIQUE

this tag is applicable for option type I<argTypeArray> only.
it can be 0 or 1. 1 means make unique array. So, if an
option is defined as UNIQUE then on command line if you
give say 2 3 4 5 3 4 6 7 then array will hold 2 3 4 5 6 7.
If it was not unique then it will hold 2 3 4 5 3 4 6 7.

=item FUNC

Holds a reference to a function. Function should take
a scalar argument and return a scalar if option is
argTypeScalar and return an array if option is
argTypeArray. This is not used for option type argTypeSwitch.

Example: if option type is an argTypeArray. and function is
defined like

FUNC => sub { eval $_[0] }

and if on the command line something like 1..3 or 1,2,3
is passed then it will generate an array having values 1 2 3.

=back 4

=item I<$ref_of_variable>

Can pass reference of a scalar or an array variable
depending on what require from command line.

=item I<$option_tag>

It is the name of the option tag. if option tag is I<opt> then
on command line you have to specify option like I<-opt>.

=back 3

=item $text_or_func1

=item $text_or_func2

pass text or reference to a function. If function is passed
it should return text or should itself print message on
STDERR. Try experimenting by passing -h or -help in the argument.
$text_or_func1 is printed after the help text is printed and
$text_or_func1 is used before printing helptext.

=back 2

=back 1

=cut

sub parse (\@@) {
    my ($arg_ref, $process, $postusage, $preusage) = @_;

    use constant argTagField  => 0;
    use constant argVarField  => 1;
    use constant argHashField => 2;

    my %functions = (argTypeScalar+0 => "argScalar",
		     argTypeArray+0  => "argArray",
		     argTypeHash+0  => "argHash",
		     argTypeSwitch+0 => "argSwitch");

    my $args = CmdArguments->beginArg(@$arg_ref);
    foreach my $argsyntax (@$process) {
	my $typehash = (defined $argsyntax->[argHashField]
			? $argsyntax->[argHashField] : {});

	my $tag     = $argsyntax->[argTagField];
	my $var     = $argsyntax->[argVarField];
	my $type    = _value($typehash->{TYPE});
	my $sub     = _value($typehash->{FUNC});
	my $unique  = _value($typehash->{UNIQUE});
	my $usage   = _value($typehash->{USAGE});
	my $dispOpt = _value($typehash->{DISPOPTION});
	my $params  = _value($typehash->{PARAMS});

	unless (defined $type) {
	    $type = argTypeScalar if ref($var) eq 'SCALAR';
	    $type = argTypeArray  if ref($var) eq 'ARRAY';
	    $type = argTypeHash   if ref($var) eq 'HASH';
	    unless (defined $type) {
		die "ERROR: option ($tag) - variable should be a reference\n";
	    }
	}

	my @arguments = ($tag => $var, usage => $usage,
			 dispOption => $dispOpt,
			 func => $sub, unique => $unique, params => $params);

	if (exists $functions{$type}) {
	    my $function = $functions{$type};
	    $args->$function(@arguments);
	} else {
	    die "Please check type ($type)\n";
	}
    }

    my @return = ();
    if (wantarray) {
	@return = $args->endArg;
    } else {
	$args->endArg;
    }
    $args->usage($preusage, $postusage);
    return @return;
}

# Start Argument processing
# usage: my $arg = CmdArguments->beginArg(@ARGV);
sub beginArg {
    my ($class, @argv) = @_;

    my $self = {};
    bless $self, $class;

    # trap the arguments
    $self->{ARGS} = @argv ? [@argv] : \@ARGV;
    # usage string in case of help or error
    $self->{USAGE} = "";
    # required for generating variable names
    $self->{_TMPNUM} = 0;

    # trap the original accumulator;
    $self->{_ACCUMULATOR} = $^A;

    # temporay variable
    # to store help status
    my $tmpHelpVar = 0;
    $self->{_HELPSAT} = \$tmpHelpVar;

    # hash where reference user supplied
    # variables are stored
    $self->{_VARIABLES} = {};
    # hash where user defined functions are stored
    $self->{_FUNCTIONS} = {};

    # used in case wrong option is given
    $self->{_UNKNOWN_OPTIONS} = [];

    # begin generating main loop
    $self->{LOOP_STRING} = <<'BEGINARG';
    while (@{$self->{ARGS}}) {
        $_ = shift @{$self->{ARGS}};
BEGINARG

    return $self;
}

# process scalar argument
# usage: $arg->argScalar(option => \$scalar_variable,
#                        usage => "description",
#                        func => sub { return $_[0] });
sub argScalar {
    my $self   = shift;

    # get user supplied argument and variable (where
    # value is to be stored) and other options
    my ($arg, $variable, %options) = _makeOptions(@_);

    # store user supplied function and variable
    my ($varName, $funName) = $self->_getVarAndFuncName($variable,
							$options{func}
							|| undef);
    # generate code to handle scalar option
    $self->{LOOP_STRING} .= <<OPRIONARG;
        \/^-($arg)\$\/ && ( do { my \$value = shift(\@{\$self->{ARGS}});
                               \${\$self->{_VARIABLES}{$varName}}
                                  = \$self->{_FUNCTIONS}{$funName}->(\$value);
                          }, next
                        );
OPRIONARG

    # make usage
    $self->_makeUsage($arg, %options);
}

# process switch argument
# passed variable will be turned on or off
# usage: $arg->argScalar(option => \$switch_variable,
#                        usage => "description");
sub argSwitch {
    my $self = shift;

    # get user supplied argument and variable (where
    # value is to be stored) and other options
    my ($arg, $variable, %options) = _makeOptions(@_);

    # store user supplied function and variable
    my ($varName, $funName) = $self->_getVarAndFuncName($variable,
							$options{func}
							|| undef);

    # generate code to handle switch option
    $self->{LOOP_STRING} .= <<OPRIONARG;
        \/^-($arg)\$\/ && ( \${\$self->{_VARIABLES}{$varName}}
                          = \!\${\$self->{_VARIABLES}{$varName}}+0 , next);
OPRIONARG

    # make usage
    $self->_makeUsage($arg, %options);
}

# process array argument
# usage: $arg->argArray(option => \@array_variable,
#                       usage => "description",
#                       unique => 1,
#                       func => sub { return @_ });
sub argArray {
    my $self = shift;

    # get user supplied argument and variable (where
    # value is to be stored) and other options
    my ($arg, $variable, %options) = _makeOptions(@_);

    # uniqe list required (default: yes)
    my $unique = exists $options{unique} ? ($options{unique} || 0) : 1;

    # store user supplied function and variable
    my ($varName, $funName) = $self->_getVarAndFuncName($variable,
							$options{func}
							|| undef);
    my $param = $options{params};
    $param = 'undef' unless defined $param;
    $self->{_PARAMS}{$varName} = $param;

    # generate code to handle array option
    $self->{LOOP_STRING} .= <<OPRIONARG;
        \/^-($arg)\$\/ &&
             (do { my \%tmp = map { (\$_, 1)
                              } \@{\$self->{_VARIABLES}{$varName}};
                   while (\@{\$self->{ARGS}} and \$self->{ARGS}[0] !~ /^-/) {
                          my \$value = shift \@{\$self->{ARGS}};
                          my \@values
                              = \$self->{_FUNCTIONS}
                                 {$funName}->(\$value,
                                              \$self->{_PARAMS}{$varName});
                          if ($unique) {
                              \@values = grep { my \$stat = exists \$tmp{\$_};
                                                \$stat ||= 0;
                                                \$tmp{\$_} = 1 unless \$stat;
                                                !\$stat
                                         } \@values;
                          }
                          push(\@{\$self->{_VARIABLES}{$varName}}, \@values)
                            if \@values;
                   }}, next
             );
OPRIONARG

    # make usage
    $self->_makeUsage($arg, %options);
}

# process hash argument
# usage: $arg->argHash(option => \%hash_variable,
#                      usage => "description",
#                      func => sub { ... });
sub argHash {
    my $self = shift;

    # get user supplied argument and variable (where
    # value is to be stored) and other options
    my ($arg, $variable, %options) = _makeOptions(@_);

    # uniqe list required (default: yes)
    my $unique = exists $options{unique} ? ($options{unique} || 0) : 1;

    # store user supplied function and variable
    my ($varName, $funName) = $self->_getVarAndFuncName($variable,
							$options{func}
							|| undef);
    my $param = $options{params};
    $param = 'undef' unless defined $param;
    $self->{_PARAMS}{$varName} = $param;

    # generate code to handle hash option
    $self->{LOOP_STRING} .= <<OPRIONARG;
        \/^-($arg)\$\/ &&
             (do { while (\@{\$self->{ARGS}} and \$self->{ARGS}[0] !~ /^-/) {
                          my \$value = shift \@{\$self->{ARGS}};
                          my \$values
                              = \$self->{_FUNCTIONS}
                                 {$funName}->(\$value,
                                              \$self->{_PARAMS}{$varName});
			  my \$ref = ref(\$values);
			  unless (\$ref) {
			      \$self->{_VARIABLES}{$varName}{\$values} = 1;
			  } elsif ( \$ref eq 'HASH') {
			      foreach my \$key (keys \%\$values) {
				  \$self->{_VARIABLES}{$varName}{\$key}
				    = \$values->{\$key};
			      }
			  }
                   }}, next
             );
OPRIONARG

    # make usage
    $self->_makeUsage($arg, %options);
}

# finish the main loop
# usage: $arg->endArg;
sub endArg {
    my $self = shift;

    # generate code to provide help
    $self->argSwitch("h|help" => $self->{_HELPSAT},
		     usage => <<HELP, dispOption => "      ");
show this help.
HELP

    my @return = ();


    my $wantarray = wantarray || 0;

    # end the main loop
    # and push unhandled options
    $self->{LOOP_STRING} .= <<ENDLOOP;
        if (\$wantarray && \$_ !~ /^-/) {
            push \@return, \$_;
        } else {
            push \@{\$self->{_UNKNOWN_OPTIONS}}, \$_;
        }
    }
ENDLOOP

    # run the main loop
    eval "$self->{LOOP_STRING}";
    if ($@) {
	print STDERR "OPS: $@ \n";
	my @array = split "\n", $self->{LOOP_STRING};
	my $i = 1;
	print STDERR map { sprintf("%3d: %s\n", $i++, $_) } @array;
	exit 1;
    }

    # reset format accumulator
    $^A = $self->{_ACCUMULATOR};

    return @return;
}

# display usage if require
# usage: $arg->usage($pre, $post);
# $pre: string or function reference
# $post: string or function reference
# NOTE: if not used help will not be generated
sub usage {
    my ($self, $pre, $pst) = @_;

    # generate string for unknown options
    my $unknown_options = (@{$self->{_UNKNOWN_OPTIONS}}
			   ? "(@{$self->{_UNKNOWN_OPTIONS}})" : "");
    $unknown_options = "$0: Unknown options $unknown_options\n"
      if $unknown_options;

    # handle error or simply help...
    if (${$self->{_HELPSAT}} || $unknown_options) {
	my $prefunc = ref($pre) eq 'CODE' ? $pre : sub { $pre || "" };
	my $pstfunc = ref($pst) eq 'CODE' ? $pst : sub { $pst || "" };

	print STDERR $unknown_options;
	print STDERR &$prefunc || "";
	print STDERR $self->{USAGE};
	print STDERR &$pstfunc || "";
        $unknown_options ? exit 100 : exit 0;
    }
}

# core code for formatting help
sub _makeUsage {
    my ($self, $option, %desc) = @_;

    my $description = $desc{usage} || "not ready yet!.";
    my $opts = $desc{dispOption} || "opts";

    my $olen = length($option.$opts) + 2;
    my $format = '@>>>>>>>>>>>>>>>>>>: ';
    if ($olen > 19) {
	$format = '@' . '>' x $olen . "\n" . " " x 19 . ": ";
    }

    my $len = 60;
    my $dformat = '^' . '<' x $len . '~';
    my $dlen = length($description);
    my $line = int($dlen / $len);

    $line += 2;
    $format .= join "\n" . " " x 21, map {$dformat} 1..$line;
    my $str = '$^A = ""; formline($format, "-" . $option . '
      . '" $opts ", ' . ('$description, ' x $line) . '  ); $^A;';
    $str = eval $str;
    chomp($str);
    $str .= "\n";
    $self->{USAGE} .= $str;
}

sub _getVariableName {
    my $self = shift;

    return "VAR_" . (++$self->{_TMPNUM});
}

sub _makeOptions {
    my $option   = shift;
    my $variable = shift;
    return ($option, $variable, @_);
}

sub _getVarAndFuncName {
    my ($self, $variable, $function) = @_;

    my $varName = $self->_getVariableName;
    $self->{_VARIABLES}{$varName} = $variable;
    my $funName = $self->_getVariableName;
    $self->{_FUNCTIONS}{$funName} = sub { $_[0] };
    if ($function) {
	if (ref($function) eq 'CODE') {
	    $self->{_FUNCTIONS}{$funName} = $function;
	} else {
	    die "ERROR: func should be a reference to a function\n";
	}
    }

    return ($varName, $funName);
}

sub _value {
    my $val = shift;
    return defined $val ? $val : undef;
}

=head1 AUTHOR

Navneet Kumar, E<lt>F<navneet_k@hotmail.com>E<gt>

=cut

1;