File Coverage

blib/lib/IO/Prompt/Hooked.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	18	18	100.0
condition	15	15	100.0
subroutine	13	13	100.0
pod	2	2	100.0
total	98	98	100.0

#!/usr/bin/env perl
package IO::Prompt::Hooked;

use 5.006000;
use strict;
use warnings;
use Params::Smart;
use IO::Prompt::Tiny ();

our $VERSION = '0.10';

use parent 'Exporter';

our @EXPORT    = qw( prompt   );
our @EXPORT_OK = qw( terminate_input );

# Steal a subroutine from IO::Prompt::Tiny (Not published in the API)!
*_is_interactive = \&IO::Prompt::Tiny::_is_interactive;

# Template for Params::Smart validation.
my @params = (
    { name => 'message', required => 0, default => '' },
    { name => 'default', required => 0, },
    { name => 'tries',   required => 0, name_only => 1, default => -1 },
    {
        name      => 'validate',
        required  => 0,
        name_only => 1,
        default   => sub { 1 }
    },
    {
        name      => 'error',
        required  => 0,
        name_only => 1,
        default   => sub { q{} }
    },
    {
        name      => 'escape',
        required  => 0,
        name_only => 1,
        default   => sub { 0 }
    },
);

sub prompt {
    my @params = _unpack_prompt_params(@_);
    return _hooked_prompt(@params);
}

sub terminate_input {
    no warnings 'exiting';
    last;

    # Return, here, would be pointless.
}

sub _unpack_prompt_params {
    my @args = ref $_[0] ? %{ shift() } : @_;
    my %args = Params(@params)->args(@args);

    $args{message} = defined $args{message} ? $args{message} : '';
    # 'validate' and 'escape' can be passed a regex object instead of
    # a subref.
    for my $arg (qw( validate escape )) {
        if ( ref $args{$arg} eq 'Regexp' ) {
            my $regex = $args{$arg};
            $args{$arg} = sub { $_[0] =~ $regex; };
        }
    }

    # Error can be passed a string or a subref.
    if ( ref( $args{error} ) ne 'CODE' ) {
        my $message = $args{error};
        $args{error} = sub { $message };
    }

    # If we're not interactive, make sure there's a tries limit.
    if ( ( $ENV{PERL_MM_USE_DEFAULT} || !_is_interactive() )
        && $args{tries} < 0 )
    {
        $args{tries} = 1;
    }

    return @args{qw( message default tries validate error escape )};
}

sub _hooked_prompt {
    my ( $msg, $default, $tries, $validate_cb, $error_cb, $escape_cb ) = @_;

  # Short-circuit to the default, whatever it is if we start out with $tries==0.
    return $default
      if defined $tries && $tries == 0;

    while ($tries) {

        my $raw = IO::Prompt::Tiny::prompt( $msg, $default );

        $tries--;

        last if $escape_cb->( $raw, $tries );

        return $raw if $validate_cb->( $raw, $tries );

        if ( my $error_msg =
                $error_cb->( $raw, $tries )
            and _is_interactive()
            and !$ENV{PERL_MM_USE_DEFAULT} )
        {
            print $error_msg;
        }
    }

    return;    # If we arrived here, no valid input accepted.
}

1;

__END__