File Coverage

lib/CLI/Framework/Application.pm

Criterion	Covered	Total	%
statement	212	338	62.7
branch	51	132	38.6
condition	10	36	27.7
subroutine	45	57	78.9
pod	34	34	100.0
total	352	597	58.9

package CLI::Framework::Application;

use strict;
use warnings;

our $VERSION = '0.04';

use Getopt::Long::Descriptive;
use Exception::Class::TryCatch;

use CLI::Framework::Exceptions qw( :all );
use CLI::Framework::Command;

# Certain built-in commands are required:
use constant REQUIRED_BUILTINS_PKGS => qw(
    CLI::Framework::Command::Help
);
use constant REQUIRED_BUILTINS_NAMES => qw(
    help
);
# Certain built-in commands are required only in interactive mode:
use constant REQUIRED_BUILTINS_PKGS_INTERACTIVE => qw(
    CLI::Framework::Command::Menu
);
use constant REQUIRED_BUILTINS_NAMES_INTERACTIVE => qw(
    menu
);

#FIXME-TODO-CLASS_GENERATION:
#sub import {
#    my ($class, $app_pkg, $app_def) = @_;
#
#    # If caller has supplied import args, CLIF's "inline form" is being used.
#    # The application class must be generated dynamically...
#
#}

#-------

sub new {
    my ($class, %args) = @_;

    my $interactive = $args{ interactive };             # boolean: interactive mode?

    my $cache = CLI::Framework::Cache->new();

    my $app = {
        _registered_command_objects => undef,           # (k,v)=(cmd pkg name,cmd obj) for all registered commands
        _default_command            => 'help',          # name of default command
        _current_command            => undef,           # name of current (or last) command to run
        _interactive                => $interactive,    # boolean: interactive state
        _cache                      => $cache,          # storage for data shared between app and cmd
        _initialized                => 0,               # initialization status
    };
    bless $app, $class;

    # Validate some hook methods so we can assume that they behave properly...
    $app->_validate_hooks();

    return $app;
}

sub _validate_hooks {
    my ($app) = @_;

    # Ensure that hook methods return expected data structure types according
    # to their preconditions...

    my $class = ref $app;

    # Ensure that command_map() succeeds...
    eval { $app->command_map() };
    if( catch my $e ) {
        throw_app_hook_exception( error =>
            "method 'command_map' in class '$class' fails" );
    }
    # Ensure that command_map() returns a "hash-worthy" list...
    else {
        eval { $app->_list_to_hashref( 'command_map' ) };
        if( catch my $e ) {
            $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
            throw_app_hook_exception( error => $e );
        }
    }
    # Ensure that command_alias() succeeds...
    eval { $app->command_alias() };
    if( catch my $e ) {
        throw_app_hook_exception(
            error   => "method 'command_alias' in class '$class' fails" );
    }
    # Ensure that commandf_alias() returns a "hash-worthy" list...
    else {
        eval { $app->_list_to_hashref( 'command_alias' ) };
        if( catch my $e ) {
            $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
            throw_app_hook_exception( error => $e );
        }
    }
}

sub cache { $_[0]->{_cache} }

###############################
#
#   COMMAND INTROSPECTION & REGISTRATION
#
###############################

# convert a list to a HASH ref if list is hash-worthy
sub _list_to_hashref {
    my ($app, $method) = @_;

    my $class = ref $app;
    my @map = $app->$method;

    # throw exception if command_map list is of odd length
    if( scalar @map % 2 ) {
        throw_app_hook_exception( error =>
            "odd-length list returned by application hook '$method' in class '$class' is not hash-worthy\n" );
    }
    my %h;
    for my $i (0..$#map-1) {
        if($i % 2 == 0) {
            my ($k,$v) = ( $map[$i], $map[$i+1] );
            # throw exception if command_map list-to-hash conversion would
            # lose data due to duplicate keys
            if( exists $h{$k} ) {
                throw_app_hook_exception( error =>
                    "list returned by application hook '$method' in class '$class' is not hash-worthy (duplicate keys for $i)\n" );
            }
            $h{ $map[$i] } = $map[$i+1];
        }
    }
    return \%h;
}

