File Coverage

blib/lib/Getopt/Kingpin/Base.pm

Criterion	Covered	Total	%
statement	98	98	100.0
branch	36	36	100.0
condition			n/a
subroutine	17	17	100.0
pod	5	5	100.0
total	156	156	100.0

package Getopt::Kingpin::Base;
use 5.008001;
use strict;
use warnings;
use Object::Simple -base;
use Carp;
use Path::Tiny;

our $VERSION = "0.10";
our $types;
sub AUTOLOAD {
    my $self = shift;
    my $func = our $AUTOLOAD;
    $func =~ s/.*:://;
    my $type = _camelize($func);

    $self->_set_types($type);

    $self->type($type);

    return $self;
}

sub DESTROY {
    return 1;
}

sub _set_types {
    my $self = shift;
    my ($type) = @_;

    if (not exists $types->{$type}) {
        my $module = sprintf "Getopt::Kingpin::Type::%s", $type;
        $module =~ s/(?:List|Hash)$//;
        if (not $module->can('set_value')) {
            croak "type error '$type'" unless eval "require $module"; ## no critic
        }
        $types->{$type} = {
            type      => \&{"${module}::type"},
            set_value => \&{"${module}::set_value"},
        };
    }

    if ($type eq "Bool") {
        if (not defined $self->_default) {
            $self->_default(0);
        }
    }

    if ($type =~ /List$/) {
        $self->is_cumulative(1);
    }

    elsif ($type =~ /Hash$/) {
        $self->is_hash(1);
    }
}

sub _camelize {
    my $c = shift;
    $c =~ s/(^|_)(.)/uc($2)/ge;
    return $c;
}

use overload (
    '""' => sub {defined $_[0]->value ? $_[0]->value : ""},
    fallback => 1,
);

has name          => undef;
has short_name    => undef;
has description   => undef;
has value         => undef;
has _defined      => 0;
has is_cumulative => 0;
has is_hash       => 0;
has _default      => undef;
has _envar        => undef;
has type          => "String";
has _required     => 0;
has index         => 0;

sub short {
    my $self = shift;
    my ($short_name) = @_;

    $self->short_name($short_name);

    return $self;
}

sub default {
    my $self = shift;
    my ($default) = @_;

    $self->_default($default);

    return $self;
}

sub override_default_from_envar {
    my $self = shift;
    my ($envar_name) = @_;

    if (exists $ENV{$envar_name}) {
        $self->_envar($ENV{$envar_name});
    }

    return $self;
}

sub required {
    my $self = shift;
    $self->_required(1);

    return $self;
}

sub set_value {
    my $self = shift;
    my $type = $self->type;
    $self->_set_types($type);
    if ($self->is_cumulative) {
        my @values;
        if ($self->_defined) {
            @values = @{$self->value};
        }
        my @ret = $types->{$type}->{set_value}->($self, @_);
        if (scalar @ret > 1) {
            return undef, $ret[1];
        }
        push @values, $ret[0];
        $self->_defined(1);
        $self->value(\@values);
    } elsif ($self->is_hash) {
        my %values;
        if ($self->_defined) {
            %values = %{$self->value};
        }
        my ($key, $val) = (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : split(/=/, $_[0], 2);
        my @ret = $types->{$type}->{set_value}->($self, $val);
        if (scalar @ret > 1) {
            return undef, $ret[1];
        }
        $values{$key} = $ret[0];
        $self->_defined(1);
        $self->value(\%values);
    } elsif ($self->_defined) {
        printf STDERR "error: flag '%s' cannot be repeated, try --help\n", $self->name;
        return undef, 1;
    } else {
        $self->_defined(1);
        my @ret = $types->{$type}->{set_value}->($self, @_);
        if (scalar @ret > 1) {
            # has error
            return undef, $ret[1];
        }
        return $self->value($ret[0]);
    }
}

1;
__END__