package Getopt::Modular;

use warnings;
use strict;

use Getopt::Long;
use Contextual::Return;
use Smart::Comments '###';
use List::MoreUtils qw(any uniq);
use Scalar::Util qw(reftype looks_like_number);
use Exception::Class
    'Getopt::Modular::Exception' => {
        description => 'Exception in commandline parsing/handling',
        fields => [ qw(option value) ],
    };
use Carp;

=head1 NAME

Getopt::Modular - Modular access to Getopt::Long

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.02';


=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use Getopt::Modular;

    Getopt::Modular->accept_param(
                                  foo => {
                                      default => 3,
                                      spec    => '=s',
                                      validate => sub { 3 <= $_ && $_ <= determine_max_foo(); }
                                  }
                                 );
    Getopt::Modular->parse_args();
    my $foo = Getopt::Modular->getOpt('foo');

=head1 PURPOSE

There are a few goals in this module.  The first is to find a way to
allow a bunch of custom modules to specify what options they want to take.
This allows you to reuse modules in multiple environments (applications)
without having to repeat a bunch of code for handling silly things like
the parameters themselves, their defaults, validation, etc.  You also don't
need to always be aware of what parameters a module may take if it merely
grabs them from the global environment.

I find I'm reusing modules that should be user-configurable (via the 
commandline) in multiple applications a lot.  By separating this out, I
can just say "use Module;" and suddenly my new application takes all the
parameters that Module requires (though I can modify this on a case-by-
case basis in my application).  This allows me to keep the information
about a variable in close proximity to its use (i.e., the same file).

There is a lot of information here that otherwise would need to be handled
with special code.  This can greatly simplify things:

=over 4

=item * consistancy

Because the same parameters are used in multiple applications with the
same meaning, spelling, valid values, etc., it makes all your applications
consistant and easy to learn.

=item * help

The online help is a big challenge in any application.  This module will
handle the help for your parameters by using what is provided to it from
each module.  Again, the help for a parameter will be the same in all your
applications, maintaining consistancy.

Further, the help will be right beside the parameter.  No more looking
through hundreds or thousands of lines of pod and code trying to match
up parameters and help, wondering if you missed something.  Now you only
have to address about 5-10 lines of code at a time wondering if you missed
something.

=item * defaults

Defaults right beside the parameter.  Again, you only need to address 5-10
lines of code to look for parameter and its default.  They aren't
separated any longer.  Now, it's true that you don't necessarily need
to have defaults far removed with L<Getopt::Long>, but that really does
depend on what you're doing.

Further, the defaults are I<dynamic>.  That means you can put in a code
reference to determine the default.  Your default may depend on other
parameters, or it may depend on external environment (Is the destination
directory writable?  What is the current hostname?  What time is it?).
You can grab your default from a webserver from another continent (not
recommended).  It doesn't matter.  But you can have that code right there
with the parameter, making it easy to compartmentalise.

=item * validation

Like everything above, the validation of a parameter is right beside the
parameter, making it easy to address the entirety of a parameter all in
a single screen (usually much less) of code.

Validation is also automatically run against both the default (same idea
as having tests for your perl modules: sanity test that your default is
valid) when no parameter is given, and any programmatic changes to a
value.  Without this, I was always forgetting to validate my option changes.
This automates that.

=back

All this, the power of L<Getopt::Long>, and huge thanks from whomever
inherits your code for keeping everything about --foo in a single place.

The downside is that you need to ensure all modules that may require
commandline parameters are loaded before you actually parse the commandline.
For me, this has meant that my test harness needs to either ask for
the module to test via environment variable or needs to pre-parse the
commandline (kind of defeating the purpose of the module).  I've opted for
checking for the module via C<$ENV{MODULE}>, loading it, and then parsing
the commandline.

Also, another downside is that parameters are not positional.  That is,
C<--foo 3 --bar 5> is the same as C<--bar 5 --foo 3>.  The vast majority
of software seems to agree that these are the same.


=head1 FUNCTIONS

=head2 new

Construct a new options object.  If you just need a single, global options object,
you don't need to call this.  By default, all methods can be called as package
functions, automatically instantiating a default global object.

Takes as parameters all modes accepted by set_mode, as well as a 'global'
mode to specify that this newly-created options object should become the
global object, even if a global object already exists.

Note that if no global object exists, the first call to new will create it.

=cut

my $global;
sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;

    # do we have a global one yet?
    $global ||= $self;

    if (any {'global' eq lc} @_)
    {
        $global = $self;
        @_ = grep { 'global' ne lc } @_;
    }

    $self->init(@_);

    $self;
}