# Transform command map to hashref
sub command_map_hashref {
    my ($app) = @_;
    return $app->_list_to_hashref('command_map');
}

# Return names of all valid commands in same order as specified by
# command_map()
sub _valid_command_names {
    my ($app) = @_;

    # ordered pairs of (command name, command class)
    my @valid_command_name_class_pairs = $app->command_map();

    # unordered command names
    my @command_names = keys %{ { @valid_command_name_class_pairs } };

    my @ordered_command_names;
    for my $c (@valid_command_name_class_pairs) {
        push @ordered_command_names, $c
            if grep {$_ eq $c} @command_names;
    }
    return @ordered_command_names;
}

# Return package names for all valid commands
sub _valid_command_pkgs {
    my ($app) = @_;
    my $valid_commands_hashref = $app->command_map_hashref;
    return values %$valid_commands_hashref;
}

## Given a command name, return its package name
#sub _find_command_pkg_named {
#    my ($app, $cmd_name) = @_;
#
#    my $valid_commands_hashref = $app->command_map_hashref;
#    return $valid_commands_hashref->{$cmd_name};
#}

sub is_valid_command_pkg {
    my ($app, $cmd_pkg) = @_;
    return unless $cmd_pkg;

    my @valid_pkgs = ( $app->_valid_command_pkgs(), REQUIRED_BUILTINS_PKGS );
    push @valid_pkgs, REQUIRED_BUILTINS_PKGS_INTERACTIVE
        if $app->get_interactivity_mode();

    return grep { $cmd_pkg eq $_ } @valid_pkgs;
}

sub is_valid_command_name {
    my ($app, $cmd_name) = @_;
    return unless $cmd_name;

    my @valid_aliases = ( $app->_valid_command_names() );
    push @valid_aliases, REQUIRED_BUILTINS_NAMES;
    push @valid_aliases, REQUIRED_BUILTINS_NAMES_INTERACTIVE
        if $app->get_interactivity_mode();

    return grep { $cmd_name eq $_ } @valid_aliases;
}

sub registered_command_names {
    my ($app) = @_;

    my @names;

    # For each registered command package (name)...
    for my $cmd_pkg_name (keys %{ $app->{_registered_command_objects} }) {
        # Find command names that this command package was registered under...
        push @names, grep { $_ } map {
            $_ if $app->command_map_hashref->{$_} eq $cmd_pkg_name
        } $app->_valid_command_names
    }
    return @names;
}

sub registered_command_object {
    my ($app, $cmd_name) = @_;
    return unless $cmd_name;

    my $cmd_pkg = $app->command_map_hashref->{$cmd_name};

    return unless $cmd_pkg
        && exists $app->{_registered_command_objects}
        && exists $app->{_registered_command_objects}->{$cmd_pkg};

    return $app->{_registered_command_objects}->{$cmd_pkg};
}

sub register_command {
    my ($app, $cmd) = @_;
    return unless $cmd;

    if( ref $cmd && $app->is_valid_command_pkg(ref $cmd) ) {
        # Register by reference...
        return unless $cmd->isa( 'CLI::Framework::Command' );
        $app->{_registered_command_objects}->{ref $cmd} = $cmd;
    }
    elsif( $app->is_valid_command_pkg($app->command_map_hashref->{$cmd}) ) {
        # Register by command name...
        my $pkg = $app->command_map_hashref->{$cmd};
        $cmd = CLI::Framework::Command->manufacture( $pkg );
        $app->{_registered_command_objects}->{ref $cmd} = $cmd;
    }
#FIXME:use REQUIRED_BUILTINS_PKGS_INTERACTIVE & REQUIRED_BUILTINS_NAMES_INTERACTIVE
    elsif( $cmd eq 'help' ) {
        # Required built-in is always valid...
        $cmd = CLI::Framework::Command->manufacture( 'CLI::Framework::Command::Help' );
        $app->{_registered_command_objects}->{'CLI::Framework::Command::Help'} = $cmd;
    }
    elsif( $app->get_interactivity_mode() && $cmd eq 'menu' ) {
        # Required built-in for interactive usage is always valid...
        $cmd = CLI::Framework::Command->manufacture( 'CLI::Framework::Command::Menu' );
        $app->{_registered_command_objects}->{'CLI::Framework::Command::Menu'} = $cmd;
    }
    else {
        throw_cmd_registration_exception(
            error => "Error: failed attempt to register invalid command '$cmd'" );
    }
    # Metacommands should be app-aware...
    $cmd->set_app( $app ) if $cmd->isa( 'CLI::Framework::Command::Meta' );

    return $cmd;
}

