File Coverage

blib/lib/Declare/CLI.pm

Criterion	Covered	Total	%
statement	233	239	97.4
branch	96	120	80.0
condition	39	51	76.4
subroutine	34	36	94.4
pod	16	16	100.0
total	418	462	90.4

package Declare::CLI;
use strict;
use warnings;

use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use List::Util qw/max/;

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

our $VERSION = 0.009;

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

default_export arg => sub {
    my ( $meta, @params ) = _parse_params(@_);
    $meta->add_arg(@params);
};

default_export opt => sub {
    my ( $meta, @params ) = _parse_params(@_);
    $meta->add_opt(@params);
};

default_export describe_opt => sub {
    my ( $meta, @params ) = _parse_params(@_);
    $meta->describe( 'opt' => @params );
};

default_export describe_arg => sub {
    my ( $meta, @params ) = _parse_params(@_);
    $meta->describe( 'arg' => @params );
};

default_export usage => sub {
    my ( $meta, @params ) = _parse_params(@_);
    $meta->usage(@params);
};

for my $name (qw/ preparse parse process run handle /) {
    default_export "${name}_cli" => sub {
        my $consumer = shift;
        my $meta     = $consumer->CLI_META;
        return $meta->$name( $consumer, @_ );
    };
}

sub _parse_params {
    my ( $first, @params ) = @_;

    my $ref  = ref $first;
    my $type = blessed $first;

    return ( $first->CLI_META, @params )
        if ( $type || !$ref ) && eval { $first->can('CLI_META') };

    my $meta = eval { caller(2)->CLI_META };
    croak "Could not find meta data object: $@"
        unless $meta;

    return ( $meta, @_ );
}

sub class     { shift->{class} }
sub args      { shift->{args} }
sub opts      { shift->{opts} }
sub _defaults { shift->{defaults} }

sub new {
    my $class  = shift;
    my %params = @_;
    my $self   = bless {args => {}, opts => {}, defaults => {}} => $class;

    $self->add_arg( $_ => $params{args}->{$_} ) for keys %{$params{args} || {}};

    $self->add_arg( $_ => $params{opts}->{$_} ) for keys %{$params{opts} || {}};

    return $self;
}

sub describe {
    my $self = shift;
    my ( $type, $name, $desc ) = @_;

    my $meth = $type . 's';
    croak "No such $type '$name'"
        unless $self->$meth->{$name};

    $self->$meth->{$name}->{description} = $desc if $desc;

    return $self->$meth->{$name}->{description};
}

sub valid_arg_params {
    return qr/^(alias|description|handler)$/;
}