sub _self_or_global
{
    my $self = shift;
    ref $self   ? $self :
        $global ? $global :
                  $self->new();
}

sub _opt : lvalue
{
    my $self = _self_or_global(shift);
    my $opt  = shift;

    LVALUE {
        unless (ref $_ and ref $_ eq 'HASH')
        {
            #croak("Can only assign hashrefs here.");
            Getopt::Modular::Exception->throw(
                                              message => 'INTERNAL ERROR: Can only assign hashrefs here.',
                                              opt => $opt,
                                             );
        }

        $self->{accept_opts}{$opt} = $_
    }
    RVALUE { 
        BOOL { exists $self->{accept_opts}{$opt} }
        HASHREF {
            unless (exists $self->{accept_opts}{$opt})
            {
                confess "Unknown option: $opt";
            }
            $self->{accept_opts}{$opt}
        } 
        VALUE {
            confess "What the... use this as a hashref, bub!"
        }
    }
}

=head2 init

Overridable method for initialisation.  Called during object creation to allow
default parameters to be set up prior to any other module adding parameters.

Default action is to call $self->set_mode(@_), though normally you'd set
any mode(s) in your own init anyway.

=cut

sub init
{
    my $self = shift;
    $self->set_mode(@_) if @_;
    1;
}

=head2 setMode

Sets option modes.

Currently, the only supported mode is:

=over 4

=item strict

Don't allow anyone to request an option that doesn't exist.  This will catch
typos.  However, if you have options that may not exist in this particular
program that may get called by one of your other modules, this may cause
problems in that your code may die unexpectedly.

Since this is a key feature to this option approach, the default is not
strict.  If you always knew all your options up front, you could just
define them and be done with it.  But then you would likely be able to just
go with L<Getopt::Long> anyway.

=back

=cut

my %_known_modes = map { $_ => 1 } qw(
    strict
);

sub setMode
{
    my $self = _self_or_global(shift);

    foreach my $mode (@_)
    {
        if ($_known_modes{$mode})
        {
            $self->{mode}{$mode}++;
        }
        else
        {
            croak "Unknown mode: $@";
        }
    }
}

=head2 acceptParam

Set up to accept parameters.  All parameters will be passed to L<Getopt::Long>
for actual parsing.

e.g.,

    Getopt::Modular->accept_param('fullname' => {
        aliases => [ 'f', 'fn' ],
        spec => '=s@', # see Getopt::Long for argument specification
        help => 'use fullname to do blah...',
        default => 'baz',
        validate => sub {
            # verify that the value passed in is ok
        },
    });

You can pass in more than one parameter at a time.

Note that B<order matters>.  That is, the order that parameters are told to
Getopt::Modular is the same order that parameters will be validated when
accepted from the commandline, B<regardless of the order the user passes them
in>.  If this is no good to you, then you may need to find another method
of handling arguments.

The parameter name is given separately.  Note that whatever this is will be
the name used when you retrieve the option.  I suggest you use the longest
name here to keep the rest of your code readable, but you can use the shortest
name or whatever you want.

Acceptable options are:

=over 4

=item aliases

In Getopt::Long, these would be done like this:

    'fullname|f|fn'

Here, we separate them out to make them easier to read.  They are combined
back into a single string for Getopt::Long.  Optionally, you can simply provide
C<'fullname|f|fn'> as the parameter name, and it will be split apart.  In this
case, the name used to retrieve the value will be the first string given.

=item spec

This is the part that tells Getopt::Long what types to accept.  This can be a
quick check against what can be accepted (numeric, string, boolean) or may be
more informative (such as taking a list).  While this is mostly used to pass
in to Getopt::Long, it is also used for context in the help option, or in
returning options back to whoever needs them, such as knowing whether the given
values can be a list, or if it's simply a boolean.

=item help

This is either a string, or a code ref that returns a string to display to the
user for help.  The reason why a code ref is allowed is in case the help string
is dynamic based on the parameters that are given.  For example, you may want
to provide different help for the current flag based on the valid of some other
flag.

If this is a code ref, it is not passed any parameters, and $_ is not set reliably.

=item default

This is either a scalar, an array ref (if C<spec> includes C<@>), a hash ref (if
C<spec> includes C<%>), or a code ref that returns the appropriate type.  A code
ref can provide the opportunity to change the default for a given parameter based
on the values of other parameters.  Note that you can only rely on the values
of parameters that have already been validated, i.e., parameters that were
given to accept_param earlier than this one.  That's because ones given later
would not have had their values set from the command line yet.

