App::Cmd - write command line apps with less suffering

  use YourApp;
  YourApp->run;

  package YourApp;
  use App::Cmd::Setup -app;
  1;

  package YourApp::Command::blort;
  use YourApp -command;
  use strict; use warnings;

  sub opt_spec {
    return (
      [ "blortex|X",  "use the blortex algorithm" ],
      [ "recheck|r",  "recheck all results"       ],
    );
  }

  sub validate_args {
    my ($self, $opt, $args) = @_;

    # no args allowed but options!
    $self->usage_error("No args allowed") if @$args;
  }

  sub execute {
    my ($self, $opt, $args) = @_;

    my $result = $opt->{blortex} ? blortex() : blort();

    recheck($result) if $opt->{recheck};

    print $result;
  }

  knight!rjbs$ yourcmd blort --recheck

  All blorts successful.

  my $cmd = App::Cmd->new(\%arg);

  no_commands_plugin - if true, the command list plugin is not added

  no_help_plugin     - if true, the help plugin is not added

  plugin_search_path - The path to search for commands in. Defaults to
                       results of plugin_search_path method

  $cmd->run;

  my $program_name = $app->arg0;

  my $full_program_name = $app->full_arg0;

  knight!rjbs$ ~/bin/rpg dice 3d6

  arg0      - rpg
  full_arg0 - /Users/rjbs/bin/rpg

  my ($cmd, $opt, @args) = $app->prepare_command(@ARGV);

  $app->execute_command($cmd, \%opt, @args);

  use constant plugin_search_path => __PACKAGE__;

  reticulate
  reload
  rasterize

  if ($cmd->app->global_options->{verbose}) { ... }

  $app->set_global_options(\%opt);

  my @names = $cmd->command_names;

  my @plugins = $cmd->command_plugins;

  my $plugin = $cmd->plugin_for($command);

  my ($command_name, $opt, @args) = $app->get_command(@args);

  print $self->app->usage->text;

  "yourapp [options] <command>"

  $self->usage_error("Something's wrong!");

use strict;
use warnings;
use 5.006;

package App::Cmd;
BEGIN {
  $App::Cmd::VERSION = '0.311';
}
use App::Cmd::ArgProcessor;
BEGIN { our @ISA = 'App::Cmd::ArgProcessor' };
# ABSTRACT: write command line apps with less suffering

use File::Basename ();
use Module::Pluggable::Object ();
use Text::Abbrev ();
use Class::Load ();

use Sub::Exporter -setup => {
  collectors => {
    -command => \'_setup_command',
    -run     => sub {
      warn "using -run to run your command is deprecated\n";
      $_[1]->{class}->run; 1
    },
  },
};

sub _setup_command {
  my ($self, $val, $data) = @_;
  my $into = $data->{into};

  Carp::confess "App::Cmd -command setup requested for already-setup class"
    if $into->isa('App::Cmd::Command');

  {
    my $base = $self->_default_command_base;
    Class::Load::load_class($base);
    no strict 'refs';
    push @{"$into\::ISA"}, $base;
  }

  $self->_register_command($into);

  for my $plugin ($self->_plugin_plugins) {
    $plugin->import_from_plugin({ into => $into });
  }

  1;
}

sub _plugin_plugins { return }


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

  my $arg0 = $0;
  my $base = File::Basename::basename $arg0;

  my $self = {
    command   => $class->_command($arg),
    arg0      => $base,
    full_arg0 => $arg0,
  };

  bless $self => $class;
}

# effectively, returns the command-to-plugin mapping guts of a Cmd
# if called on a class or on a Cmd with no mapping, construct a new hashref
# suitable for use as the object's mapping
sub _command {
  my ($self, $arg) = @_;
  return $self->{command} if ref $self and $self->{command};

  # TODO _default_command_base can be wrong if people are not using
  # ::Setup and have no ::Command :(
  #
  #  my $want_isa = $self->_default_command_base;
  # -- kentnl, 2010-12
   my $want_isa = 'App::Cmd::Command';

  my %plugin;
  for my $plugin ($self->_plugins) {
    Class::Load::load_class($plugin);

    die "$plugin is not a " . $want_isa
      unless $plugin->isa($want_isa);

    next unless $plugin->can("command_names");

    foreach my $command (map { lc } $plugin->command_names) {
      die "two plugins for command $command: $plugin and $plugin{$command}\n"
        if exists $plugin{$command};

      $plugin{$command} = $plugin;
    }
  }

  $self->_load_default_plugin($_, $arg, \%plugin) for qw(commands help);

  if ($self->allow_any_unambiguous_abbrev) {
    # add abbreviations to list of authorized commands
    my %abbrev = Text::Abbrev::abbrev( keys %plugin );
    @plugin{ keys %abbrev } = @plugin{ values %abbrev };
  }

  return \%plugin;
}

# ->_plugins won't be called more than once on any given App::Cmd, but since
# finding plugins can be a bit expensive, we'll do a lousy cache here.
# -- rjbs, 2007-10-09
my %plugins_for;
sub _plugins {
  my ($self) = @_;
  my $class = ref $self || $self;

  return @{ $plugins_for{$class} } if $plugins_for{$class};

  my $finder = Module::Pluggable::Object->new(
    search_path => $self->plugin_search_path,
    $self->_module_pluggable_options,
  );

  my @plugins = $finder->plugins;
  $plugins_for{$class} = \@plugins;

  return @plugins;
}

