File Coverage

blib/lib/App/CmdDispatch/Help.pm

Criterion	Covered	Total	%
statement	110	110	100.0
branch	58	62	93.5
condition	8	11	72.7
subroutine	25	25	100.0
pod	5	5	100.0
total	206	213	96.7

package App::CmdDispatch::Help;

use warnings;
use strict;

our $VERSION = '0.42';

sub new
{
    my ( $class, $owner, $commands, $config ) = @_;
    $config ||= {};
    die "Command definition is not a hashref.\n" unless ref $commands eq ref {};
    die "No commands specified.\n"               unless keys %{$commands};
    die "Config parameter is not a hashref.\n"   unless ref $config   eq ref {};
    die "Invalid owner object.\n" unless eval { $owner->isa( 'App::CmdDispatch' ); };
    _extend_table_with_help( $commands );
    my %conf = (
        indent_hint => '  ',
        indent_help => '        ',
        _extract_config_parm( $config, 'indent_hint' ),
        _extract_config_parm( $config, 'pre_hint' ),
        _extract_config_parm( $config, 'post_hint' ),
        _extract_config_parm( $config, 'indent_help' ),
        _extract_config_parm( $config, 'pre_help' ),
        _extract_config_parm( $config, 'post_help' ),
    );
    return bless { owner => $owner, %conf }, $class;
}

sub _extract_config_parm
{
    my ( $config, $parm ) = @_;
    return unless defined $config->{"help:$parm"};
    return ( $parm => $config->{"help:$parm"} );
}

sub _extend_table_with_help
{
    my ( $commands ) = @_;
    $commands->{help} = {
        code     => \&_dispatch_help,
        clue     => "help [command|alias]",
        abstract => 'Display complete help',
        help     => "Display help about commands and/or aliases. Limit display with the\nargument.",
    };
    $commands->{hint} = {
        code     => \&_dispatch_hint,
        clue     => "hint [command|alias]",
        abstract => 'Display command hints',
        help     => 'A list of commands and/or aliases. Limit display with the argument.',
    };
    return;
}

sub _dispatch_help
{
    my $owner = shift;
    return $owner->{_helper}->help( @_ );
}

sub _dispatch_hint
{
    my $owner = shift;
    return $owner->{_helper}->hint( @_ );
}

sub _hint_string
{
    my ( $self, $cmd, $maxlen ) = @_;
    my $desc = $self->_table->get_command( $cmd );
    return '' unless $desc;
    my $indent = ( $maxlen ? ' ' x ( 3 + $maxlen - length $desc->{clue} ) : '   ' );
    return $desc->{clue} . ( $desc->{abstract} ? $indent . $desc->{abstract} : '' );
}

sub _clue_string
{
    my ( $self, $cmd ) = @_;
    my $desc = $self->_table->get_command( $cmd );
    return '' unless $desc;
    return $desc->{clue};
}

sub _alias_hint
{
    my ($self, $alias) = @_;
    return "$alias\t: " . $self->_table->get_alias( $alias );
}

sub _help_string
{
    my ( $self, $cmd ) = @_;
    my $desc = $self->_table->get_command( $cmd );

    return '' unless defined $desc->{help};
    return join( "\n", map { $self->{indent_help} . $_ } split /\n/, $desc->{help} );
}

sub _list_command
{
    my ( $self, $code ) = @_;
    $self->_print( "\nCommands:\n" );
    foreach my $c ( $self->{owner}->command_list() )
    {
        # The following should not be possible. But I'll keep this until
        # I'm absolutely certain.
        next if $c eq '' or !$self->_table->get_command( $c );
        $self->_print( $code->( $c ) );
    }
    return;
}

sub _list_aliases
{
    my ( $self ) = @_;
    return unless $self->_table->has_aliases;

    $self->_print( "\nAliases:\n" );
    foreach my $c ( $self->{owner}->alias_list() )
    {
        $self->_print( $self->{indent_hint} . $self->_alias_hint( $c ) . "\n" );
    }
    return;
}

sub _is_missing { return !defined $_[0] || $_[0] eq ''; }

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

    my $maxlen = 0;
    my $len;
    foreach my $cmd ( $self->_table->command_list() )
    {
        $len = length $self->_table->get_command( $cmd )->{clue};
        $maxlen = $len if $len > $maxlen;
    }
    return $maxlen;
}

sub hint
{
    my ( $self, $arg ) = @_;

    if( _is_missing( $arg ) )
    {
        my $maxlen = $self->_get_abstract_offset();
        $self->_print( "\n$self->{pre_hint}\n" ) if $self->{pre_hint};
        $self->_list_command(
            sub { $self->{indent_hint}, $self->_hint_string( $_[0], $maxlen ), "\n"; } );
        $self->_list_aliases();
        $self->_print( "\n$self->{post_hint}\n" ) if $self->{post_hint};
        return;
    }

    if( $self->_table->get_command( $arg ) )
    {
        $self->_print( "\n", $self->_hint_string( $arg ), "\n" );
    }
    elsif( $self->_table->get_alias( $arg ) )
    {
        $self->_print( "\n", $self->_alias_hint( $arg ), "\n" );
    }
    elsif( $arg eq 'commands' )
    {
        my $maxlen = $self->_get_abstract_offset();
        $self->_list_command( sub { $self->{indent_hint}, $self->_hint_string( $_[0], $maxlen ), "\n"; } );
    }
    elsif( $arg eq 'aliases' )
    {
        $self->_list_aliases();
    }
    else
    {
        $self->_print( "Unrecognized command '$arg'\n" );
    }

    return;
}

sub help
{
    my ( $self, $arg ) = @_;

    if( _is_missing( $arg ) )
    {
        $self->_print( "\n$self->{pre_help}\n" ) if $self->{pre_help};
        $self->_list_command(
            sub {
                $self->{indent_hint}, $self->_clue_string( $_[0] ), "\n",
                    $self->_help_string( $_[0] ), "\n";
            }
        );
        $self->_list_aliases();
        $self->_print( "\n$self->{post_help}\n" ) if $self->{post_help};
        return;
    }

    if( $self->_table->get_command( $arg ) )
    {
        $self->_print( "\n", $self->_clue_string( $arg ),
            "\n", ( $self->_help_string( $arg ) || $self->{indent_help} . "No help for '$arg'" ),
            "\n" );
    }
    elsif( $self->_table->get_alias( $arg ) )
    {
        $self->_print( "\n", $self->_alias_hint( $arg ), "\n" );
    }
    elsif( $arg eq 'commands' )
    {
        $self->_list_command(
            sub {
                $self->{indent_hint}, $self->_clue_string( $_[0] ), "\n",
                    $self->_help_string( $_[0] ), "\n";
            }
        );
    }
    elsif( $arg eq 'aliases' )
    {
        $self->_list_aliases();
    }
    else
    {
        $self->_print( "Unrecognized command '$arg'\n" );
    }

    return;
}

sub normalize_command_help
{
    my ( $self, $table ) = @_;
    foreach my $cmd ( $table->command_list )
    {
        my $desc = $table->get_command( $cmd );
        $desc->{clue} = $cmd unless defined $desc->{clue};
        $desc->{hint} = ''   unless defined $desc->{hint};
        $desc->{help} = ''   unless defined $desc->{help};
    }
    return;
}

sub sort_commands
{
    return ( sort grep { $_ ne 'hint' && $_ ne 'help' } @_ ), 'hint', 'help';
}

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

sub _table { return $_[0]->{owner}->{table}; }

1;
__END__