File Coverage

blib/lib/App/Cmd.pm

Criterion	Covered	Total	%
statement	185	195	94.8
branch	35	52	67.3
condition	16	30	53.3
subroutine	48	50	96.0
pod	21	22	95.4
total	305	349	87.3

# The "experimental" below is not actually scary.  The feature went on to be
# de-experimental-ized with no changes and is now on by default in perl v5.24
# and later. -- rjbs, 2021-03-14
use 5.020;
use warnings;
use experimental qw(postderef postderef_qq);

package App::Cmd 0.334;

use parent 'App::Cmd::ArgProcessor';
# ABSTRACT: write command line apps with less suffering

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

use Sub::Exporter -setup => {
  collectors => {
    -ignore  => \'_setup_ignore',
    -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 _setup_ignore {
  my ($self, $val, $data) = @_;
  my $into = $data->{into};

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

  $self->_register_ignore($into);

  1;
}

sub _plugin_plugins { return }

#pod =head1 SYNOPSIS
#pod
#pod in F:
#pod
#pod   use YourApp;
#pod   YourApp->run;
#pod
#pod in F:
#pod
#pod   package YourApp;
#pod   use App::Cmd::Setup -app;
#pod   1;
#pod
#pod in F:
#pod
#pod   package YourApp::Command::blort;
#pod   use YourApp -command;
#pod   use strict; use warnings;
#pod
#pod   sub abstract { "blortex algorithm" }
#pod
#pod   sub description { "Long description on blortex algorithm" }
#pod
#pod   sub opt_spec {
#pod     return (
#pod       [ "blortex|X",  "use the blortex algorithm" ],
#pod       [ "recheck|r",  "recheck all results"       ],
#pod     );
#pod   }
#pod
#pod   sub validate_args {
#pod     my ($self, $opt, $args) = @_;
#pod
#pod     # no args allowed but options!
#pod     $self->usage_error("No args allowed") if @$args;
#pod   }
#pod
#pod   sub execute {
#pod     my ($self, $opt, $args) = @_;
#pod
#pod     my $result = $opt->{blortex} ? blortex() : blort();
#pod
#pod     recheck($result) if $opt->{recheck};
#pod
#pod     print $result;
#pod   }
#pod
#pod and, finally, at the command line:
#pod
#pod   knight!rjbs$ yourcmd blort --recheck
#pod
#pod   All blorts successful.
#pod
#pod =head1 DESCRIPTION
#pod
#pod App::Cmd is intended to make it easy to write complex command-line applications
#pod without having to think about most of the annoying things usually involved.
#pod
#pod For information on how to start using App::Cmd, see L.
#pod
#pod =method new
#pod
#pod   my $cmd = App::Cmd->new(\%arg);
#pod
#pod This method returns a new App::Cmd object.  During initialization, command
#pod plugins will be loaded.
#pod
#pod Valid arguments are:
#pod
#pod   no_commands_plugin - if true, the command list plugin is not added
#pod
#pod   no_help_plugin     - if true, the help plugin is not added
#pod
#pod   no_version_plugin  - if true, the version plugin is not added
#pod
#pod   show_version_cmd -   if true, the version command will be shown in the
#pod                        command list
#pod
#pod   plugin_search_path - The path to search for commands in. Defaults to
#pod                        results of plugin_search_path method
#pod
#pod If C is not given, L will be
#pod required, and it will be registered to handle all of its command names not
#pod handled by other plugins.
#pod
#pod If C is not given, L will be required,
#pod and it will be registered to handle all of its command names not handled by
#pod other plugins. B "help" is the default command, so if you do not load
#pod the default help plugin, you should provide your own or override the
#pod C method.
#pod
#pod If C is not given, L will be
#pod required to show the application's version with command C<--version>. By
#pod default, the version command is not included in the command list. Pass
#pod C to include the version command in the list.
#pod
#pod =cut

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

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

  my $self = {
    arg0         => $base,
    full_arg0    => $arg0,
    show_version => $arg->{show_version_cmd} // 0,
  };

  bless $self, $class;

  $self->{command} = $self->_command($arg);

  return $self;
}

# 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);

    # relies on either the plugin itself registering as ignored
    # during compile ( use MyApp::Cmd -ignore )
    # or being explicitly registered elsewhere ( blacklisted )
    # via $app_cmd->_register_ignore( $class )
    #  -- kentnl, 2011-09
    next if $self->should_ignore( $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 version);

  if ($self->allow_any_unambiguous_abbrev) {
    # add abbreviations to list of authorized commands
    require Text::Abbrev;
    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 }->@*;
}

