File Coverage

lib/CLI/Dispatch.pm

Criterion	Covered	Total	%
statement	95	104	91.3
branch	28	36	77.7
condition	6	10	60.0
subroutine	19	21	90.4
pod	9	9	100.0
total	157	180	87.2

package CLI::Dispatch;

use strict;
use warnings;
use Carp;
use Getopt::Long ();
use String::CamelCase;
use Try::Tiny;

our $VERSION = '0.21';

# you may want to override these three methods.

sub options {qw( help|h|? verbose|v debug logfilter=s )}

sub default_command { 'help' }

sub get_command {
  my $self = shift;

  my $command = shift @ARGV || $self->default_command;
  return $self->convert_command($command);
}

sub convert_command {
  my ($self, $command) = @_;

  $command = String::CamelCase::camelize( $command );
  $command =~ tr/a-zA-Z0-9_//cd;
  return $command;
}

# you usually don't need to care below.

sub new {
  my ($class, %opts) = @_;
  bless \%opts, $class;
}

sub get_options {
  my ($self, @specs) = @_;

  my $parser = Getopt::Long::Parser->new(
    config => [qw( bundling ignore_case pass_through )]
  );

  $parser->getoptions( \my %hash => @specs );

  return %hash;
}

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

  my $command = $self->get_command;

  if ( $help ) {
    unshift @ARGV, $command;
    $command = 'Help';
  }

  my $instance = $self->_load_command($namespaces, $command);
  return $instance if $instance;

  # fallback to help (maybe the command is just a pod)
  unshift @ARGV, $command;
  $instance = $self->_load_command($namespaces, 'Help');
  return $instance if $instance;

  # this shouldn't happen
  print STDERR "Help command is missing or broken.\n";
  print STDERR "Prerequisite modules may not be installed.\n";
  print STDERR "Please check your installation.\n";
  exit;
}

sub _load_command {
  my ($self, $namespaces, $command) = @_;

  foreach my $namespace (@$namespaces) {
    my $package = $namespace.'::'.$command;
    return $package->new if $package->can('new');

    my $error;
    try   { eval "require $package" or die }
    catch { $error = $_ || 'Obscure error' };
    return $package->new unless $error;

    my $file = _package_file($package);
    next if $error =~ /Can't locate $file/;
    croak $error;
  }

  if ($command eq 'Help') {
    require CLI::Dispatch::Help;
    return CLI::Dispatch::Help->new;
  }
  return;
}

sub _package_file {
  my $package = shift;

  $package =~ s{::}{/}g;
  $package .= '\.(?:pm|pod)';
  $package;
}

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

  my $class;
  unless ($class = ref $self) {
    $class = $self;
    $self = $self->new;
  }

  if (!grep { $_ ne $class } @namespaces) {
    push @namespaces, $class;
  }

  my %global  = $self->get_options( $self->options );
  my $command = $self->load_command( \@namespaces, $global{help} );
  my %local   = $self->get_options( $command->options );

  $command->set_options( %$self, %global, %local, _namespaces => \@namespaces );

  if ( $command->isa('CLI::Dispatch::Help') and @ARGV ) {
    $ARGV[0] = $self->convert_command($ARGV[0]);
  }

  $command->check if $command->can('check');

  $command->run(@ARGV);
}

sub run_directly {
  my ($self, $package) = @_;

  unless ($package->can('new')) {
    my $error;
    try   { eval "require $package" or die }
    catch { $error = $_ || 'Obscure error' };
    croak $error if $error;
  }

  my $class;
  unless ($class = ref $self) {
    $class = $self;
    $self = $self->new;
  }

  my %global  = $self->get_options( $self->options );
  my $command = $package->new;
  if ($global{help}) {
    require CLI::Dispatch::Help;
    $command = CLI::Dispatch::Help->new;
    unshift @ARGV, "+$package";
  }
  my %local   = $self->get_options( $command->options );

  $command->set_options( %global, %local );

  $command->check if $command->can('check');

  $command->run(@ARGV);
}

1;

__END__