File Coverage

blib/lib/Declare/Opts.pm

Criterion	Covered	Total	%
statement	117	118	99.1
branch	58	66	87.8
condition	26	31	83.8
subroutine	19	19	100.0
pod	6	8	75.0
total	226	242	93.3

package Declare::Opts;
use strict;
use warnings;

our $VERSION = "0.005";

use Carp qw/croak/;

use Exporter::Declare qw{
    import
    gen_default_export
    default_export
};

gen_default_export 'OPTS_META' => sub {
    my ( $class, $caller ) = @_;
    my $meta = $class->new();
    $meta->{class} = $caller;
    return sub { $meta };
};

default_export opt        => sub { caller->OPTS_META->opt( @_ )   };
default_export parse_opts => sub { caller->OPTS_META->parse( @_ ) };
default_export opt_info   => sub { caller->OPTS_META->info        };

sub class   { shift->{class}   }
sub opts    { shift->{opts}    }
sub default { shift->{default} }

sub new {
    my $class = shift;
    my ( %opts ) = @_;

    my $self = bless { opts => {}, default => {} } => $class;
    $self->opt( $_, $opts{$_} ) for keys %opts;

    return $self;
}

sub valid_opt_params {
    return qr/^(alias|list|bool|default|check|transform|description)$/;
}

sub opt {
    my $self = shift;
    my ( $name, %config ) = @_;

    croak "opt '$name' already defined"
        if $self->opts->{$name};

    for my $prop ( keys %config ) {
        next if $prop =~ $self->valid_opt_params;
        croak "invalid opt property: '$prop'";
    }

    $config{name} = $name;

    croak "'check' cannot be used with 'bool'"
        if $config{bool} && $config{check};

    croak "'transform' cannot be used with 'bool'"
        if $config{bool} && $config{transform};

    croak "opt properties 'list' and 'bool' are mutually exclusive"
        if $config{list} && $config{bool};

    if (exists $config{default}) {
        croak "References cannot be used in default, wrap them in a sub."
            if ref $config{default} && ref $config{default} ne 'CODE';
        $self->default->{$name} = $config{default};
    }

    if ( exists $config{check} ) {
        my $ref = ref $config{check};
        croak "'$config{check}' is not a valid value for 'check'"
            if ($ref && $ref !~ m/^(CODE|Regexp)$/)
            || (!$ref && $config{check} !~ m/^(file|dir|number)$/);
    }

    if ( exists $config{alias} ) {
        my $aliases = ref $config{alias} ?   $config{alias}
                                         : [ $config{alias} ];

        $config{_alias} = { map { $_ => 1 } @$aliases };

        for my $alias ( @$aliases ) {
            croak "Cannot use alias '$alias', name is already taken by another opt."
                if $self->opts->{$alias};

            $self->opts->{$alias} = \%config;
        }
    }

    $self->opts->{$name} = \%config;
}

sub parse {
    my $self = shift;
    my @opts = @_;

    my $params = [];
    my $flags = {};
    my $no_flags = 0;

    while ( my $opt = shift @opts ) {
        if ( $opt eq '--' ) {
            $no_flags++;
        }
        elsif ( $opt =~ m/^-+([^-=]+)(?:=(.+))?$/ && !$no_flags ) {
            my ( $key, $value ) = ( $1, $2 );

            my $name = $self->_flag_name( $key );
            my $values = $self->_flag_value(
                $name,
                $value,
                \@opts
            );

            if( $self->opts->{$name}->{list} ) {
                push @{$flags->{$name}} => @$values;
            }
            else {
                $flags->{$name} = $values->[0];
            }
        }
        else {
            push @$params => $opt;
        }
    }

    # Add defaults for opts not provided
    for my $opt ( keys %{ $self->default } ) {
        next if exists $flags->{$opt};
        my $val = $self->default->{$opt};
        $flags->{$opt} = ref $val ? $val->() : $val;
    }

    return ( $params, $flags );
}

sub info {
    my $self = shift;
    return {
        map { $self->opts->{$_}->{name} => $self->opts->{$_}->{description} || "No Description" }
            keys %{ $self->opts }
    };
}

sub _flag_value {
    my $self = shift;
    my ( $flag, $value, $opts ) = @_;

    my $spec = $self->opts->{$flag};

    if ( $spec->{bool} ) {
        return [$value] if defined $value;
        return [$spec->{default} ? 0 : 1];
    }

    my $val = defined $value ? $value : shift @$opts;

    my $out = $spec->{list} ? [ split /\s*,\s*/, $val ]
                            : [ $val ];

    $self->_validate( $flag, $spec, $out );

    return $out unless $spec->{transform};
    return [ map { $spec->{transform}->($_) } @$out ];
}

sub _validate {
    my $self = shift;
    my ( $flag, $spec, $value ) = @_;

    my $check = $spec->{check};
    return unless $check;
    my $ref = ref $check || "";

    my @bad;

    if ( $ref eq 'Regexp' ) {
        @bad = grep { $_ !~ $check } @$value;
    }
    elsif ( $ref eq 'CODE' ) {
        @bad = grep { !$check->( $_ ) } @$value;
    }
    elsif ( $check eq 'file' ) {
        @bad = grep { ! -f $_ } @$value;
    }
    elsif ( $check eq 'dir' ) {
        @bad = grep { ! -d $_ } @$value;
    }
    elsif ( $check eq 'number' ) {
        @bad = grep { m/\D/ } @$value;
    }

    return unless @bad;
    my $type = $ref || $check;
    die "Validation Failed for '$flag=$type': " . join( ", ", @bad ) . "\n";
}

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

    # Exact match
    return $self->opts->{$key}->{name}
        if $self->opts->{$key};

    my %matches = map { $self->opts->{$_}->{name} => 1 }
        grep { m/^$key/ }
            keys %{ $self->opts };
    my @matches = keys %matches;

    die "partial option '$key' is ambiguous, could be: " . join( ", " => @matches ) . "\n"
        if @matches > 1;

    die "unknown option '$key'\n"
        unless @matches;

    return $matches[0];
}

1;

__END__