sub _register_command {
  my ($self, $cmd_class) = @_;
  $self->_plugins;

  my $class = ref $self || $self;
  push @{ $plugins_for{ $class } }, $cmd_class
    unless grep { $_ eq $cmd_class } @{ $plugins_for{ $class } };
}

sub _module_pluggable_options {
  # my ($self) = @_; # no point in creating these ops, just to toss $self
  return;
}

# load one of the stock plugins, unless requested to squash; unlike normal
# plugin loading, command-to-plugin mapping conflicts are silently ignored
sub _load_default_plugin {
  my ($self, $plugin_name, $arg, $plugin_href) = @_;
  unless ($arg->{"no_$plugin_name\_plugin"}) {
    my $plugin = "App::Cmd::Command::$plugin_name";
    Class::Load::load_class($plugin);
    for my $command (map { lc } $plugin->command_names) {
      $plugin_href->{$command} ||= $plugin;
    }
  }
}


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

  # We should probably use Class::Default.
  $self = $self->new unless ref $self;

  # prepare the command we're going to run...
  my ($cmd, $opt, @args) = $self->prepare_command(@ARGV);

  # ...and then run it
  $self->execute_command($cmd, $opt, @args);
}


sub arg0      { $_[0]->{arg0} }
sub full_arg0 { $_[0]->{full_arg0} }


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

  # figure out first-level dispatch
  my ($command, $opt, @sub_args) = $self->get_command(@args);

  # set up the global options (which we just determined)
  $self->set_global_options($opt);

  # find its plugin or else call default plugin (default default is help)
  if ($command) {
    $self->_prepare_command($command, $opt, @sub_args);
  } else {
    $self->_prepare_default_command($opt, @sub_args);
  }
}

sub _prepare_command {
  my ($self, $command, $opt, @args) = @_;
  if (my $plugin = $self->plugin_for($command)) {
    return $plugin->prepare($self, @args);
  } else {
    return $self->_bad_command($command, $opt, @args);
  }
}

sub _prepare_default_command {
  my ($self, $opt, @sub_args) = @_;
  $self->_prepare_command($self->default_command, $opt, @sub_args);
}

sub _bad_command {
  my ($self, $command, $opt, @args) = @_;
  print "Unrecognized command: $command.\n\nUsage:\n" if defined($command);

  # This should be class data so that, in Bizarro World, two App::Cmds will not
  # conflict.
  our $_bad++;
  $self->prepare_command("commands");
}

END { exit 1 if our $_bad };


sub default_command { "help" }


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

  local our $active_cmd = $cmd;

  $cmd->validate_args($opt, \@args);
  $cmd->execute($opt, \@args);
}


sub _default_command_base {
  my ($self) = @_;
  my $class = ref $self || $self;
  return "$class\::Command";
}

sub _default_plugin_base {
  my ($self) = @_;
  my $class = ref $self || $self;
  return "$class\::Plugin";
}

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

  my $dcb = $self->_default_command_base;
  my $ccb = $dcb eq 'App::Cmd::Command'
          ? $self->App::Cmd::_default_command_base
          : $self->_default_command_base;

  my @default = ($ccb, $self->_default_plugin_base);

  if (ref $self) {
    return $self->{plugin_search_path} ||= \@default;
  } else {
    return \@default;
  }
}


sub allow_any_unambiguous_abbrev { return 0 }


sub global_options {
	my $self = shift;
	return $self->{global_options} ||= {} if ref $self;
  return {};
}


sub set_global_options {
  my ($self, $opt) = @_;
  return $self->{global_options} = $opt;
}


sub command_names {
  my ($self) = @_;
  keys %{ $self->_command };
}


sub command_plugins {
  my ($self) = @_;
  my %seen = map {; $_ => 1 } values %{ $self->_command };
  keys %seen;
}


sub plugin_for {
  my ($self, $command) = @_;
  return unless exists $self->_command->{ $command };

  return $self->_command->{ $command };
}


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

  my ($opt, $args, %fields)
    = $self->_process_args(\@args, $self->_global_option_processing_params);

  my ($command, $rest) = $self->_cmd_from_args($args);

  $self->{usage} = $fields{usage};

  return ($command, $opt, @$rest);
}

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

  my $command = shift @$args;
  return ($command, $args);
}

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

  return (
    $self->usage_desc(@args),
    $self->global_opt_spec(@args),
    { getopt_conf => [qw/pass_through/] },
  );
}


sub usage { $_[0]{usage} };


sub usage_desc {
  # my ($self) = @_; # no point in creating these ops, just to toss $self
  return "%c %o <command>";
}


sub global_opt_spec {
  # my ($self) = @_; # no point in creating these ops, just to toss $self
  return;
}


sub usage_error {
  my ($self, $error) = @_;
  die "Error: $error\nUsage: " . $self->_usage_text;
}

sub _usage_text {
  my ($self) = @_;
  my $text = $self->usage->text;
  $text =~ s/\A(\s+)/!/;
  return $text;
}


1;

__END__