sub get_default_command { $_[0]->{_default_command} }
sub set_default_command { $_[0]->{_default_command} = $_[1] }

sub get_current_command { $_[0]->{_current_command} }
sub set_current_command { $_[0]->{_current_command} = $_[1] }

sub get_default_usage { $_[0]->{_default_usage} }
sub set_default_usage { $_[0]->{_default_usage} = $_[1] }

###############################
#
#   PARSING & RUNNING COMMANDS
#
###############################

sub usage {
    my ($app, $command_name, @args) = @_;

    # Allow aliases in place of command name...
    $app->_canonicalize_cmd( $command_name );

    my $usage_text;
    if( $command_name && $app->is_valid_command_name($command_name) ) {
        # Get usage from Command object...
        my $cmd = $app->registered_command_object( $command_name )
            || $app->register_command( $command_name );
        $usage_text = $cmd->usage(@args);
    }
    else {
        # Get usage from Application object...
        $usage_text = $app->usage_text();
    }
    # Finally, fall back to default application usage message...
    $usage_text ||= $app->get_default_usage();

    return $usage_text;
}

sub _canonicalize_cmd {
    my ($self, $input) = @_;

    # Translate shorthand aliases for commands to full names...

    return unless $input;

    my $command_name;
        my %aliases = $self->command_alias();
        return unless %aliases;
        $command_name = $aliases{$input} || $input;
    $_[1] = $command_name;
}

sub _handle_global_app_options {
    my ($app) = @_;

    # Process the [app-opts] prefix of the command request...

    # preconditions:
    #   - tail of @ARGV has been parsed and removed, leaving only the
    #   [app-opts] portion of the request
    # postconditions:
    #   - application options have been parsed and any application-specific
    #     validation and initialization that is defined has been performed
    #   - invalid tokens after [app-opts] and before  are detected and
    #     handled

    # Parse [app-opts], consuming them from @ARGV...
    my ($app_options, $app_usage);
    eval { ($app_options, $app_usage) = describe_options( '%c %o ...', $app->option_spec ) };
    if( catch my $e ) { # (failed application options parsing)
        throw_app_opts_parse_exception( error => $e );
    }
    $app->set_default_usage( $app_usage->text );

    # Detect invalid tokens in the [app-opts] part of the request
    # (@ARGV should be empty unless such invalid tokens exist because  has
    # been removed and any valid options have been processed)...
    if( @ARGV ) {
        my $err = @ARGV > 1 ? 'Unrecognized options: ' : 'Unrecognized option: ';
        $err .= join(' ', @ARGV ) . "\n";
        throw_app_opts_parse_exception( error => $err );
    }
    # --- VALIDATE APP OPTIONS ---
    eval { $app->validate_options($app_options) };
    if( catch my $e ) { # (failed application options validation)
        $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
        throw_app_opts_validation_exception( error => $e . "\n" . $app->usage );
    }
    # --- INITIALIZE APP ---
    eval{ $app->init($app_options) };
    if( catch my $e ) { # (application failed initialization)
        $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
        throw_app_init_exception( error => $e );
    }
    $app->{_initialized} = 1;

    return 1;
}

