File Coverage

blib/lib/IO/Prompt/Simple.pm

Criterion	Covered	Total	%
statement	143	147	97.2
branch	98	112	87.5
condition	23	41	56.1
subroutine	13	14	92.8
pod	1	1	100.0
total	278	315	88.2

package IO::Prompt::Simple;

use strict;
use warnings;
use 5.006001;
use base 'Exporter';

BEGIN {
    $ENV{ANSI_COLORS_DISABLED} = 1 if $^O eq 'MSWin32';
}

our $VERSION = '0.06';

our @EXPORT = 'prompt';

sub prompt {
    my ($message, $opts) = @_;
    _croak('Usage: prompt($message, [$default_or_opts])') unless defined $message;

    my $default;
    if (ref $opts eq 'HASH') {
        $default = $opts->{default};
    }
    else {
        ($default, $opts) = ($opts, {});
    }
    my $display_default = defined $default ? "[$default]" : '';
    $default = defined $default ? $default : '';

    my $stash = { message => $message };
    _parse_option($opts, $stash);

    $stash->{message} .= " $display_default";
    if (my $color = $opts->{color}) {
        require Term::ANSIColor;
        $color = [$color] unless ref $color eq 'ARRAY';
        $stash->{message} = Term::ANSIColor::colored($color, $stash->{message});
    }

    my ($in, $out) = @$stash{qw/in out/};

    # autoflush and reset format for output
    my $org_out = select $out;
    local $| = 1;
    local $\;
    select $org_out;

    my $ignore_case = $opts->{ignore_case} ? 1 : 0;
    my $isa_tty     = _isa_tty($in, $out);
    my $answer;
    my @answers; # for multi
    while (1) {
        print {$out} $stash->{choices}, "\n" if defined $stash->{choices};
        print {$out} $stash->{message}, ': ';
        if ($ENV{PERL_IOPS_USE_DEFAULT} || $opts->{use_default} || (!$isa_tty && eof $in)) {
            print {$out} "$default\n";
            $answer = $default;
            last;
        }
        $answer = <$in>;
        if (defined $answer) {
            chomp $answer;
            print {$out} "$answer\n" unless $isa_tty;
        }
        else {
            print {$out} "\n";
        }

        $answer = $default if !defined $answer || $answer eq '';
        $answer = $stash->{encoder}->decode($answer) if defined $stash->{encoder};
        if (my $exclusive_map = $stash->{exclusive_map}) {
            if ($stash->{want_multi}) {
                $answer = $ignore_case ? lc $answer : $answer;
                my $has_error;
                for my $ans (split /\s+/, $answer) {
                    unless (exists $exclusive_map->{$ans}) {
                        $has_error = 1;
                        last;
                    }
                    push @answers, $exclusive_map->{$ans};
                }
                $has_error = 1 unless @answers;
                last unless $has_error;
            }
            else {
                if (exists $exclusive_map->{$ignore_case ? lc $answer : $answer}) {
                    $answer = $exclusive_map->{$ignore_case ? lc $answer : $answer};
                    last;
                }
            }
            @answers = ();
            $answer  = undef;
            print {$out} $stash->{hint};
            next;
        }
        elsif (my $regexp = $stash->{regexp}) {
            last if $answer =~ $regexp;
            $answer = undef;
            print {$out} $stash->{hint};
            next;
        }
        last;
    }

    return $stash->{want_multi} ? @answers : $answer;
}

sub _parse_option {
    my ($opts, $stash) = @_;

    $stash->{in}  = _is_fh($opts->{input})  ? $opts->{input}  : *STDIN;
    $stash->{out} = _is_fh($opts->{output}) ? $opts->{output} : *STDOUT;

    if ($opts->{yn}) {
        $opts->{anyone}       = \[y => 1, n => 0];
        $opts->{ignore_case}  = 1 unless exists $opts->{ignore_case};
    }

    $opts->{anyone} ||= $opts->{choices};
    if ($opts->{anyone}) {
        $stash->{exclusive_map} = _make_exclusive_map($opts, $stash);
        $stash->{want_multi}    = $opts->{multi} ? 1 : 0;
    }
    elsif ($opts->{regexp}) {
        $stash->{regexp} = _make_regexp($opts, $stash);
    }

    if ($opts->{encode}) {
        require Encode;
        $stash->{encoder} = Encode::find_encoding($opts->{encode});
    }
}

