File Coverage

blib/lib/Getopt/Param.pm

Criterion	Covered	Total	%
statement	105	108	97.2
branch	49	58	84.4
condition	8	13	61.5
subroutine	18	19	94.7
pod	11	11	100.0
total	191	209	91.3

package Getopt::Param;

use warnings;
use strict;
use Carp;

use version; our $VERSION = qv('0.0.5');

use Locale::Maketext::Pseudo;
use Class::Std;
use Class::Std::Utils;

{
    my %lang;
    my %opts;
    my %quiet;
    my %args_ar;
    my %help_cr;

    sub BUILD {
        my ($prm, $ident, $arg_ref) = @_;

        $lang{ $ident } = ref $arg_ref->{'lang_obj'} && $arg_ref->{'lang_obj'}->can('maketext')
            ? $arg_ref->{'lang_obj'} : Locale::Maketext::Pseudo->new();

        $opts{ $ident }    = {};
        $quiet{ $ident }   = $arg_ref->{'quiet'} || 0;
        my $args_ar        = ref $arg_ref->{'array_ref'} ne 'ARRAY' ? \@ARGV : $arg_ref->{'array_ref'};
        my @nodestruct     = @{ $args_ar };
        $args_ar{ $ident } = \@nodestruct;

        my $idx = 0;
        ARG_ITEM:
        for my $arg ( @{ $args_ar{ $ident } } ) {
            last ARG_ITEM if $arg eq '--';

            my $rg = $arg_ref->{'strict'} ? qr{^--([^-])} : qr{^--(.)};

            if( $arg =~ s/$rg/$1/ ) {
                my($flag, $value) = split /=/, $arg, 2;
                push @{ $opts{ $ident }->{ $flag } }, defined $value ? $value : '--' . $flag;
            }
            else {
                carp $lang{ $ident }->maketext('Argument [_1] did not match [_2]', $idx, $rg) if !$quiet{ $ident };
            }
            $idx++;
        }

        if ( $opts{ $ident }->{'help'} && $arg_ref->{'help_coderef'} ) {
            $arg_ref->{'help_coderef'}->($prm);
        }

        $help_cr{$ident} = $arg_ref->{'help_coderef'} || sub { croak $lang{ $ident }->maketext(q{No '[_1]' function defined}, 'help') };

        if ( !keys %{$opts{$ident}} && $arg_ref->{'no_args_help'} ) {
            $help_cr{$ident}->($prm);
        }

        if( ref $arg_ref->{'known_only'} eq 'ARRAY') {
            my %lookup;
            @lookup{ @{$arg_ref->{'known_only'}} } = ();

            my $unknown = 0;
            for my $k (keys %{$opts{$ident}}) {
                if (!exists $lookup{$k}) {
                    $unknown++;
                    # $k =~ s{\W}{?}g; # or quotemeta()
                    carp $lang{ $ident }->maketext(q{Unknown argument '[_1]'}, quotemeta($k));
                }
            }
            $help_cr{$ident}->($prm) if $unknown;
        }

        if( ref $arg_ref->{'required'} eq 'ARRAY') {

            my $missing = 0;
            for my $k (@{$arg_ref->{'required'}}) {
                if (!exists $opts{$ident}->{$k}) {
                    $missing++;
                    # $k =~ s{\W}{?}g; # or quotemeta()
                    carp $lang{ $ident }->maketext(q{Missing argument '[_1]'}, quotemeta($k));
                }
            }
            $help_cr{$ident}->($prm) if $missing;
        }

        if( ref $arg_ref->{'validate'} eq 'CODE') {
            $arg_ref->{'validate'}->($prm) || $help_cr{$ident}->($prm);
        }

        if ( ref $arg_ref->{'actions'} eq 'ARRAY' ) {
            for my $k ($arg_ref->{'actions'}) {
                if (exists $opts{$ident}->{$k->[0]}) {
                    if (ref $k->[1] eq 'CODE') {
                        $k->[1]->($prm);
                    }
                    else {
                        $help_cr{$ident}->($prm);
                    }
                }
            }
        }
    }

    sub help {
        my ($prm) = @_;
        $help_cr{ ident $prm }->();
    }

    sub get_param {
        my ($prm, $name) = @_;
        return if !exists $opts{ ident $prm }->{ $name }; # do not auto vivify it
        $opts{ ident $prm }->{ $name } = [] if ref $opts{ ident $prm }->{ $name } ne 'ARRAY';
        return wantarray ? @{ $opts{ ident $prm }->{ $name } }
                         : $opts{ ident $prm }->{ $name }->[0];
    }

    sub set_param {
        my ($prm, $name, @val) = @_;
        $opts{ ident $prm }->{ $name } = [ @val ];
            # = ref $val->[0] eq 'ARRAY' && @val == 1 ? [ @{ $val->[0] } ] : [@val];
    }

    sub list_params {
        my ($prm) = @_;
        return wantarray ? keys %{ $opts{ ident $prm } }
                         : [ keys %{ $opts{ ident $prm } } ]
                         ;
    }

    sub append_param {
        my ($prm, $name, @val) = @_;
        $opts{ ident $prm }->{ $name } = [] if ref $opts{ ident $prm }->{ $name } ne 'ARRAY';
        $opts{ ident $prm }->{ $name } = [ @{ $opts{ ident $prm }->{ $name } }, @val ];
    }

    sub prepend_param {
        my ($prm, $name, @val) = @_;
        $opts{ ident $prm }->{ $name } = [] if ref $opts{ ident $prm }->{ $name } ne 'ARRAY';
        $opts{ ident $prm }->{ $name } = [ @val, @{ $opts{ ident $prm }->{ $name } } ];
    }

    sub param {
       my ($prm, $name, @val) = @_;
       return $prm->list_params() if !$name;
       $prm->set_param( $name, @val ) if @val;
       return $prm->get_param( $name );
    }

    sub delete_param {
        my ($prm, $name) = @_;
        delete $opts{ ident $prm }->{ $name };
    }

    sub exists_param {
        my ($prm, $name) = @_;
        return 1 if exists $opts{ ident $prm }->{ $name };
        return;
    }

    sub get_param_hashref {
        my ($prm) = @_;
        my %new_hash = %{ $opts{ ident $prm } };
        return \%new_hash; # deref first so the internal one does not risk ferdidling
    }
}

1;

__END__