sub _parse_request {
    my ($app, %param) = @_;

    # Parse options/arguments from a command request and set the name of the
    # current command...

    # If requested, perform validation and initialization of the application.
    # NOTE: Application validation/initialization should NOT be performed here
    # in interactive mode for each command request because it should only be
    # done once for the application, not every time a command is run.

    #~~~~~~~~~~~~~~~~~~~~~~~
    # ARGV_Format
    #
    # non-interactive case:     @ARGV:      [app-opts]   [cmd-opts] [cmd-args]
    # interactive case:         @ARGV:                   [cmd-opts] [cmd-args]
    #~~~~~~~~~~~~~~~~~~~~~~~

    my $initialize_app = $param{initialize};

    # Parse options/arguments for the application and the command from @ARGV...
    my ($command_name, @command_opts_and_args);
    for my $i ( 0..$#ARGV ) {
        # Find first valid command name in @ARGV...
        $app->_canonicalize_cmd( $ARGV[$i] );
        if( $app->is_valid_command_name($ARGV[$i]) ) {
            # Extract and store ' [cmd-opts] [cmd-args]', leaving
            # preceding contents (potentially '[app-opts]') in @ARGV...
            ($command_name, @command_opts_and_args) = @ARGV[$i..@ARGV-1];
            splice @ARGV, $i;
            last;
        }
    }
    unless( defined $command_name ) {
        # If no valid command, fall back to default, ignoring any args...
        $command_name = $app->get_default_command();
        @command_opts_and_args = ();

        # If no valid command then any non-option tokens are invalid args...
        my @invalid_args = grep { substr($_, 0, 1) ne '-' } @ARGV;
        if( @invalid_args ) {
            my $err = @invalid_args > 1 ? 'Invalid arguments: ' : 'Invalid argument: ';
            $err .= join(' ', @invalid_args );
            throw_invalid_cmd_exception( error => $err );
        }
    }
    # Set internal current command name...
    $app->set_current_command( $command_name );

    # If requested, parse [app-opts] and initialize application...
    # (this is an optional step because in interactive mode, it should not be
    # done for every request)
    $app->_handle_global_app_options() if $initialize_app;

    # Leave '[cmd-opts] [cmd-args]' in @ARGV...
    @ARGV = @command_opts_and_args;

    return 1;
}

sub run {
    my ($app, %param) = @_;

    # Auto-instantiate if necessary...
    unless( ref $app ) {
        my $class = $app;
        $app = $class->new();
    }
    # Determine whether to do initialization -- if not explicitly indicated,
    # default to doing initialization only if it has not yet been done...
    my $initialize = $param{initialize};
    $initialize = not $app->{_initialized} unless defined $initialize;

    # Parse request; perform initialization...
    eval { $app->_parse_request( initialize => $initialize ) };
    if( catch my $e ) { $app->handle_exception($e); return }

    my $command_name = $app->get_current_command();

    # Lazy registration of commands...
    my $command = $app->registered_command_object( $command_name )
        || $app->register_command( $command_name );

    # Parse command options and auto-generate minimal usage message...
    my ($cmd_options, $cmd_usage);
    my $currently_interactive = $app->get_interactivity_mode();
    my $format = "$command_name %o ...";                            # Getopt::Long::Descriptive format string
    $format = '%c '.$format unless $currently_interactive;          # (%c is command name -- irrelevant in interactive mode)

    # (configure Getopt::Long to stop consuming tokens when first non-option is
    # encountered on input stream)
    my $getopt_configuration = { getopt_conf => [qw(require_order)] };
    eval { ($cmd_options, $cmd_usage) =
        describe_options( $format, $command->option_spec, $getopt_configuration )
    };
    # (handle failed command options parsing)
    if( catch my $e ) {
        if( $e->isa('CLI::Framework::Exception') ) {
            $app->handle_exception($e);
            return;
        }
        eval{ throw_cmd_opts_parse_exception( error => $e ) };
        if( catch my $e ) { $app->handle_exception( $e ); return }
    }
    $command->set_default_usage( $cmd_usage->text );

    # Share session data with command...
    # (init() method may have populated shared session data in cache for use by all commands)
    $command->set_cache( $app->cache );

    # --- APP HOOK: COMMAND PRE-DISPATCH ---
    $app->pre_dispatch( $command );

    # --- RUN COMMAND ---
    my $output;
    eval { $output = $command->dispatch( $cmd_options, @ARGV ) };
    if( catch my $e ) { $app->handle_exception($e); return }

    # Display output of command, if any...
    $app->render( $output ) if defined $output;

    return 1;
}