my %ignored_for;

sub should_ignore {
  my ($self, $cmd_class) = @_;
  my $class = ref $self || $self;
  for ($ignored_for{ $class }->@*) {
    return 1 if $_ eq $cmd_class;
  }
  return;
}

sub _register_ignore {
  my ($self, $cmd_class) = @_;
  my $class = ref $self || $self;
  push $ignored_for{ $class }->@*, $cmd_class
    unless grep { $_ eq $cmd_class } $ignored_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;
    }
  }
}

#pod =method run
#pod
#pod   $cmd->run;
#pod
#pod This method runs the application.  If called the class, it will instantiate a
#pod new App::Cmd object to run.
#pod
#pod It determines the requested command (generally by consuming the first
#pod command-line argument), finds the plugin to handle that command, parses the
#pod remaining arguments according to that plugin's rules, and runs the plugin.
#pod
#pod It passes the contents of the global argument array (C<@ARGV>) to
#pod L>, but C<@ARGV> is not altered by running an App::Cmd.
#pod
#pod =cut

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 @argv = $self->prepare_args();
  my ($cmd, $opt, @args) = $self->prepare_command(@argv);

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

#pod =method prepare_args
#pod
#pod Normally App::Cmd uses C<@ARGV> for its commandline arguments. You can override
#pod this method to change that behavior for testing or otherwise.
#pod
#pod =cut

sub prepare_args {
  my ($self) = @_;
  return scalar(@ARGV)
    ? (@ARGV)
    : ($self->default_args->@*);
}

#pod =method default_args
#pod
#pod If C> is not changed and there are no arguments in C<@ARGV>,
#pod this method is called and should return an arrayref to be used as the arguments
#pod to the program.  By default, it returns an empty arrayref.
#pod
#pod =cut

use constant default_args => [];

#pod =method abstract
#pod
#pod    sub abstract { "command description" }
#pod
#pod Defines the command abstract: a short description that will be printed in the
#pod main command options list.
#pod
#pod =method description
#pod
#pod    sub description { "Long description" }
#pod
#pod Defines a longer command description that will be shown when the user asks for
#pod help on a specific command.
#pod
#pod =method arg0
#pod
#pod =method full_arg0
#pod
#pod   my $program_name = $app->arg0;
#pod
#pod   my $full_program_name = $app->full_arg0;
#pod
#pod These methods return the name of the program invoked to run this application.
#pod This is determined by inspecting C<$0> when the App::Cmd object is
#pod instantiated, so it's probably correct, but doing weird things with App::Cmd
#pod could lead to weird values from these methods.
#pod
#pod If the program was run like this:
#pod
#pod   knight!rjbs$ ~/bin/rpg dice 3d6
#pod
#pod Then the methods return:
#pod
#pod   arg0      - rpg
#pod   full_arg0 - /Users/rjbs/bin/rpg
#pod
#pod These values are captured when the App::Cmd object is created, so it is safe to
#pod assign to C<$0> later.
#pod
#pod =cut

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

#pod =method prepare_command
#pod
#pod   my ($cmd, $opt, @args) = $app->prepare_command(@ARGV);
#pod
#pod This method will load the plugin for the requested command, use its options to
#pod parse the command line arguments, and eventually return everything necessary to
#pod actually execute the command.
#pod
#pod =cut

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(qw(commands --stderr));
}

END { exit 1 if our $_bad };

#pod =method default_command
#pod
#pod This method returns the name of the command to run if none is given on the
#pod command line.  The default default is "help"
#pod
#pod =cut

sub default_command { "help" }

#pod =method execute_command
#pod
#pod   $app->execute_command($cmd, \%opt, @args);
#pod
#pod This method will invoke C and then C on C<$cmd>.
#pod
#pod =cut

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

  local our $active_cmd = $cmd;

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