This is checked/called only once, maximum, per process, as once the default is
retrieved, it is stored as if it were set by the user via the command line.  It
may be called either as part of the help display, or it may be called the first
time the code requests the value of this parameter.  If the current code path
does not check this value, the default will not be checked or called even if
the parameter is not passed in on the command line.

If this is a code ref, it is not passed any parameters, and $_ is not set reliably.

=item validate

This is a code ref that validates the parameter being passed in against not only
valid values, but the current state of the parameters.  This includes validation
of the default value.

You can use this callback to ensure that the current values are allowed given
all the parameters validates so far.  That is, you can call getOpt on any previous
parameter to check their values make sense given the current value.  If it doesn't,
simply die with the error message.  Do not call exit, because this is called in
an eval block for displaying help, and it's perfectly reasonable that a user
requests help when some values are invalid.

The value(s) being validated are passed in via $_, which may be a reference
if the type is an array or hash.

You may throw an exception in case of error, or you can simply return false
and a generic exception will be thrown on your behalf.  Obviously throwing
your own exception with a useful error message for the user is the better
choice.

If this key is not present, then anything Getopt::Long accepts (due to the specification)
will be accepted as valid.

=item mandatory

If this is set to a true value, then during parameter validation, this option
will always be set, either via the command line, or via checking/calling default
(which will then be validated).

=back

=cut

sub acceptParam
{
    my $self = _self_or_global(shift);
    while (@_)
    {
        my $param = shift;
        my $opts = shift;
        
        my $aliases = exists $opts->{aliases} ? ref $opts->{aliases} ? $opts->{aliases} : [ $opts->{aliases} ] : [];
        
        if ($param =~ /\|/)
        {
            ($param, my @aliases) = split /\|/, $param;
            unshift @$aliases, @aliases;
        }

        # if any of the aliases have pipes, split them up.  Needed to provide
        # the help screen.
        $opts->{aliases} = [
                            uniq
                            eval { 
                                $self->_opt($param) ?
                                @{$self->_opt($param)->{aliases}} : ()
                            },
                            map { split /\|/, $_ } @$aliases
                           ];

        # check if this flag already exists (other than as main name)
        for (@{$opts->{aliases}})
        {
            if (exists $self->{all_opts}{$_} and
                $self->{all_opts}{$_} ne $param)
            {
                croak "$_ already used by $self->{all_opts}{$_}";
            }
            # save this as the owner
            $self->{all_opts}{$_} = $param;
        }

        delete $self->{unacceptable}{$param};
        if ($self->_opt($param))
        {
            @{$self->_opt($param)}{keys %$opts} = values %$opts;
        }
        else
        {
            # set some defaults ...
            $opts->{spec} ||= '';

            $self->_opt($param) = $opts;
        }
    }
}

=head2 unacceptParam

Sometimes you may load a module that has a parameter, but in this
particular case, you don't want the user to be able to specify it.  Either
you want the default to always be used, or you want to set it to something
explicitly.  You can set the parameter to be "un"accepted, thereby eliminating
it from the list of options the user can pass in.

However, this will not remove it from the list that Getopt::Modular
will recognise inside the code.  That is, Getopt::Modular->getOpt() will
still accept that parameter, and setOpt will still allow you to set it
programmatically.

To re-accept an unaccepted parameter, simply call accept_param, passing
in the parameter name and an empty hash of options, and all the old values
will be used.

=cut

sub unacceptParam
{
    my $self = _self_or_global(shift);
    for my $param (@_)
    {
        $self->{unacceptable}{$param} = 1;
        my @x =
        delete @{$self->{all_opts}}{@{$self->{accept_opts}{$param}{aliases}}};
    }
}

=head2 parseArgs

Once all parameters have been accepted (and, possibly, unaccepted), you must
call parse_args to perform the actual parsing.

=cut

sub parseArgs
{
    my $self = _self_or_global(shift);

    # first, gather up for the call to Getopt::Long.
    my %opts;
    my $accept    = $self->{accept_opts};
    my $unaccept  = $self->{unacceptable};
    my @params = map {
        my $param = join '|', $_, @{$accept->{$_}{aliases}};
        $param . ($accept->{$_}{spec} || '');
    } grep {
        # skip unaccepted parameters
        $unaccept and not $unaccept->{$_}
    } keys %$accept;
    #### @params

    # parse them
    my $warnings;
    my $success = do {
        local $SIG{__WARN__} = sub { $warnings .= "@_";};
        GetOptions(\%opts, @params);
    };
    if (not $success)
    {
        Getopt::Modular::Exception->throw(
             message => "Bad command-line: $warnings",
            );
    }
    #### %opts
    
    # now validate everything that was passed in, and save it.
    for my $opt (keys %$accept)
    {
        #### $opt
        if (exists $opts{$opt})
        {
            #### $opts{$opt}
            $self->setOpt($opt, $opts{$opt});
        }
        # if it's mandatory, get it - that will call the default and
        # set it.
        elsif ($accept->{$opt}{mandatory})
        {
            #### setting via default...
            $self->getOpt($opt);
        }
    }
}