###############################
#
#   INTERACTIVITY
#
###############################

sub get_interactivity_mode { $_[0]->{_interactive} }
sub set_interactivity_mode { $_[0]->{_interactive} = $_[1] }

sub is_interactive_command {
    my ($app, $command_name) = @_;

    my @noninteractive_commands = $app->noninteractive_commands();

    # Command must be valid...
    return 0 unless $app->is_valid_command_name( $command_name );

    # Command must NOT be non-interactive...
    return 1 unless grep { $command_name eq $_ } @noninteractive_commands;

    return 0;
}

sub get_interactive_commands {
    my ($app) = @_;

    my @valid_commands = $app->_valid_command_names;

    # All valid commands are enabled in non-interactive mode...
    return @valid_commands unless( $app->get_interactivity_mode() );

    # ...otherwise, in interactive mode, include only interactive commands...
    my @command_names;
    for my $c ( @valid_commands ) {
        push @command_names, $c if $app->is_interactive_command( $c );
    }
    return @command_names;
}

sub run_interactive {
    my ($app, %param) = @_;

    # Auto-instantiate if necessary...
    unless( ref $app ) {
        my $class = $app;
        $app = $class->new();
    }
    $app->set_interactivity_mode(1);

    # If default command is non-interactive, reset it, remembering default...
    my $orig_default_command = $app->get_default_command();
    if( grep { $orig_default_command eq $_ } $app->noninteractive_commands() ) {
        $app->set_default_command( 'help' );
    }
    # If initialization indicated, run init() and handle existing input...
    eval { $app->_parse_request( initialize => $param{initialize} )
        if $param{initialize}
    };
    if( catch my $e ) { $app->handle_exception($e); return }

    # Find how many prompts to display in sequence between displaying menu...
    my $menu_cmd = $app->registered_command_object('menu')
        || $app->register_command( 'menu' );
    $menu_cmd->isa( 'CLI::Framework::Command::Menu' )
        or throw_type_exception(
            error => "Menu command must be a subtype of " .
                     "CLI::Framework::Command::Menu" );

    my $invalid_request_threshold = $param{invalid_request_threshold}
        || $menu_cmd->line_count(); # num empty prompts b4 re-displaying menu

    $app->_run_cmd_processing_loop(
        menu_cmd                    => $menu_cmd,
        invalid_request_threshold   => $invalid_request_threshold
    );
    # Restore original default command...
    $app->set_default_command( $orig_default_command );
}

sub _run_cmd_processing_loop {
    my ($app, %param) = @_;

    my $menu_cmd                    = $param{menu_cmd};
    my $invalid_request_threshold   = $param{invalid_request_threshold};

    $app->render( $menu_cmd->run() );

    my ($cmd_succeeded, $invalid_request_count, $done) = (0,0,0);
    until( $done ) {
        if( $invalid_request_count >= $invalid_request_threshold ) {
            # Reached threshold for invalid cmd requests => re-display menu...
            $invalid_request_count = 0;
            $app->render( $menu_cmd->run() );
        }
        elsif( $cmd_succeeded ) {
            # Last command request was successful => re-display menu...
            $app->render( $menu_cmd->run() );
            $cmd_succeeded = $invalid_request_count = 0;
        }
        # Read a command request...
        $app->read_cmd();

        if( @ARGV ) {
            # Recognize quit requests...
            if( $app->is_quit_signal($ARGV[0]) ) {
                undef @ARGV;
                last;
            }
            $app->_canonicalize_cmd($ARGV[0]); # translate cmd aliases

            if( $app->is_interactive_command($ARGV[0]) ) {
                if( $app->run() ) {
                    $cmd_succeeded = 1;
                }
                else { $invalid_request_count++ }
            }
            else {
                $app->render( 'unrecognized command request: ' . join(' ',@ARGV) . "\n");
                $invalid_request_count++;
            }
        }
        else { $invalid_request_count++ }
    }
}

