view release on metacpan or  search on metacpan

lib/App/Info/Handler/Prompt.pm  view on Meta::CPAN

package App::Info::Handler::Prompt;

=head1 NAME

App::Info::Handler::Prompt - Prompting App::Info event handler

=head1 SYNOPSIS

  use App::Info::Category::FooApp;
  use App::Info::Handler::Print;

  my $prompter = App::Info::Handler::Print->new;
  my $app = App::Info::Category::FooApp->new( on_unknown => $prompter );

  # Or...
  my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' );

=head1 DESCRIPTION

App::Info::Handler::Prompt objects handle App::Info events by printing their
messages to C<STDOUT> and then accepting a new value from C<STDIN>. The new
value is validated by any callback supplied by the App::Info concrete subclass
that triggered the event. If the value is valid, App::Info::Handler::Prompt
assigns the new value to the event request. If it isn't it prints the error
message associated with the event request, and then prompts for the data
again.

Although designed with unknown and confirm events in mind,
App::Info::Handler::Prompt handles info and error events as well. It will
simply print info event messages to C<STDOUT> and print error event messages
to C<STDERR>. For more interesting info and error event handling, see
L<App::Info::Handler::Print|App::Info::Handler::Print> and
L<App::Info::Handler::Carp|App::Info::Handler::Carp>.

Upon loading, App::Info::Handler::Print registers itself with
App::Info::Handler, setting up a single string, "prompt", that can be passed
to an App::Info concrete subclass constructor. This string is a shortcut that
tells App::Info how to create an App::Info::Handler::Print object for handling
events.

=cut

use strict;
use App::Info::Handler;
use vars qw($VERSION @ISA);
$VERSION = '0.57';
@ISA = qw(App::Info::Handler);

# Register ourselves.
App::Info::Handler->register_handler
  ('prompt' => sub { __PACKAGE__->new } );

=head1 INTERFACE

=head2 Constructor

=head3 new

  my $prompter = App::Info::Handler::Prompt->new;

Constructs a new App::Info::Handler::Prompt object and returns it. No special
arguments are required.

=cut

sub new {
    my $pkg = shift;
    my $self = $pkg->SUPER::new(@_);
    $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) );
    # We're done!
    return $self;
}

my $get_ans = sub {
    my ($prompt, $tty, $def) = @_;
    # Print the message.
    local $| = 1;
    local $\;
    print $prompt;

    # Collect the answer.
    my $ans;