sub _make_exclusive_map {
    my ($opts, $stash) = @_;
    my $anyone = $opts->{anyone};
    my $exclusive_map = {};

    my $ignore_case = $opts->{ignore_case} ? 1 : 0;
    my ($message, $hint, $choices) = @$stash{qw/message hint choices/};
    my $type = _anyone_type($anyone) || return;
    if ($type eq 'ARRAY') {
        my @stuffs = _uniq(@$anyone);
        for my $stuff (@stuffs) {
            $exclusive_map->{$ignore_case ? lc $stuff : $stuff} = $stuff;
        }
        $hint     = sprintf "# Please answer %s\n", join ' or ', map qq{`$_`}, @stuffs;
        $message .= sprintf ' (%s)', join '/', @stuffs;
    }
    elsif ($type eq 'HASH' || $type eq 'REFARRAY' || $type eq 'Hash::MultiValue') {
        my @keys =
            $type eq 'HASH'             ? sort { $a cmp $b } keys %$anyone :
            $type eq 'REFARRAY'         ? do { my $i = 0; grep { ++$i % 2 == 1 } @{$$anyone} } :
            $type eq 'Hash::MultiValue' ? $anyone->keys : ();
        my $max = 0;
        my $idx = 1;
        for my $key (@keys) {
            $max = length $key > $max ? length $key : $max;
            $exclusive_map->{$ignore_case ? lc $key : $key} =
                $type eq 'REFARRAY' ? $$anyone->[$idx] : $anyone->{$key};
            $idx += 2;
        }
        $hint = sprintf "# Please answer %s\n", join ' or ',map qq{`$_`}, @keys;
        if ($opts->{verbose}) {
            my $idx = -1;
            $choices = join "\n", map {
                $idx += 2;
                sprintf "# %-*s => %s", $max, $_,
                    $type eq 'REFARRAY' ? $$anyone->[$idx] : $anyone->{$_};
            } @keys;
        }
        else {
            $message .= sprintf ' (%s)', join '/', @keys;
        }
    }

    @$stash{qw/message hint choices/} = ($message, $hint, $choices);
    return $exclusive_map;
}

sub _anyone_type {
    my $anyone = shift;
    my $type =
        ref $anyone eq 'ARRAY' && @$anyone ? 'ARRAY' :
        ref $anyone eq 'HASH'  && %$anyone ? 'HASH'  :
        ref $anyone eq 'REF'   && ref $$anyone eq 'ARRAY' && @{$$anyone}
            ? 'REFARRAY' :
        do {
            require Scalar::Util;
            Scalar::Util::blessed($anyone) || ''
        } eq 'Hash::MultiValue' && %$anyone
            ? 'Hash::MultiValue' : '';
    return $type;
}

sub _make_regexp {
    my ($opts, $stash) = @_;
    my $regexp = ref $opts->{regexp} eq 'Regexp' ? $opts->{regexp}
        : $opts->{ignore_case} ? qr/$opts->{regexp}/i : qr/$opts->{regexp}/;
    $stash->{hint} = sprintf "# Please answer pattern %s\n", $regexp;
    $regexp = qr/\A $regexp \Z/x;
    return $regexp;
}

# using IO::Interactive::is_interactive() ?
sub _isa_tty {
    my ($in, $out) = @_;
    return -t $in && (-t $out || !(-f $out || -c $out)) ? 1 : 0; ## no critic
}

# taken from Test::Builder
sub _is_fh {
    my $maybe_fh = shift;
    return 0 unless defined $maybe_fh;

    return 1 if ref $maybe_fh  eq 'GLOB'; # its a glob ref
    return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob

    return eval { $maybe_fh->isa('IO::Handle') }
        || eval { tied($maybe_fh)->can('TIEHANDLE') };
}

sub _uniq {
    my %h;
    grep !$h{$_}++, @_;
}

sub _croak {
    require Carp;
    Carp::croak(@_);
}

1;
__END__