File Coverage

blib/lib/App/Cmd/Command.pm

Criterion	Covered	Total	%
statement	73	75	97.3
branch	14	24	58.3
condition	7	8	87.5
subroutine	20	20	100.0
pod	12	12	100.0
total	126	139	90.6

use strict;
use warnings;

package App::Cmd::Command 0.334;

use App::Cmd::ArgProcessor;
BEGIN { our @ISA = 'App::Cmd::ArgProcessor' };

# ABSTRACT: a base class for App::Cmd commands

use Carp ();

#pod =method prepare
#pod
#pod   my ($cmd, $opt, $args) = $class->prepare($app, @args);
#pod
#pod This method is the primary way in which App::Cmd::Command objects are built.
#pod Given the remaining command line arguments meant for the command, it returns
#pod the Command object, parsed options (as a hashref), and remaining arguments (as
#pod an arrayref).
#pod
#pod In the usage above, C<$app> is the App::Cmd object that is invoking the
#pod command.
#pod
#pod =cut

sub prepare {
  my ($class, $app, @args) = @_;

  my ($opt, $args, %fields)
    = $class->_process_args(\@args, $class->_option_processing_params($app));

  return (
    $class->new({ app => $app, %fields }),
    $opt,
    @$args,
  );
}

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

  return (
    $class->usage_desc(@args),
    $class->opt_spec(@args),
  );
}

#pod =method new
#pod
#pod This returns a new instance of the command plugin.  Probably only C
#pod should use this.
#pod
#pod =cut

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

#pod =method execute
#pod
#pod   $command_plugin->execute(\%opt, \@args);
#pod
#pod This method does whatever it is the command should do!  It is passed a hash
#pod reference of the parsed command-line options and an array reference of left
#pod over arguments.
#pod
#pod If no C method is defined, it will try to call C -- but it will
#pod warn about this behavior during testing, to remind you to fix the method name!
#pod
#pod =cut

sub execute {
  my $class = shift;

  if (my $run = $class->can('run')) {
    warn "App::Cmd::Command subclasses should implement ->execute not ->run"
      if $ENV{HARNESS_ACTIVE};

    return $class->$run(@_);
  }

  Carp::croak ref($class) . " does not implement mandatory method 'execute'\n";
}

#pod =method app
#pod
#pod This method returns the App::Cmd object into which this command is plugged.
#pod
#pod =cut

sub app { $_[0]->{app}; }

#pod =method usage
#pod
#pod This method returns the usage object for this command.  (See
#pod L).
#pod
#pod =cut

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

#pod =method command_names
#pod
#pod This method returns a list of command names handled by this plugin. The
#pod first item returned is the 'canonical' name of the command.
#pod
#pod If this method is not overridden by an App::Cmd::Command subclass, it will
#pod return the last part of the plugin's package name, converted to lowercase.
#pod For example, YourApp::Cmd::Command::Init will, by default, handle the command
#pod "init".
#pod
#pod Subclasses should generally get the superclass value of C
#pod and then append aliases.
#pod
#pod =cut

sub command_names {
  # from UNIVERSAL::moniker
  (ref( $_[0] ) || $_[0]) =~ /([^:]+)$/;
  return lc $1;
}

#pod =method usage_desc
#pod
#pod This method should be overridden to provide a usage string.  (This is the first
#pod argument passed to C from Getopt::Long::Descriptive.)
#pod
#pod If not overridden, it returns "%c COMMAND %o";  COMMAND is the first item in
#pod the result of the C method.
#pod
#pod =cut

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

  my ($command) = $self->command_names;
  return "%c $command %o"
}

#pod =method opt_spec
#pod
#pod This method should be overridden to provide option specifications.  (This is
#pod list of arguments passed to C from Getopt::Long::Descriptive,
#pod after the first.)
#pod
#pod If not overridden, it returns an empty list.
#pod
#pod =cut

sub opt_spec {
  return;
}

#pod =method validate_args
#pod
#pod   $command_plugin->validate_args(\%opt, \@args);
#pod
#pod This method is passed a hashref of command line options (as processed by
#pod Getopt::Long::Descriptive) and an arrayref of leftover arguments.  It may throw
#pod an exception (preferably by calling C, below) if they are invalid,
#pod or it may do nothing to allow processing to continue.
#pod
#pod =cut

sub validate_args { }

#pod =method usage_error
#pod
#pod   $self->usage_error("This command must not be run by root!");
#pod
#pod This method should be called to die with human-friendly usage output, during
#pod C.
#pod
#pod =cut

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

sub _usage_text {
  my ($self) = @_;
  local $@;
  join "\n", eval { $self->app->_usage_text }, eval { $self->usage->text };
}

#pod =method abstract
#pod
#pod This method returns a short description of the command's purpose.  If this
#pod method is not overridden, it will return the abstract from the module's Pod.
#pod If it can't find the abstract, it will look for a comment starting with
#pod "ABSTRACT:" like the ones used by L.
#pod
#pod =cut

# stolen from ExtUtils::MakeMaker
sub abstract {
  my ($class) = @_;
  $class = ref $class if ref $class;

  my $result;
  my $weaver_abstract;

  # classname to filename
  (my $pm_file = $class) =~ s!::!/!g;
  $pm_file .= '.pm';
  $pm_file = $INC{$pm_file} or return "(unknown)";

  # if the pm file exists, open it and parse it
  open my $fh, "<", $pm_file or return "(unknown)";

  local $/ = "\n";
  my $inpod;

  while (local $_ = <$fh>) {
    # =cut toggles, it doesn't end :-/
    $inpod = /^=cut/ ? !$inpod : $inpod || /^=(?!cut)/;

    if (/#+\s*ABSTRACT: (.*)/){
      # takes ABSTRACT: ... if no POD defined yet
      $weaver_abstract = $1;
    }

    next unless $inpod;
    chomp;

    next unless /^(?:$class\s-\s)(.*)/;

    $result = $1;
    last;
  }

  return $result || $weaver_abstract || "(unknown)";
}

#pod =method description
#pod
#pod This method can be overridden to provide full option description. It
#pod is used by the built-in L command.
#pod
#pod If not overridden, it uses L to extract the description
#pod from the module's Pod DESCRIPTION section or the empty string.
#pod
#pod =cut

sub description {
    my ($class) = @_;
    $class = ref $class if ref $class;

    # classname to filename
    (my $pm_file = $class) =~ s!::!/!g;
    $pm_file .= '.pm';
    $pm_file = $INC{$pm_file} or return '';

    open my $input, "<", $pm_file or return '';

    my $descr = "";
    open my $output, ">", \$descr;

    require Pod::Usage;
    Pod::Usage::pod2usage( -input => $input,
               -output => $output,
               -exit => "NOEXIT",
               -verbose => 99,
               -sections => "DESCRIPTION",
               indent => 0
    );
    $descr =~ s/Description:\n//m;
    chomp $descr;

    return $descr;
}

1;

__END__