sub add_arg {
    my $self = shift;
    my ( $name, @params ) = @_;
    my %config = @params > 1 ? @params : ( handler => $params[0] );

    croak "arg '$name' already defined"
        if $self->args->{$name};

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

    $config{name} = $name;
    $config{description} ||= "No Description.";

    croak "You must provide a handler"
        unless $config{handler};

    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 arg."
                if $self->args->{$alias};

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

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

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

sub add_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;
    $config{description} ||= "No Description.";

    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->_defaults->{$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 _opt_value {
    my $self = shift;
    my ( $opt, $value, $cli ) = @_;

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

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

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

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

sub _validate {
    my $self = shift;
    my ( $opt, $value ) = @_;
    my $spec = $self->opts->{$opt};

    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 '$opt=$type': " . join( ", ", @bad ) . "\n";
}

sub usage {
    my $self = shift;

    my $arg_len = max map { length $_ } keys %{$self->args};
    my $opt_len = max map { length $_ } keys %{$self->opts};

    my %seen;
    my $opts = join "\n" => sort map {
        my $spec  = $self->opts->{$_};
        my $name  = $spec->{name};
        my $value = $spec->{bool} ? "" : $spec->{list} ? "XXX,..." : "XXX";

        $seen{$name}++ ? () : sprintf(
            "    -%-${opt_len}s %-7s    %s",
            $name,
            $value,
            $spec->{description}
        );
    } keys %{$self->opts};

    %seen = ();
    my $cmds = join "\n" => sort map {
        my $spec = $self->args->{$_};
        my $name = $spec->{name};

        $seen{$name}++ ? () : sprintf(
            "    %-${arg_len}s    %s",
            $name,
            $spec->{description}
        );
    } keys %{$self->args};

    return <<"    EOT";
Options:
$opts

Arguments:
$cmds

    EOT
}

sub preparse {
    my $self = shift;
    my (@cli) = @_;
    return $self->_parse_cli( 'pre', @cli );
}

sub parse {
    my $self = shift;
    my ( $consumer, @cli ) = @_;
    my ( $opts, $args ) = $self->_parse_cli( 0, @cli );
    $self->_process_opts( $consumer, $opts );
    return ( $opts, $args );
}

sub run {
    my $self = shift;
    my ( $consumer, $opts, $args ) = @_;

    croak "No argument specified"
        unless $args && @$args;

    my $arg = shift @$args;
    my $name = $self->_item_name( 'argument', $self->args, $arg );

    my $handler = $self->args->{$name}->{handler};

    croak "Invalid argument '$arg'"
        unless $handler;

    return $consumer->$handler( $name, $opts, @$args );
}

sub handle {
    my $self = shift;
    my ( $consumer, @cli )  = @_;
    my ( $opts,     $args ) = $self->parse(@_);
    return $self->run( $consumer, $opts, $args );
}

sub process_cli { goto &process }

sub process {
    my $self = shift;
    my ( $consumer, @cli ) = @_;

    warn "process and process_cli are deprecated\n";

    my ( $opts, $args ) = $self->parse(@_);
    $consumer->set_opts($opts) if $consumer->can('set_opts');
    $consumer->set_args($args) if $consumer->can('set_args');

    return $opts
        unless @$args
        && $self->_item_name( 'argument', $self->args, $args->[0] );

    return $self->run( $consumer, $opts, $args );
}

sub _parse_cli {
    my $self = shift;
    my ( $pre, @cli ) = @_;

    my $args    = [];
    my $opts    = {};
    my $no_opts = 0;

    while ( my $item = shift @cli ) {
        my ( $opt, $value );

        if ( $item eq '--' ) {
            $no_opts++;
            next;
        }

        if ( $item =~ m/^-+([^-=]+)(?:=(.+))?$/ && !$no_opts ) {
            my $key = $1;
            $value = $2;
            $opt = $self->_item_name( 'option', $self->opts, $key );
            die "unknown option '$key'\n" unless $pre || $opt;
        }

        # If we do not have an opt, push to args and go to next.
        unless ($opt) {
            push @$args => $item;
            next;
        }

        $value = $self->_opt_value(
            $opt,
            $value,
            \@cli
        );

        if ( $self->opts->{$opt}->{list} ) {
            push @{$opts->{$opt}} => @$value;
        }
        else {
            $opts->{$opt} = $value;
        }
    }

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

    return ( $opts, $args );
}

sub _process_opts {
    my $self = shift;
    my ( $consumer, $opts ) = @_;

    for my $opt ( keys %$opts ) {
        my $values = $opts->{$opt};
        my $list;

        if ( ref $values && ref $values eq 'ARRAY' ) {
            $list = 1;
        }
        else {
            $list   = 0;
            $values = [$values];
        }

        my $transform = $self->opts->{$opt}->{transform};
        my $trigger   = $self->opts->{$opt}->{trigger};

        $values = [map { $consumer->$transform($_) } @$values]
            if $transform;

        $self->_validate( $opt, $values );

        $opts->{$opt} = $list ? $values : $values->[0];

        $consumer->$trigger( $opt, $opts->{$opt}, $opts )
            if $trigger;
    }
}

sub _item_name {
    my $self = shift;
    my ( $type, $hash, $key ) = @_;

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

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

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

    return '' unless @matches;
    return $matches[0];
}

1;

__END__