#pod =method plugin_search_path
#pod
#pod This method returns the plugin_search_path as set.  The default implementation,
#pod if called on "YourApp::Cmd" will return "YourApp::Cmd::Command"
#pod
#pod This is a method because it's fun to override it with, for example:
#pod
#pod   use constant plugin_search_path => __PACKAGE__;
#pod
#pod =cut

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;
  }
}

#pod =method allow_any_unambiguous_abbrev
#pod
#pod If this method returns true (which, by default, it does I), then any
#pod unambiguous abbreviation for a registered command name will be allowed as a
#pod means to use that command.  For example, given the following commands:
#pod
#pod   reticulate
#pod   reload
#pod   rasterize
#pod
#pod Then the user could use C for C or C for C and
#pod so on.
#pod
#pod =cut

sub allow_any_unambiguous_abbrev { return 0 }

#pod =method global_options
#pod
#pod   if ($cmd->app->global_options->{verbose}) { ... }
#pod
#pod This method returns the running application's global options as a hashref.  If
#pod there are no options specified, an empty hashref is returned.
#pod
#pod =cut

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

#pod =method set_global_options
#pod
#pod   $app->set_global_options(\%opt);
#pod
#pod This method sets the global options.
#pod
#pod =cut

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

#pod =method command_names
#pod
#pod   my @names = $cmd->command_names;
#pod
#pod This returns the commands names which the App::Cmd object will handle.
#pod
#pod =cut

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

#pod =method command_groups
#pod
#pod   my @groups = $cmd->commands_groups;
#pod
#pod This method can be implemented to return a grouped list of command names with
#pod optional headers. Each group is given as arrayref and each header as string.
#pod If an empty list is returned, the commands plugin will show two groups without
#pod headers: the first group is for the "help" and "commands" commands, and all
#pod other commands are in the second group.
#pod
#pod =cut

sub command_groups { }

#pod =method command_plugins
#pod
#pod   my @plugins = $cmd->command_plugins;
#pod
#pod This method returns the package names of the plugins that implement the
#pod App::Cmd object's commands.
#pod
#pod =cut

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

#pod =method plugin_for
#pod
#pod   my $plugin = $cmd->plugin_for($command);
#pod
#pod This method returns the plugin (module) for the given command.  If no plugin
#pod implements the command, it returns false.
#pod
#pod =cut

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

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

#pod =method get_command
#pod
#pod   my ($command_name, $opt, @args) = $app->get_command(@args);
#pod
#pod Process arguments and into a command name and (optional) global options.
#pod
#pod =cut

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

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

  # map --help to help command
  if ($opt->{help}) {
      unshift @$args, 'help';
      delete $opt->{help};
  }

  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/] },
  );
}

#pod =method usage
#pod
#pod   print $self->app->usage->text;
#pod
#pod Returns the usage object for the global options.
#pod
#pod =cut

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

#pod =method usage_desc
#pod
#pod The top level usage line. Looks something like
#pod
#pod   "yourapp  [options]"
#pod
#pod =cut

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

#pod =method global_opt_spec
#pod
#pod Returns a list with help command unless C has been specified or
#pod an empty list. Can be overridden for pre-dispatch option processing.  This is
#pod useful for flags like --verbose.
#pod
#pod =cut

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

  my $cmd = $self->{command};
  my %seen;
  my @help = grep { ! $seen{$_}++ }
             reverse sort map { s/^--?//; $_ }
             grep { $cmd->{$_} eq 'App::Cmd::Command::help' } keys %$cmd;

  return (@help ? [ join('|', @help) => "show help" ] : ());
}

#pod =method usage_error
#pod
#pod   $self->usage_error("Something's wrong!");
#pod
#pod Used to die with nice usage output, during C.
#pod
#pod =cut

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;
}

#pod =head1 TODO
#pod
#pod =for :list
#pod * publish and bring in Log::Speak (simple quiet/verbose output)
#pod * publish and use our internal enhanced describe_options
#pod * publish and use our improved simple input routines
#pod
#pod =cut

1;

__END__