File Coverage

blib/lib/App/CmdDispatch.pm

Criterion	Covered	Total	%
statement	112	122	91.8
branch	37	52	71.1
condition	8	13	61.5
subroutine	22	22	100.0
pod	9	9	100.0
total	188	218	86.2

package App::CmdDispatch;

use warnings;
use strict;

use Config::Tiny;
use Term::ReadLine;
use App::CmdDispatch::IO;
use App::CmdDispatch::Table;

our $VERSION = '0.42';

sub new
{
    my ( $class, $commands, $options ) = @_;

    $options ||= {};
    die "Command definition is not a hashref.\n" unless ref $commands eq ref {};
    die "No commands specified.\n" unless keys %{$commands};
    die "Options parameter is not a hashref.\n" unless $options and ref $options eq ref {};

    $options = { %{$options} };
    my $config_file = delete $options->{config};
    my $aliases;
    my $self = bless { config => $options }, $class;
    $self->{_command_sorter} = delete $self->{config}->{command_sort}
        if $self->{config}->{command_sort} && 'CODE' eq ref $self->{config}->{command_sort};
    if( defined $config_file )
    {
        die "Supplied config is not a file.\n" unless -f $config_file;
        $self->_initialize_config( $config_file );
    }
    $aliases = delete $self->{config}->{alias};
    $aliases = {} unless ref $aliases eq ref {};

    $commands = $self->_setup_commands( $commands );

    # TODO - replace the hard-coded Table module name with a parameter.
    my $table = App::CmdDispatch::Table->new( $commands, $aliases );
    if( $self->{_helper} )
    {
        $self->{_helper}->normalize_command_help( $table );
        $self->{_command_sorter} ||= ( ref $self->{_helper} )->can( "sort_commands" );
    }
    $self->{table} = $table;
    $self->_initialize_io_object();
    $self->{_command_sorter} ||= sub { return ( sort @_ ); };

    return $self;
}

sub get_config { return $_[0]->{config}; }

sub run
{
    my ( $self, $cmd, @args ) = @_;

    eval {
        $self->{table}->run( $self, $cmd, @args );
        1;
    } or do
    {
        my $ex = $@;
        if( ref( $ex ) =~ /\AApp::CmdDispatch::Exception/ )
        {
            $self->_print( $ex->why(), "\n" );
            $self->command_hint;
        }
        else
        {
            die $ex;
        }
    };
    return;
}

sub command_list
{
    my ( $self ) = @_;
    return $self->{_command_sorter}->( $self->{table}->command_list() );
}

sub command_hint
{
    my ( $self ) = @_;
    return $self->{_helper}->hint() if defined $self->{_helper};
    $self->_print( "Commands: ", join( ', ', $self->command_list() ), "\n" );
    return;
}

sub hint
{
    my ( $self, $arg ) = @_;
    eval {
        $self->run( 'hint', $arg );
        1;
    } or do
    {
        return $self->{_helper}->hint( $arg ) if defined $self->{_helper};
        $self->_print( "Commands: ", join( ', ', $self->command_list() ), "\n" );
    };
    return;
}

sub help
{
    my ( $self, $arg ) = @_;
    eval {
        $self->run( 'help', $arg );
        1;
    } or do
    {
        return $self->{_helper}->help( $arg ) if defined $self->{_helper};
        $self->_print( "Commands: ", join( ', ', $self->command_list() ), "\n" );
    };
    return;
}

sub alias_list { return $_[0]->{table}->alias_list(); }

sub shell
{
    my ( $self ) = @_;

    $self->_print( "Enter a command or 'quit' to exit:\n" );
    while ( my $line = $self->_prompt( '> ' ) )
    {
        chomp $line;
        next unless $line =~ /\S/;
        last if $line eq 'quit';
        $self->run( split /\s+/, $line );
    }
    return;
}

sub _print
{
    my $self = shift;
    return $self->{io}->print( @_ );
}

sub _prompt
{
    my $self = shift;
    return $self->{io}->prompt( @_ );
}

sub _initialize_config
{
    my ( $self, $config_file ) = @_;
    my $conf = Config::Tiny->read( $config_file );
    %{ $self->{config} } = (
        ( $conf->{_} ? %{ delete $conf->{_} } : () ),    # first extract the top level
        %{$conf},                # Keep any multi-levels that are not aliases
        %{ $self->{config} },    # Override with supplied parameters
    );
    return;
}

sub _initialize_io_object
{
    my ( $self ) = @_;

    my $io = delete $self->{config}->{'io'};
    if( !defined $io )
    {
        eval {
            $io = App::CmdDispatch::IO->new();
        } or do {
            $io = App::CmdDispatch::MinimalIO->new();
        };
        die "Unable to create an IO object for CmdDispatch.\n" unless defined $io;
    }
    elsif( !_is_valid_io_object( $io ) )
    {
        die "Object supplied as io parameter does not supply correct interface.\n";
    }

    $self->{io} = $io;
    return;
}

sub _is_valid_io_object
{
    my ( $io ) = @_;
    return unless ref $io;
    return 2 == grep { $io->can( $_ ) } qw/print prompt/;
}

sub _setup_commands
{
    my ( $self, $commands ) = @_;
    $commands = { %{$commands} };

    return $commands unless $self->{config}->{default_commands};

    foreach my $def ( split / /, $self->{config}->{default_commands} )
    {
        if( $def eq 'shell' )
        {
            $commands->{shell} = {
                code     => \&App::CmdDispatch::shell,
                clue     => 'shell',
                abstract => 'Launch an interactive command shell.',
                help     => 'Execute commands as entered until quit.',
            };
        }
        elsif( $def eq 'help' )
        {
            require App::CmdDispatch::Help;
            $self->{_helper} = App::CmdDispatch::Help->new( $self, $commands, $self->{config} );
        }
        else
        {
            die "Unrecognized default command: '$def'\n";
        }
    }
    return $commands;
}

1;

__END__