=head2 getOpt

Retrieve the desired option.  This will "set" any option that has not
been retrieved before, and was not on the command line, by calling the default.

If you need to know the difference between an implicit default and an
explicit default, you need to do that in your default code.  That said,
you should think twice about that: is it intuitive to the user that
there should be a difference between "--foo 3" and not specifying --foo
at all when the default is 3?

=cut

sub getOpt
{
    my $self = _self_or_global(shift);
    my $opt  = shift || Getopt::Modular::Exception->throw(
                                                          message => 'No option given?'
                                                         );

    if (not exists $self->{accept_opts}{$opt})
    {
        if ($self->{mode}{strict})
        {
            Getopt::Modular::Exception->throw(
                                              message => "No such option: $opt",
                                              opt => $opt,
                                              val => undef,
                                             );
        }
    }

    # If we don't have it yet, check if there's a default.
    if (not exists $self->{options}{$opt} and
        exists $self->{accept_opts}{$opt} and
        exists $self->{accept_opts}{$opt}{default})
    {
        my @default = $self->{accept_opts}{$opt}{default};
        if (ref $default[0] and ref $default[0] eq 'CODE')
        {
            @default = $default[0]->();
        }
        $self->setOpt($opt, @default);
    }

    # should have one now ... check and return
    if (exists $self->{options}{$opt})
    {
        return
            LIST {
                ref $self->{options}{$opt} ? @{$self->{options}{$opt}} : $self->{options}{$opt};
            } VALUE {
                $self->{options}{$opt}
            } HASHREF {
                croak qq[can't use $opt as hash] unless ref $self->{options}{$opt} eq 'HASH';
                $self->{options}{$opt}
            };
    }

    return;
}

sub _getType
{
    my $self = _self_or_global(shift);
    my $opt  = shift;

    unless (exists $self->_opt($opt)->{_GMTYPE})
    {
        my $type = $self->_opt($opt)->{spec};
        $self->_opt($opt)->{_GMTYPE} = ''; #scalar
        if ($type =~ /\@/)
        {
            $self->_opt($opt)->{_GMTYPE} = 'ARRAY';
        }
        elsif ($type =~ /\%/)
        {
            $self->_opt($opt)->{_GMTYPE} = 'HASH';
        }
    }
    $self->_opt($opt)->{_GMTYPE}
}

sub _bool_val
{
    # technically, perl allows anything to be boolean.
    #my ($opt,$val) = @_;
}

sub _int_val
{
    my ($opt,$val) = @_;
    if ($val =~ /\D/)
    {
        Getopt::Modular::Exception->throw(
                                          message => "Trying to set '$opt' (an integer-only parameter) to '$val'",
                                          option  => $opt,
                                          value   => $val
                                         );
    }
}

sub _real_val
{
    my ($opt,$val) = @_;

    unless (looks_like_number $val)
    {
        Getopt::Modular::Exception->throw(
                                          message => "Trying to set '$opt' (a real-number parameter) to '$val'",
                                          option  => $opt,
                                          value   => $val
                                         );
    }
}

my %_valtypes = (
                 '!' => { val => \&_bool_val },
                 '+' => { val => \&_int_val },
                 's' => { val => sub {} },
                 'i' => { val => \&_int_val },
                 'o' => { val => \&_int_val },
                 'f' => { val => \&_real_val },
                );

sub _setOpt
{
    my $self = _self_or_global(shift);
    my $opt  = shift;
    my $val  = shift;

    # check known types before passing on to user-specified validation.

    my $type = $self->_opt($opt)->{spec};
    if ($type eq '' || $type eq '!') # boolean
    {
        _bool_val($opt,$val);
        # extra information should not be stored in a boolean.
        $val = !!$val;
    }
    else
    {
        for (split //, $type)
        {
            if (my $info = $_valtypes{$_})
            {
                if ($type =~ /\@/)
                {
                    $info->{val}->($opt,$_) for @$val;
                }
                elsif ($type =~ /\%/)
                {
                    $info->{val}->($opt,$_) for values %$val;
                }
                else
                {
                    $info->{val}->($opt,$val);
                }
            }
        }
    }

    if ($self->_opt($opt)->{validate})
    {
        local $_ = $val;
        unless ($self->_opt($opt)->{validate}->())
        {
            if (ref $val)
            {
                $val = join ',', @$val if ref $val eq 'ARRAY';
                $val = join ',', map { "$_=$val->{$_}" } sort keys %$val if ref $val eq 'HASH';
            }
            Getopt::Modular::Exception->throw(
                                              message => "'$val' is an invalid value for $opt",
                                              option  => $opt,
                                              value   => $val,
                                             );
        }
    }

    $self->{options}{$opt} = $val;
}

=head2 setOpt

Programmatic changing of options.  This should not be done until after
the options have been parsed: defaults are set through the default flag,
not by setting the option first.

Note that this will pass the value through the validation code, if any, so
be sure you set the values to something that make sense.  Will throw an
exception if the value cannot be set, e.g., it is invalid.

=cut

sub setOpt
{
    my $self = _self_or_global(shift);
    my $opt  = shift;
    my $val  = do {
        if (ref $_[0])
        {
            Getopt::Modular::Exception->throw(
                                              message => "Wrong type of data for $opt.  Expected: " .
                                              ($self->_getType($opt) || 'SCALAR') .
                                              " got: " . (reftype $_[0] || 'SCALAR'),
                                              opt => $opt,
                                              value => $_[0],
                                             )
                unless $self->_getType($opt) eq reftype $_[0];

            # if it's a reference, pass it in unchanged.
            shift;
        }
        else
        {
            # scalars get passed in, but hashes and arrays need to
            # be referencised.

            ! $self->_getType($opt) ? shift  :
                $self->_getType($opt) eq 'HASH'  ? { @_ } : [ @_ ];
        }
    };

    $self->_setOpt($opt, $val);
}

=head2 getHelpRaw

This function will go through all the parameters and construct a list
of hashes for constructing your own help.  It's also the internal function
used by getHelp to create its help screen.

Each hash has the following keys:

=over 4

=item param

Array ref of parameter names.  This is what the user passes in, e.g., "-f" or
"--foo".

=item help

The string associated with the parameter (if this was a code ref, the code
is called, and this is the return from there).

=item default

If there is a default (that doesn't die when validated), or if the value
was already on the command line, that value.  If the default does die, then
this key will be absent (i.e., no default, or mandatory, or however you
want to interpret this).

=back

=cut

sub getHelpRaw
{
    my $self = _self_or_global(shift);

    # get the list of parameters ...
    my $accept    = $self->{accept_opts};
    my $unaccept  = $self->{unacceptable};
    my @params = sort grep {
        # skip unaccepted parameters
        $unaccept and not $unaccept->{$_}
    } keys %$accept;

    # start figuring it out.
    my @raw;
    for my $param (@params)
    {
        my %opt;

        my $param_info = $accept->{$param};
        my @keys = ($param, @{$param_info->{aliases}});
        #### @keys

        # booleans get the "no" version.
        if ($param_info->{spec} =~ /!/)
        {
            @keys = map { length > 1 ? ($_, "no$_") : $_ } @keys;
        }
        #### @keys

        # anything with more than one letter gets a double-dash.
        @keys = map { length > 1 ? "--$_" : "-$_" } @keys;
        $opt{param} = \@keys;
        #### @keys

        $opt{help} = ref $param_info->{help} ?
            $param_info->{help}->() : $param_info->{help};

        # determine default (or set value)
        my $default;
        eval {
            $opt{default} = $self->getOpt($param);
        };
        push @raw, \%opt;
    }
    LIST { @raw };
}

=head2 getHelp

Returns a string representation of the above raw help.

=cut

sub getHelp
{
    my $self = _self_or_global(shift);
    my @raw = $self->getHelpRaw;

    require Text::Table;
    #require Text::Wrap;

    my $tb = Text::Table->new();
    for my $param (@raw)
    {
        my $opt = join ",\n  ", @{$param->{param}};
        my $txt = $param->{help};
        $txt .= "\n Default: [" . $param->{default} . "]" if exists $param->{default};

        $tb->add($opt, $txt);
    }
    $tb;
}

=head1 AUTHOR

Darin McBride, C<< <dmcbride at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-getopt-modular at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Getopt-Modular>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Getopt::Modular


You can also look for information at:

=over 4

=item * SourceForge

L<http://sourceforget.net/projects/getopt-modular>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Getopt-Modular>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Getopt-Modular>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Getopt-Modular>

=item * Search CPAN

L<http://search.cpan.org/dist/Getopt-Modular>

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2008 Darin McBride, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of Getopt::Modular
