File Coverage

blib/lib/Getopt/Param/Tiny.pm

Criterion	Covered	Total	%
statement	66	69	95.6
branch	43	48	89.5
condition	8	12	66.6
subroutine	5	6	83.3
pod	3	3	100.0
total	125	138	90.5

package Getopt::Param::Tiny;

use strict;
use vars qw($VERSION);
$VERSION = 0.5;

sub new {
    my ($self, $arg_ref) = @_;
    $self = bless {}, $self;

    $arg_ref->{'quiet'}  ||= 0;
    $arg_ref->{'strict'} ||= 0;

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

    $self->{'opts'} = {};

    my $idx = 0;
    ARG_ITEM:
    for my $arg ( @nodestruct ) {
        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 @{ $self->{'opts'}{ $flag } }, defined $value ? $value : '--' . $flag;
        }
        else {
            warn( sprintf('Argument %s did not match %s', $idx, $rg) ) if !$arg_ref->{'quiet'};
        }
        $idx++;
    }

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

    $self->{'help_coderef'} = $arg_ref->{'help_coderef'} || sub { die( sprintf(q{No '%s' function defined}, 'help') ) };

    if ( !keys %{$self->{'opts'}} && $arg_ref->{'no_args_help'} ) {
        $self->{'help_coderef'}->($self);
    }

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

        my $unknown = 0;
        for my $k (keys %{$self->{'opts'}}) {
            if (!exists $lookup{$k}) {
                $unknown++;
                # $k =~ s{\W}{?}g; # or quotemeta()
                warn( sprintf(q{Unknown argument '%s'}, quotemeta($k)) );
            }
        }
        $self->{'help_coderef'}->($self) if $unknown;
    }

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

        my $missing = 0;
        for my $k (@{$arg_ref->{'required'}}) {
            if (!exists $self->{'opts'}->{$k}) {
                $missing++;
                # $k =~ s{\W}{?}g; # or quotemeta()
                warn( sprintf(q{Missing argument '%s'}, quotemeta($k)) );
            }
        }
        $self->{'help_coderef'}->($self) if $missing;
    }

    if( ref $arg_ref->{'validate'} eq 'CODE') {
        $arg_ref->{'validate'}->($self) || $self->{'help_coderef'}->($self);
    }

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

    return $self;
}

sub help {
    my ($prm) = @_;
    $prm->{'help_coderef'}->($prm);
}

sub param {
    my ($self, $name, @val) = @_;
    return wantarray ? keys %{ $self->{'opts'} } : [ keys %{ $self->{'opts'} } ] if !$name;
    $self->{'opts'}{$name} = \@val if @val;
    return if !exists $self->{'opts'}{$name}; # do not auto vivify it
    return wantarray ? @{ $self->{'opts'}{$name} } : $self->{'opts'}{$name}->[0];
}

1;

__END__