File Coverage

blib/lib/Getopt/Modular.pm

Criterion	Covered	Total	%
statement	282	297	94.9
branch	120	142	84.5
condition	44	65	67.6
subroutine	37	40	92.5
pod	12	12	100.0
total	495	556	89.0

package Getopt::Modular;
$Getopt::Modular::VERSION = '0.13';
#ABSTRACT: Modular access to Getopt::Long

use warnings;
use strict;

use Getopt::Long;
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(type option value warning valid expected) ],
    },
    'Getopt::Modular::Internal' => {
        description => 'Internal Exception in commandline parsing/handling',
        fields => [ qw(type option) ]
    };
use Carp;


sub import
{
    my $class = shift;
    while (@_)
    {
        my $opt = shift;
        if ($opt eq '-namespace')
        {
            my $ns = shift || die "No namespace given";

            # I could do this without eval, but I'm too lazy today.
            eval qq{
                package $ns;
                \@${ns}::ISA = List::MoreUtils::uniq('Getopt::Modular', \@${ns}::ISA);
                1; } or die $@;
        }
        elsif ($opt eq '-getOpt')
        {
            my $package = caller || 'main';

            # again, too lazy right now.
            eval qq{
                package $package;
                sub getOpt { Getopt::Modular->getOpt(\@_) }
                1; } or die $@;
        }
    }
}


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->setBoolHelp(qw(off on));

    $self->init(@_);

    $self;
}

sub _self_or_global
{
    my $underscore = shift;
    my $self = $underscore->[0];

    # is it an object? use it.
    eval { ref $self && $self->isa(__PACKAGE__) } && return shift @$underscore;

    # passed in via class method?  skip it.
    eval { not ref $self && $self->isa(__PACKAGE__) } && shift @$underscore;

    # have global? use it.
    $global ? $global :
        # otherwise, create new.
        $self->new();
}

sub _accepts_opt
{
    my $self = _self_or_global(\@_);
    my $opt  = shift;
    return exists $self->{accept_opts}{$opt};
}

sub _opt
{
    my $self = _self_or_global(\@_);
    my $opt  = shift;

    if (@_)
    {
        $self->{accept_opts}{$opt} = shift;
        return;
    }

    unless (exists $self->{accept_opts}{$opt})
    {
        Getopt::Modular::Internal->throw(
                                         type    => 'unknown-option',
                                         message => "Unknown option: $opt",
                                         option  => $opt,
                                        );
    }
    return $self->{accept_opts}{$opt};
}


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


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