sub read_cmd {
    my ($app) = @_;

    require Text::ParseWords;

    # Retrieve or cache Term::ReadLine object (this is necessary to save
    # command-line history in persistent object)...
    my $term = $app->{_readline};
    unless( $term ) {
        require Term::ReadLine;
        $term = Term::ReadLine->new('CLIF Application');
        select $term->OUT;
        $app->{_readline} = $term;

#FIXME-TODO-CMDLINE_COMPLETION:
#        # Arrange for command-line completion...
#        my $attribs = $term->Attribs;
#        $attribs->{completion_function} = $app->_cmd_request_completions();
    }
    # Prompt for the name of a command and read input from STDIN.
    # Store the individual tokens that are read in @ARGV.
    my $command_request = $term->readline('> ');
    if(! defined $command_request ) {
        # Interpret CTRL-D (EOF) as a quit signal...
        @ARGV = $app->quit_signals();
        print "\n"; # since EOF character is rendered as ''
    }
    else {
        # Prepare command for usual parsing...
        @ARGV = Text::ParseWords::shellwords( $command_request );
        $term->addhistory($command_request)
            if $command_request =~ /\S/ and !$term->Features->{autohistory};
    }
    return 1;
}

##FIXME-TODO-CMDLINE_COMPLETION:this should only return interactive commands; it should pay attention
##to its text/line/start args, ...; also: make it work with subcommands
##  --see Term::Readline::Gnu
#sub _cmd_request_completions {
#    my ($app) = @_;
#    return sub {
#        my ($text, $line, $start) = @_;
#        return $app->_valid_command_names;
#    }
#}

sub is_quit_signal {
    my ($app, $command_name) = @_;

    my @quit_signals = $app->quit_signals();
    return grep { $command_name eq  $_ } @quit_signals;
}

###############################
#
#   APPLICATION SUBCLASS HOOKS
#
###############################

#XXX-CONSIDER: consider making default implementation of init():
#       $app->set_current_command('help') if $opts->{help}
sub init { 1 }

sub pre_dispatch { }

sub usage_text { }

sub option_spec { }

sub validate_options { 1 }

sub command_map {
    help        => 'CLI::Framework::Command::Help',
    console     => 'CLI::Framework::Command::Console',
    menu        => 'CLI::Framework::Command::Menu',
    list        => 'CLI::Framework::Command::List',
    'dump'      => 'CLI::Framework::Command::Dump',
    tree        => 'CLI::Framework::Command::Tree',
    alias       => 'CLI::Framework::Command::Alias',
}

sub command_alias { }

sub noninteractive_commands { qw( console menu ) }

sub quit_signals { qw( q quit exit ) }

sub handle_exception {
    my ($app, $e) = @_;
    $app->render( $e->description . "\n\n" . $e->error );
    return;
}

sub render {
    my ($app, $output) = @_;

#XXX-CONSIDER: consider built-in features to help simplify associating templates
#with commands (each command would probably have its own template for its
#output)
    print $output;
}

###############################
#
#   CACHING
#
###############################

package CLI::Framework::Cache;

use strict;
use warnings;

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

    bless { _cache => { } }, $class;
}

sub get {
    my ($self, $k) = @_;

    my $v = $self->{_cache}->{$k};
    return $v;
}

sub set {
    my ($self, $k, $v) = @_;

    $self->{_cache}->{$k} = $v;
    return $v;
}

#-------
1;

__END__