File Coverage

blib/lib/App/Cmd/Plugin/Prompt.pm

Criterion	Covered	Total	%
statement	12	45	26.6
branch	0	24	0.0
condition	0	29	0.0
subroutine	4	11	36.3
pod	3	3	100.0
total	19	112	16.9

use strict;
use warnings;
package App::Cmd::Plugin::Prompt 1.006;
# ABSTRACT: plug prompting routines into your commands
use App::Cmd::Setup -plugin => {
  exports => [ qw(prompt_str prompt_yn prompt_any_key) ],
};

use Term::ReadKey;

#pod =head1 SYNOPSIS
#pod
#pod In your app:
#pod
#pod   package MyApp;
#pod   use App::Cmd::Setup -app => {
#pod     plugins => [ qw(Prompt) ],
#pod   };
#pod
#pod In your command:
#pod
#pod   package MyApp::Command::dostuff;
#pod   use MyApp -command;
#pod
#pod   sub run {
#pod     my ($self, $opt, $args) = @_;
#pod
#pod     return unless prompt_yn('really do stuff?', { default => 1 });
#pod
#pod     ...
#pod   }
#pod
#pod =head1 SUBROUTINES
#pod
#pod =head2 prompt_str
#pod
#pod   my $input = prompt_str($prompt, \%opt)
#pod
#pod This prompts a user for string input.  It can be directed to
#pod persist until input is 'acceptable'.
#pod
#pod Valid options are:
#pod
#pod =over 4
#pod
#pod =item *
#pod
#pod B optional coderef, which, when invoked, returns the
#pod user's response; default is to read from STDIN.
#pod
#pod =item *
#pod
#pod B optional coderef, which, when invoked (with two
#pod arguments: the prompt and the choices/default), should
#pod prompt the user; default is to write to STDOUT.
#pod
#pod =item *
#pod
#pod B an optional coderef which any input is passed into
#pod and which must return true in order for the program to
#pod continue
#pod
#pod =item *
#pod
#pod B may be any string; must pass the 'valid' coderef
#pod (if given)
#pod
#pod =item *
#pod
#pod B what to display after the prompt; default is
#pod either the 'default' parameter or nothing
#pod
#pod =item *
#pod
#pod B do not test the 'default' parameter
#pod against the 'valid' coderef
#pod
#pod =item *
#pod
#pod B error message to throw when the
#pod 'default' parameter is not valid (does not pass the 'valid'
#pod coderef)
#pod
#pod =back
#pod
#pod =cut

sub prompt_str {
  my ($plugin, $cmd, $message, $opt) = @_;
  if ($opt->{default} && $opt->{valid} && ! $opt->{no_valid_default}) {
    Carp::croak(
      $opt->{invalid_default_error} || "'default' must pass 'valid' parameter"
    ) unless $opt->{valid}->($opt->{default});
  }
  $opt->{input}  ||= sub { scalar  };
  $opt->{valid}  ||= sub { 1 };
  $opt->{output} ||= sub {
    if (defined $_[1]) {
      printf "%s [%s]: ", @_;
    } else {
      printf "%s: ", $_[0];
    }
  };

  my $response;
  while (!defined($response) || !$opt->{valid}->($response)) {
    $opt->{output}->(
      $message,
      ($opt->{choices} || $opt->{default} || undef),
    );
    $response = $opt->{input}->();
    chomp($response);
    if ($opt->{default} && ! length($response)) {
      $response = $opt->{default};
    }
  }
  return $response;
}

#pod =head2 prompt_yn
#pod
#pod   my $bool = prompt_yn($prompt, \%opt);
#pod
#pod This prompts the user for a yes or no response and won't give up until it gets
#pod one.  It returns true for yes and false for no.
#pod
#pod Valid options are:
#pod
#pod  default: may be yes or no, indicating how to interpret an empty response;
#pod           if empty, require an explicit answer; defaults to empty
#pod
#pod =cut

sub prompt_yn {
  my ($plugin, $cmd, $message, $opt) = @_;

  Carp::croak("default must be y or n or 0 or 1")
    if defined $opt->{default}
    and $opt->{default} !~ /\A[yn01]\z/;

  my $choices = (not defined $opt->{default}) ? 'y/n'
              : $opt->{default} eq 'y'        ? 'Y/n'
              : $opt->{default} eq 'n'        ? 'y/N'
              : $opt->{default}               ? 'Y/n'
              :                                 'y/N';

  my $default = ($opt->{default}||'') =~ /\A\d\z/
              ? ($opt->{default} ? 'y' : 'n')
              : $opt->{default};

  my $response = $plugin->prompt_str(
    $cmd,
    $message,
    {
      choices => $choices,
      valid   => sub { lc($_[0]) eq 'y' || lc($_[0]) eq 'n' },
      default => $default,
    },
  );

  return lc($response) eq 'y';
}

#pod =head2 prompt_any_key($prompt)
#pod
#pod   my $input = prompt_any_key($prompt);
#pod
#pod This routine prompts the user to "press any key to continue."  C<$prompt>, if
#pod supplied, is the text to prompt with.
#pod
#pod =cut

sub prompt_any_key {
  my ($plugin, $cmd, $prompt) = @_;

  $prompt ||= "press any key to continue";
  print $prompt;
  Term::ReadKey::ReadMode 'cbreak';
  Term::ReadKey::ReadKey(0);
  Term::ReadKey::ReadMode 'normal';
  print "\n";
}

#pod =head1 SEE ALSO
#pod
#pod L
#pod
#pod =cut

1;

__END__