sub setMode
{
    my $self = _self_or_global(\@_);

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


sub setBoolHelp
{
    my $self = _self_or_global(\@_);
    $self->{bool_strings} = [ @_[0,1] ];
}


sub acceptParam
{
    my $self = _self_or_global(\@_);
    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 {
                                my $o = $self->_accepts_opt($param) ? $self->_opt($param) : {};
                                @{$o->{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->_accepts_opt($param))
        {
            my $opt = $self->_opt($param);
            @{$self->_opt($param)}{keys %$opts} = values %$opts;
        }
        else
        {
            # set some defaults ...
            $opts->{spec} ||= '';

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


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


sub parseArgs
{
    my $self = _self_or_global(\@_);

    # 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;

    # parse them
    my $warnings;
    my $success = do {
        local $SIG{__WARN__} = sub { $warnings .= "@_";};
        Getopt::Long::Configure("bundling");
        GetOptions(\%opts, @params);
    };
    if (not $success)
    {
        Getopt::Modular::Exception->throw(
                                          message => "Bad command-line: $warnings",
                                          type => 'getopt-long-failure',
                                          warning => $warnings,
                                         );
    }

    # now validate everything that was passed in, and save it.
    for my $opt (keys %$accept)
    {
        if (exists $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);
        }
    }

    # if passed in a hash ref to populate, fill it.
    if (@_ && ref $_[0] eq 'HASH')
    {
        my $opts = shift;
        for my $opt (keys %{$self->{accept_opts}})
        {
            $opts->{$opt} = $self->getOpt($opt);
        }
    }
}


sub getOpt
{
    my $self = _self_or_global(\@_);
    my $opt  = shift || Getopt::Modular::Exception->throw(
                                                          message => 'No option given?',
                                                          type => 'dev-error',
                                                         );

    if (not exists $self->{accept_opts}{$opt})
    {
        if ($self->{mode}{strict})
        {
            Getopt::Modular::Exception->throw(
                                              message => "No such option: $opt",
                                              type    => 'no-such-option',
                                              option  => $opt,
                                              value   => 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})
    {
        if (wantarray)
        {
            return
                ref $self->{options}{$opt} eq 'ARRAY' ? @{$self->{options}{$opt}} :
                ref $self->{options}{$opt} eq 'HASH'  ? %{$self->{options}{$opt}} :
            $self->{options}{$opt};
        }
        return $self->{options}{$opt}
    }

    return;
}

sub _getType
{
    my $self = _self_or_global(\@_);
    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'",
                                          type    => 'set-int-failure',
                                          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'",
                                          type    => 'set-real-failure',
                                          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(\@_);
    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",
                                              type    => 'validate-failure',
                                              option  => $opt,
                                              value   => $val,
                                             );
        }
    }

    if (my $valid = $self->_opt($opt)->{valid_values})
    {
        if (ref $valid eq 'CODE')
        {
            my @valid = $valid->();
            $valid = \@valid;
            $self->_opt($opt)->{valid_values} = $valid; # cache for next time.
        }

        if (ref $valid eq 'ARRAY')
        {
            unless (any { $_ eq $val } @$valid)
            {
                Getopt::Modular::Exception->throw(
                                                  message => "'$val' is an invalid value for $opt",
                                                  type    => 'validate-failure',
                                                  option  => $opt,
                                                  value   => $val,
                                                  valid   => $valid,
                                                 );
            }
        }
        else
        {
            Getopt::Modular::Exception->throw(
                                              message => "'valid_values requires either an array ref or a code ref to generate the list of valid values.",
                                              type => 'valid-values-error',
                                              option => $opt,
                                             );
        }
    }

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


sub setOpt
{
    my $self = _self_or_global(\@_);
    my $opt  = shift;
    my $val  = do {
        if (ref $_[0])
        {
            Getopt::Modular::Exception->throw(
                                              type    => 'wrong-type',
                                              message => "Wrong type of data for $opt.  Expected: " .
                                              ($self->_getType($opt) || 'SCALAR') .
                                              " got: " . (reftype $_[0] || 'SCALAR'),
                                              expected => ($self->_getType($opt) || 'SCALAR'),
                                              option => $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);
}


sub getHelpRaw
{
    my $self = _self_or_global(\@_);

    # 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}||[]});

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

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

            my $type = $self->_opt($param)->{spec};
            if ($type eq '' || $type eq '!') # boolean
            {
                my $bools = ( $self->_opt($param)->{help_bool} or $self->{bool_strings} );

                $opt{default} = $bools->[$opt{default} ? 1 : 0];
            }
        };

        # determine valid values.
        eval {
            $opt{valid_values} = $self->_opt($param)->{valid_values};

            no warnings;
            # if it's not a code ref, the eval will exit, but we'll already
            # have what we want anyway.
            $opt{valid_values} = [ $opt{valid_values}->() ];
        };

        # is it hidden?  It's still part of the raw output.
        $opt{hidden} = $param_info->{hidden} if exists $param_info->{hidden};

        push @raw, \%opt;
    }
    return @raw;
}


sub getHelp
{
    my $self = _self_or_global(\@_);
    my @raw = grep { not $_->{hidden} } $self->getHelpRaw;
    my $cbs = shift || {};

    require Text::Table;

    my $tb = Text::Table->new();
    for my $param (@raw)
    {
        my $opt = join ",\n  ", @{$param->{param}};
        my $txt = $param->{help};
        no warnings 'uninitialized';

        $txt .= "\n " . ($cbs->{current_value} || sub { "Current value: [". shift(). "]" })->($param->{default}) if exists $param->{default};

        if ($param->{valid_values})
        {
            # if it's a code ref, de-ref it.  If not, ignore the exception.
            eval { $param->{valid_values} = [ $param->{valid_values}->() ] };
            $txt .= "\n " . ($cbs->{valid_values} || sub { "Valid values: [". join(',', @_). "]" })->(@{$param->{valid_values}});
        }

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


sub getHelpWrap
{
    my $self = _self_or_global(\@_);
    my $width = (@_ && not ref $_[0]) ? shift : 80;
    my $cbs = shift || {};
    my @raw = grep { not $_->{hidden} } $self->getHelpRaw;

    require Text::Table;

    my $wrap = eval {
        require Text::WrapI18N;
        sub {
            local $Text::WrapI18N::columns = shift;
            local $Text::WrapI18N::unexpand;

            Text::WrapI18N::wrap('', '', @_);
        };
    } || do {
        require Text::Wrap;
        sub {
            local $Text::Wrap::columns = shift;
            local $Text::Wrap::unexpand;

            Text::Wrap::wrap('', '', @_);
        }
    };

    my $tb = Text::Table->new();
    my $load_data = sub {
        my $tb    = shift;
        my $param = shift;

        my $opt = join ",\n  ", @{$param->{param}};
        my $txt = shift;

        my $available = shift;

        no warnings 'uninitialized';

        $txt .= "\n " . ($cbs->{current_value} || sub { "Current value: [". shift(). "]" })->($param->{default}) if exists $param->{default};
        $txt .= "\n " . ($cbs->{valid_values} || sub { "Valid values: [". join(',', @_). "]" })->(@{$param->{valid_values}}) if $param->{valid_values};

        # wrap all lines
        $txt = $wrap->($available, $txt) if $available;

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

    for my $param (@raw)
    {
        $load_data->($tb, $param, $param->{help});
    }

    if ($tb->width > $width)
    {
        # rebuild, wrapped.
        my @colrange = $tb->colrange(0);
        my $available = $width - $colrange[1] - 1; # 1 for extra space between columns

        $tb->clear();
        for my $param (@raw)
        {
            $load_data->($tb, $param, $param->{help}, $available);
        }
    }

    # if the current value or valid values are a block of text too long, we don't want all
    # lines to be too long, so clobber the extra spaces that Text::Table puts in at the end.
    (my $txt = "".$tb) =~ s/\s+$//msg;
    $txt .= "\n";
    $txt;
}


1; # End of Getopt::Modular

__END__