view release on metacpan or  search on metacpan

lib/App/Cmd.pm  view on Meta::CPAN

#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<App::Cmd::Tutorial>.
#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<no_commands_plugin> is not given, L<App::Cmd::Command::commands> 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<no_help_plugin> is not given, L<App::Cmd::Command::help> will be required,
#pod and it will be registered to handle all of its command names not handled by
#pod other plugins. B<Note:> "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<default_command> method.
#pod
#pod If C<no_version_plugin> is not given, L<App::Cmd::Command::version> 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<show_version_cmd> 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 = {
    command      => $class->_command($arg),
    arg0         => $base,
    full_arg0    => $arg0,
    show_version => $arg->{show_version_cmd} || 0,
  };

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

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