File Coverage

blib/lib/IO/Prompter.pm

Criterion	Covered	Total	%
statement	471	834	56.4
branch	137	374	36.6
condition	109	280	38.9
subroutine	49	75	65.3
pod	1	1	100.0
total	767	1564	49.0

use 5.010;
package IO::Prompter;
use utf8;

use warnings;
no if $] >= 5.018000, warnings => 'experimental';
use strict;
use Carp;
use Contextual::Return qw< PUREBOOL BOOL SCALAR METHOD VOID LIST RETOBJ >;
use Scalar::Util qw< openhandle looks_like_number >;
use Symbol       qw< qualify_to_ref >;

our $VERSION = '0.004015';

my $fake_input;     # Flag that we're faking input from the source

my $DEFAULT_TERM_WIDTH   = 80;
my $DEFAULT_VERBATIM_KEY = "\cV";

# Completion control...
my $COMPLETE_DISPLAY_FIELDS = 4;  #...per line
my $COMPLETE_DISPLAY_GAP    = 3;  #...spaces

my $COMPLETE_KEY  = $ENV{IO_PROMPTER_COMPLETE_KEY} // qq{\t};
my $COMPLETE_HIST = $ENV{IO_PROMPTER_HISTORY_KEY}  // qq{\cR};
my $COMPLETE_NEXT = qq{\cN};
my $COMPLETE_PREV = qq{\cP};

my $COMPLETE_INIT  = qr{ [\Q$COMPLETE_KEY$COMPLETE_HIST\E] }xms;
my $COMPLETE_CYCLE = qr{ [$COMPLETE_NEXT$COMPLETE_PREV] }xms;

my %COMPLETE_MODE = (
    $COMPLETE_KEY
        => [split /\s+/, $ENV{IO_PROMPTER_COMPLETE_MODES}//q{list+longest  full}],
    $COMPLETE_HIST
        => [split /\s+/, $ENV{IO_PROMPTER_HISTORY_MODES} // q{full}],
);

my $FAKE_ESC    = "\e";
my $FAKE_INSERT = "\cF";
my $MENU_ESC    = "\e";
my $MENU_MK     = '__M_E_N_U__';

my %EDIT = (
    BACK    => qq{\cB},
    FORWARD => qq{\cF},
    START   => qq{\cA},
    END     => qq{\cE},
);
my $EDIT_KEY = '['.join(q{},values %EDIT).']';

# Extracting key letters...
my $KL_EXTRACT = qr{ (?| \[  ( [[:alnum:]]++ )  \]
                       | \(  ( [[:alnum:]]++ )  \)
                       | \<  ( [[:alnum:]]++ )  \>
                       | \{  ( [[:alnum:]]++ )  \}
                     )
                   }xms;
my $KL_DEF_EXTRACT = qr{ \[  ( [[:alnum:]]++ )  \] }xms;


# Auxiliary prompts for -Yes => N construct...
my @YESNO_PROMPTS = (
    q{Really?},
    q{You're quite certain?},
    q{Definitely?},
    q{You mean it?},
    q{You truly mean it?},
    q{You're sure?},
    q{Have you thought this through?},
    q{You understand the consequences?},
);


# Remember returned values for history completion...
my %history_cache;

# Track lexically-scoped default options and wrapper subs...
my @lexical_options  = [];
my @lexical_wrappers = [];

# Export the prompt() sub...
sub import {
    my (undef, $config_data, @other_args) = @_;

    # Handle -argv requests...
    if (defined $config_data && $config_data eq '-argv') {
        scalar prompt(-argv, @other_args);
    }

    # Handle lexical options...
    elsif (ref $config_data eq 'ARRAY') {
        push @lexical_options, $config_data;
        $^H{'IO::Prompter::scope_number'} = $#lexical_options;
    }

    # Handle lexical wrappers...
    elsif (ref $config_data eq 'HASH') {
        push @lexical_options, [];
        $lexical_wrappers[ $#lexical_options ] = $config_data;
        $^H{'IO::Prompter::scope_number'} = $#lexical_options;
        for my $subname (keys %{$config_data}) {
            my @args = @{$config_data->{$subname}};
            no strict 'refs';
            no warnings 'redefine';
            *{caller().'::'.$subname} = sub {
                my $scope_number = (caller 0)[10]{'IO::Prompter::scope_number'};
                return prompt(@{$lexical_wrappers[$scope_number]{$subname}//[]}, @_);
            };
        }
    }

    # Handler faked input specifications...
    elsif (defined $config_data) {
        $fake_input = $config_data;
    }

    no strict 'refs';
    *{caller().'::prompt'} = \&prompt;
}

# Prompt for, read, vet, and return input...
sub prompt {
    # Reclaim full control of print statements while prompting...
    local $\ = '';

    # Locate any lexical default options...
    my $hints_hash = (caller 0)[10] // {};
    my $scope_num = $hints_hash->{'IO::Prompter::scope_number'} // 0;

    # Extract and sanitize configuration arguments...
    my $opt_ref = _decode_args(@{$lexical_options[$scope_num]}, @_);

    _warn( void => 'Useless use of prompt() in void context' )
        if VOID && !$opt_ref->{-void};

    # Set up yesno prompts if required...
    my @yesno_prompts
        = ($opt_ref->{-yesno}{count}//0) > 1 ? @YESNO_PROMPTS : ();

    # Work out where the prompts go, and where the input comes from...
    my $in_filehandle  = $opt_ref->{-in}  // _open_ARGV();
    my $out_filehandle = $opt_ref->{-out} // qualify_to_ref(select);
    if (!openhandle $in_filehandle) {
        open my $fh, '<', $in_filehandle
            or _opt_err('Unacceptable', '-in', 'valid filehandle or filename');
        $in_filehandle = $fh;
    }
    if (!openhandle $out_filehandle) {
        open my $fh, '>', $out_filehandle
            or _opt_err('Unacceptable', '-out', 'valid filehandle or filename');
        $out_filehandle = $fh;
    }

    # Track timeouts...
    my $in_pos = do { no warnings;  tell $in_filehandle } // 0;

    # Short-circuit if not valid handles...
    return if !openhandle($in_filehandle) || !openhandle($out_filehandle);

    # Work out how they're arriving and departing...
    my $outputter_ref = -t $in_filehandle && -t $out_filehandle
                            ? _std_printer_to($out_filehandle, $opt_ref)
                            : _null_printer()
                            ;
    my $inputter_ref = _generate_unbuffered_reader_from(
                            $in_filehandle, $outputter_ref, $opt_ref
                       );

    # Clear the screen if requested to...
    if ($opt_ref->{-wipe}) {
        $outputter_ref->(-nostyle => "\n" x 1000);
    }

    # Handle menu structures...
    my $input;
    REPROMPT_YESNO:
    if ($opt_ref->{-menu}) {
        # Remember top of (possibly nested) menu...
        my @menu = ( $opt_ref->{-menu} );
        my $top_prompt = $opt_ref->{-prompt};
        $top_prompt =~ s{$MENU_MK}{$opt_ref->{-menu}{prompt}}xms;
        $menu[-1]{prompt} = $top_prompt;

        MENU:
        while (1) {
            # Track the current level...
            $opt_ref->{-menu_curr_level} = $menu[-1]{value_for};

            # Show menu and retreive choice...
            $outputter_ref->(-style => $menu[-1]{prompt});
            my $tag = $inputter_ref->($menu[-1]{constraint});

            # Handle a failure by exiting the loop...
            last MENU if !defined $tag;
            $tag =~ s{\A\s*(\S*).*}{$1}xms;

            # Handle  by moving up menu stack...
            if ($tag eq $MENU_ESC) {
                $input = undef;
                last MENU if @menu <= 1;
                pop @menu;
                next MENU;
            }

            # Handle defaults by selecting and ejecting...
            if ($tag =~ /\A\R?\Z/ && exists $opt_ref->{-def}) {
                $input = $tag;
                last MENU;
            }

            # Otherwise, retrieve value for selected tag and exit if not a nested menu...
            $input = $menu[-1]{value_for}{$tag};
            last MENU if !ref $input;

            # Otherwise, go down the menu one level...
            push @menu,
                _build_menu($input,
                             "Select from $menu[-1]{key_for}{$tag}: ",
                             $opt_ref->{-number} || $opt_ref->{-integer}
                );
            $menu[-1]{prompt} .= '> ';
        }
    }

    # Otherwise, simply ask and ye shall receive...
    else {
        $outputter_ref->(-style => $opt_ref->{-prompt});
        $input = $inputter_ref->();
    }

    # Provide default value if available and necessary...
    my $defaulted = 0;
    if (defined $input && $input =~ /\A\R?\Z/ && exists $opt_ref->{-def}) {
        $input = $opt_ref->{-def};
        $defaulted = 1;
    }

    # The input line is usually chomped before being returned...
    if (defined $input && !$opt_ref->{-line}) {
        chomp $input;
    }

    # Check for a value indicating failure...
    if (exists $opt_ref->{-fail} && $input ~~ $opt_ref->{-fail}) {
        $input = undef;
    }

    # Setting @ARGV is a special case; process it like a command-line...
    if ($opt_ref->{-argv}) {
        @ARGV = map { _shell_expand($_) }
                    grep {defined}
                            $input =~ m{
                                    ( '  [^'\\]* (?: \\. [^'\\]* )* ' )
                                |   ( "  [^"\\]* (?: \\. [^"\\]* )* " )
                                |   (?: ^ | \s)  ( [^\s"'] \S*        )
                            }gxms;
        return 1;
    }

    # "Those who remember history are enabled to repeat it"...
    if (defined $input and $opt_ref->{-history} ne 'NONE') {
        my $history_set = $history_cache{ $opt_ref->{-history} } //= [] ;
        @{ $history_set } = ($input, grep { $_ ne $input } @{ $history_set });
    }

    # If input timed out insert the default, if any...
    my $timedout = $in_pos == do{ no warnings; tell $in_filehandle } // 0;
    if ($timedout && exists $opt_ref->{-def}) {
        $input = $opt_ref->{-def};
        $defaulted = 1;
    }

    # A defined input is a successful input...
    my $succeeded = defined $input;

    # The -yesno variants also need a 'y' to be successful...
    if ($opt_ref->{-yesno}{count}) {
        $succeeded &&= $input =~ m{\A \s* y}ixms;
        if ($succeeded && $opt_ref->{-yesno}{count} > 1) {
            my $count = --$opt_ref->{-yesno}{count};
            $opt_ref->{-prompt}
                = @yesno_prompts ? shift(@yesno_prompts) . q{ }
                : $count > 1     ? qq{Please confirm $count more times }
                :                   q{Please confirm one last time }
                ;
            goto REPROMPT_YESNO;    # Gasp, yes goto is the cleanest way!
        }
    }

    # Verbatim return doesn't do fancy tricks...
    if ($opt_ref->{-verbatim}) {
        return $input // ();
    }

    # Failure in a list context returns nothing...
    return if LIST && !$succeeded;

    # Otherwise, be context sensitive...
    return
        PUREBOOL { $_ = RETOBJ; next handler;      }
            BOOL { $succeeded;                     }
          SCALAR { $input;                         }
          METHOD {
                    defaulted => sub { $defaulted  },
                    timedout  => sub {
                        return q{} if !$timedout;
                        return "timed out after $opt_ref->{-timeout} second"
                             . ($opt_ref->{-timeout} == 1 ? q{} : q{s});
                    },
                 };
}


# Simulate a command line expansion for the -argv option...
sub _shell_expand {
    my ($text) = @_;

    # Single-quoted text is literal...
    if ($text =~ m{\A ' (.*) ' \z}xms) {
        return $1;
    }

    # Everything else has shell variables expanded...
    my $ENV_PAT = join '|', reverse sort keys %ENV;
    $text =~ s{\$ ($ENV_PAT)}{$ENV{$1}}gxms;

    # Double-quoted text isn't globbed...
    if ($text =~ m{\A " (.*) " \z}xms) {
        return $1;
    }

    # Everything else is...
    return glob($text);
}

# No completion is the default...
my $DEFAULT_COMPLETER = sub { q{} };

# Translate std constraints...
my %STD_CONSTRAINT = (
    positive  => sub { $_ > 0      },
    negative  => sub { $_ < 0      },
    zero      => sub { $_ == 0     },
    even      => sub { $_ % 2 == 0 },
    odd       => sub { $_ % 2 != 0 },
);

# Create abbreviations...
$STD_CONSTRAINT{pos} = $STD_CONSTRAINT{positive};
$STD_CONSTRAINT{neg} = $STD_CONSTRAINT{negative};

# Create antitheses...
for my $constraint (keys %STD_CONSTRAINT) {
    my $implementation = $STD_CONSTRAINT{$constraint};
    $STD_CONSTRAINT{"non$constraint"}
        = sub { ! $implementation->(@_) };
}

# Special style specifications require decoding...

sub _decode_echo {
    my $style = shift;

    # Not a special style...
    return $style if ref $style || $style !~ m{/};

    # A slash means yes/no echoes...
    my ($yes, $no) = split m{/}, $style;
    return sub{ /y/i ? $yes : $no };
}

sub _decode_echostyle {
    my $style = shift;

    # Not a special style...
    return $style if ref $style || $style !~ m{/};

    # A slash means yes/no styles...
    my ($yes, $no) = split m{/}, $style;
    return sub{ /y/i ? $yes : $no };
}

sub _decode_style {
    # No special prompt styles (yet)...
    return shift;
}

# Generate safe closure around active sub...
sub _gen_wrapper_for {
    my ($arg) = @_;
    return ref $arg ne 'CODE'
           ? sub { $arg }
           : sub { eval { for (shift) { no warnings; return $arg->($_) // $_ } } };
}

# Create recognizer...
my $STD_CONSTRAINT
    = '^(?:' . join('|', reverse sort keys %STD_CONSTRAINT) . ')';

# Translate name constraints to implementations...
sub _standardize_constraint {
    my ($option_type, $constraint_spec) = @_;

    return ("be an acceptable $option_type", $constraint_spec)
        if ref $constraint_spec;

    my @constraint_names = split /\s+/, $constraint_spec;
    my @constraints =
        map { $STD_CONSTRAINT{$_}
              // _opt_err('invalid',-$option_type,'"pos", "neg", "even", etc.')
            } @constraint_names;

    return (
        'be ' . join(' and ', @constraint_names),
        sub {
            my ($compare_val) = @_;
            for my $constraint (@constraints) {
                return 0 if !$constraint->($compare_val);
            }
            return 1;
        }
    );
}


# Convert args to prompt + options hash...
sub _decode_args {
    my %option = (
        -prompt    => undef,
        -complete  => $DEFAULT_COMPLETER,
        -must      => {},
        -history   => 'DEFAULT',
        -style     => sub{ q{} },
        -nostyle   => sub{ q{} },
        -echostyle => sub{ q{} },
        -echo      => sub { my $char = shift; $char eq "\t" ? q{ } : $char },
        -return    => sub { "\n" },
    );

    DECODING:
    while (defined(my $arg = shift @_)) {
        if (my $type = ref $arg) {
            _warn( reserved =>
                'prompt(): Unexpected argument (' . lc($type) . ' ref) ignored'
            );
        }
        else {
            my $redo;
            given ($arg) {
                # The sound of one hand clapping...
                when (/^-_/) {
                    $redo = 1;
                }

                # Non-chomping option...
                when (/^-line$/) {
                    $option{-line}++;
                }
                when (/^-l/) {
                    $option{-line}++;
                    $redo = 1;
                }

                # The -yesno variants...
                when (/^-YesNo$/) {
                    my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
                    $option{-yesno} = {
                        must => { '[YN]' => qr{\A \s* [YN] }xms },
                        count  => $count,
                    };
                }
                when (/^-YN/) {
                    $option{-yesno} = {
                        must => { '[YN]' => qr{\A \s* [YN] }xms },
                        count  => 1,
                    };
                    $redo = 2;
                }
                when (/^-yesno$/) {
                    my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
                    $option{-yesno} = {
                        must => { '[yn]' => qr{\A \s* [YN] }ixms },
                        count  => $count,
                    };
                }
                when (/^-yn/) {
                    $option{-yesno} = {
                        must => { '[yn]' => qr{\A \s* [YN] }ixms },
                        count  => 1,
                    };
                    $redo = 2;
                }
                when (/^-Yes$/) {
                    my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
                    $option{-yesno} = {
                        must => { '[Y for yes]' => qr{\A \s* (?: [^y] | \Z) }xms },
                        count  => $count,
                    };
                }
                when (/^-Y/) {
                    $option{-yesno} = {
                        must => { '[Y for yes]' => qr{\A \s* (?: [^y] | \Z) }xms },
                        count  => 1,
                    };
                    $redo = 1;
                }
                when (/^-yes$/) {
                    my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1;
                    $option{-yesno} = { count  => $count };
                }
                when (/^-y/) {
                    $option{-yesno} = { count  => 1 };
                    $redo = 1;
                }

                # Load @ARGV...
                when (/^-argv$/) {
                    $option{-argv} = 1;
                }

                when (/^-a/) {
                    $option{-argv} = 1;
                    $redo = 1;
                }

                # Clear screen before prompt...
                state $already_wiped;
                when (/^-wipe(first)?$/) {
                    $option{-wipe} = $1 ? !$already_wiped : 1;
                    $already_wiped = 1;
                }
                when (/^-w/) {
                    $option{-wipe} = 1;
                    $already_wiped = 1;
                    $redo = 1;
                }

                # Specify a failure condition...
                when (/^-fail$/) {
                    _opt_err('Missing', -fail, 'failure condition') if !@_;
                    $option{-fail} = shift @_;
                }

                # Specify a file request...
                when (/^-f(?:ilenames?)?$/) {
                    $option{-must}{'0: be an existing file'} = sub { -e $_[0] };
                    $option{-must}{'1: be readable'}         = sub { -r $_[0] };
                    $option{-complete}                       = 'filenames';
                }

                # Specify prompt echoing colour/style...
                when (/^-style/) {
                    _opt_err('Missing -style specification') if !@_;
                    my $style = _decode_style(shift @_);
                    $option{-style} = _gen_wrapper_for($style);
                }

                # Specify input colour/style...
                when (/^-echostyle/) {
                    _opt_err('Missing -echostyle specification') if !@_;
                    my $style = _decode_echostyle(shift @_);
                    $option{-echostyle} = _gen_wrapper_for($style);
                }


                # Specify input and output filehandles...
                when (/^-stdio$/) { $option{-in}  = *STDIN;
                                   $option{-out} = *STDOUT;
                                  }
                when (/^-in$/)    { $option{-in}  = shift @_; }
                when (/^-out$/)   { $option{-out} = shift @_; }

                # Specify integer and number return value...
                when (/^-integer$/)       {
                    $option{-integer} = 1;
                    if (@_ && (ref $_[0] || $_[0] =~ $STD_CONSTRAINT)) {
                        my ($errmsg, $constraint)
                            = _standardize_constraint('integer',shift);
                        $option{-must}{$errmsg} = $constraint;
                    }
                }
                when (/^-num(?:ber)?$/)   {
                    $option{-number}  = 1;
                    if (@_ && (ref $_[0] || $_[0] =~ $STD_CONSTRAINT)) {
                        my ($errmsg, $constraint)
                            = _standardize_constraint('number',shift);
                        $option{-must}{$errmsg} = $constraint;
                    }
                }
                when (/^-i/)              { $option{-integer} = 1; $redo = 1; }
                when (/^-n/)              { $option{-number}  = 1; $redo = 1; }

                # Specify void context is okay...
                when (/^-void$/)          { $option{-void} = 1;               }

                # Specify verbatim return value...
                when (/^-verb(?:atim)?$/) { $option{-verbatim} = 1;           }
                when (/^-v/)              { $option{-verbatim} = 1; $redo = 1;}

                # Specify single character return...
                when (/^-sing(?:le)?$/)   { $option{-single} = 1;             }
                when (/^-[s1]/)           { $option{-single} = 1; $redo = 1;  }

                # Specify a default...
                when (/^-DEF(?:AULT)?/) {
                    _opt_err('Missing', '-DEFAULT', 'string') if !@_;
                    $option{-def} = shift @_;
                    $option{-def_nocheck} = 1;
                    _opt_err('Invalid', '-DEFAULT', 'string')
                        if ref($option{-def});
                }
                when (/^-def(?:ault)?/) {
                    _opt_err('Missing', '-default', 'string') if !@_;
                    $option{-def} = shift @_;
                    _opt_err('Invalid', '-default', 'string')
                        if ref($option{-def});
                }
                when (/^-d(.+)$/)   { $option{-def} = $1; }

                # Specify a timeout...
                when (/^-t(\d+)/)   {
                    $option{-timeout} = $1;
                    $arg =~ s{\d+}{}xms;
                    $redo = 1;
                }
                when (/^-timeout$/) {
                    _opt_err('Missing', -timeout, 'number of seconds') if !@_;
                    $option{-timeout} = shift @_;
                    _opt_err('Invalid', -timeout,'number of seconds')
                        if !looks_like_number($option{-timeout});
                }

                # Specify a set of input constraints...
                when (/^-g.*/) {
                    _opt_err('Missing', -guarantee, 'input restriction') if !@_;
                    my $restriction = shift @_;
                    my $restriction_type = ref $restriction;

                    $option{-must}{'be a valid input'} = $restriction;

                    # Hashes restrict input to their keys...
                    if ($restriction_type eq 'HASH') {
                        $restriction_type = 'ARRAY';
                        $restriction = [ keys %{$restriction} ];
                    }
                    # Arrays of strings matched (and completed) char-by-char...
                    if ($restriction_type eq 'ARRAY') {
                        my @restrictions = @{$restriction};
                        $option{-guarantee}
                            = '\A(?:'
                            . join('|', map {
                                  join(q{}, map { "(?:\Q$_\E" } split(q{}, $_))
                                . ')?' x length($_)
                              } @restrictions)
                            . ')\z'
                            ;
                        if ($option{-complete} == $DEFAULT_COMPLETER) {
                            $option{-complete} = \@restrictions;
                        }
                    }
                    # Regexes matched as-is...
                    elsif ($restriction_type eq 'Regexp') {
                        $option{-guarantee} = $restriction;
                    }
                    else {
                        _opt_err( 'Invalid', -guarantee,
                                  'array or hash reference, or regex'
                        );
                    }
                }

                # Specify a set of key letters...
                when ('-keyletters_implement') {
                    # Extract all keys and default keys...
                    my @keys  = ($option{-prompt} =~ m{$KL_EXTRACT}gxms);

                    # Convert default to a -default...
                    my @defaults = ($option{-prompt} =~ m{$KL_DEF_EXTRACT}gxms);
                    if (@defaults > 1) {
                        _warn( ambiguous =>
                            "prompt(): -keyletters found too many defaults"
                        )
                    }
                    elsif (@defaults) {
                        push @_, -default => $defaults[0];
                    }

                    # Convert key letters to a -guarantee...
                    @keys = ( map({uc} @keys), map({lc} @keys) );
                    if (@defaults == 1) {
                        push @keys, q{};
                    }
                    push @_, -guarantee => \@keys;

                }
                when (/^-key(?:let(?:ter)?)(?:s)?/) {
                    push @_, '-keyletters_implement';
                }
                when (/^-k/) {
                    push @_, '-keyletters_implement';
                    $redo = 1;
                }

                # Specify a set of return constraints...
                when (/^-must$/) {
                    _opt_err('Missing', -must, 'constraint hash') if !@_;
                    my $must = shift @_;
                    _opt_err('Invalid', -must, 'hash reference')
                        if ref($must) ne 'HASH';
                    for my $errmsg (keys %{$must}) {
                        $option{-must}{$errmsg} = $must->{$errmsg};
                    }
                }

                # Specify a history set...
                when (/^-history/) {
                    $option{-history}
                        = @_ && $_[0] !~ /^-/ ? shift @_
                        :                       undef;
                    _opt_err('Invalid', -history, 'history set name')
                        if ref($option{-history});
                }
                when (/^-h(.*)/)   { $option{-history} = length($1) ? $1 : undef; }

                # Specify completions...
                when (/^-comp(?:lete)?/) {
                    _opt_err('Missing', -complete, 'completions') if !@_;
                    my $comp_spec = shift @_;
                    my $comp_type = ref($comp_spec) || $comp_spec || '???';
                    if ($comp_type =~ m{\A(?: file\w* | dir\w* | ARRAY | HASH | CODE )\Z}xms) {
                        $option{-complete} = $comp_spec;
                    }
                    else {
                        _opt_err( 'Invalid', -complete,
                                    '"filenames", "dirnames", or reference to array, hash, or subroutine');
                    }
                }

                # Specify what to echo when a character is keyed...
                when (/^-(echo|ret(?:urn)?)$/) {
                    my $flag = $1 eq 'echo' ? '-echo' : '-return';
                    if ($flag eq '-echo' && !eval { no warnings 'deprecated'; require Term::ReadKey }) {
                        _warn( bareword => "Warning: next input will be in plaintext\n");
                    }
                    my $arg = @_ && $_[0] !~ /^-/ ? shift(@_)
                            : $flag eq '-echo'    ? q{}
                            :                       qq{\n};
                    $option{$flag} = _gen_wrapper_for(_decode_echo($arg));
                }
                when (/^-e(.*)/) {
                    if (!eval { no warnings 'deprecated'; require Term::ReadKey }) {
                        _warn( bareword => "Warning: next input will be in plaintext\n");
                    }
                    my $arg = $1;
                    $option{-echo} = _gen_wrapper_for(_decode_echo($arg));
                }
                when (/^-r(.+)/) {
                    my $arg = $1;
                    $option{-return} = _gen_wrapper_for(_decode_echo($arg));
                }
                when (/^-r/) {
                    $option{-return} = sub{ "\n" };
                }

                # Explicit prompt replaces implicit prompts...
                when (/^-prompt$/) {
                    _opt_err('Missing', '-prompt', 'prompt string') if !@_;
                    $option{-prompt} = shift @_;
                    _opt_err('Invalid', '-prompt', 'string')
                        if ref($option{-prompt});
                }
                when (/^-p(\S*)$/) {
                    $option{-prompt} = $1;
                }

                # Menus inject a placeholder in the prompt string...
                when (/^-menu$/) {
                    _opt_err('Missing', '-menu', 'menu specification') if !@_;
                    $option{-menu}         = ref $_[0] ? shift(@_) : \shift(@_);
                    $option{-prompt}      .= $MENU_MK;
                    $option{-def_nocheck}  = 1;
                }

                # Anything else of the form '-...' is a misspelt option...
                when (/^-\w+$/) { _warn(misc => "prompt(): Unknown option $arg ignored"); }

                # Anything else is part fo the prompt...
                default       { $option{-prompt} .= $arg; }
            }

            # Handle option bundling...
            redo DECODING if $redo && $arg =~ s{\A -.{$redo} (?=.)}{-}xms;
        }
    }

    # Precompute top-level menu, if menuing...
    if (exists $option{-menu}) {
        $option{-menu} = _build_menu($option{-menu},
                                     undef,
                                     $option{-number}||$option{-integer}
                         );
    }

    # Handle return magic on -single...
    if (defined $option{-single} && length($option{-echo}('X')//'echoself')) {
        $option{-return} //= sub{ "\n" };
    }

    # Adjust prompt as necessary...
    if ($option{-argv}) {
        my $progname = $option{-prompt} // $0;
        $progname =~ s{^.*/}{}xms;

        my $HINT = '[enter command line args here]';
        $option{-prompt} = "> $progname  $HINT\r> $progname ";

        $option{-complete} = 'filenames';

        my $not_first;
        $option{-echo}   = sub{
            my $char = shift;
            $option{-prompt} = "> $progname ";  # Sneaky resetting to handle completions
            return $char if $not_first++;
            return "\r> $progname  " . (q{ } x length $HINT) . "\r> $progname $char";
        }
    }
    elsif (!defined $option{-prompt}) {
        $option{-prompt} = '> ';
    }
    elsif ($option{-prompt} =~ m{ \S \z}xms) {
        # If prompt doesn't end in whitespace, make it so...
        $option{-prompt} .= ' ';
    }
    elsif ($option{-prompt} =~ m{ (.*) \n \z}xms) {
        # If prompt ends in a newline, remove it...
        $option{-prompt} = $1;
    }

    # Steal history set name if -h given without a specification...
    $option{-history} //= $option{-prompt};

    # Verify any default satisfies any constraints...
    if (exists $option{-def} && !$option{-def_nocheck}) {
        if (!_verify_input_constraints(\q{},undef,undef,\%option)) {
            _warn( misc =>
                'prompt(): -default value does not satisfy -must constraints'
            );
        }
    }

    return \%option;
}

#====[ Error Handlers ]=========================================

sub _opt_err {
    my ($problem, $option, $expectation) = @_;
    Carp::croak "prompt(): $problem value for $option (expected $expectation)";
}

sub _warn {
    my ($category, @message) = @_;

    return if !warnings::enabled($category);

    my $message = join(q{},@message);
    warn $message =~ /\n$/ ? $message : Carp::shortmess($message);
}


#====[ Utility subroutines ]====================================

# Return the *ARGV filehandle, "magic-opening" it if necessary...
sub _open_ARGV {
    if (!openhandle \*ARGV) {
        $ARGV = shift @ARGV // '-';
        open *ARGV or Carp::croak(qq{prompt(): Can't open *ARGV: $!});
    }
    return \*ARGV;
}

my $INTEGER_PAT = qr{ \A \s*+ [+-]?+ \d++ (?: [Ee] \+? \d+ )? \s*+ \Z }xms;

my $NUMBER_PAT  = qr{
    \A \s*+ [+-]?+
    (?:
        \d++ (?: [.,] \d*+ )?
    |   [.,] \d++
    )
    (?: [eE] [+-]?+ \d++ )?
    \s*+ \Z
}xms;

# Verify interactive constraints...
sub _verify_input_constraints {
    my ($input_ref, $local_fake_input_ref, $outputter_ref, $opt_ref, $extras)
        = @_;

    # Use default if appropriate (but short-circuit checks if -DEFAULT set)...
    my $input = ${$input_ref};
    if (${$input_ref} =~ m{^\R?$}xms && exists $opt_ref->{-def}) {
        return 1 if $opt_ref->{-def_nocheck};
        $input = $opt_ref->{-def}
    }
    chomp $input;

    my $failed;
    # Integer constraint is hard-coded...
    if ($opt_ref->{-integer} && $input !~ $INTEGER_PAT) {
        $failed = $opt_ref->{-prompt} . "(must be an integer) ";
    }

    # Numeric constraint is hard-coded...
    if (!$failed && $opt_ref->{-number} && $input !~ $NUMBER_PAT) {
        $failed = $opt_ref->{-prompt} . "(must be a number) ";
    }

    # Sort and clean up -must list...
    my $must_ref = $opt_ref->{-must} // {};
    my @must_keys     = sort keys %{$must_ref};
    my %clean_key_for = map { $_ => (/^\d+[.:]?\s*(.*)/s ? $1 : $_) } @must_keys;
    my @must_kv_list  = map { $clean_key_for{$_} => $must_ref->{$_} } @must_keys;

    # Combine -yesno and -must constraints...
    my %constraint_for = (
        %{ $extras // {} },
        %{ $opt_ref->{-yesno}{must} // {} },
        @must_kv_list,
    );
    my @constraints = (
        keys %{ $extras // {} },
        keys %{ $opt_ref->{-yesno}{must} // {} },
        @clean_key_for{@must_keys},
    );

    # User-specified constraints...
    if (!$failed && keys %constraint_for) {
        CONSTRAINT:
        for my $msg (@constraints) {
            my $constraint = $constraint_for{$msg};
            next CONSTRAINT if eval { no warnings; local $_ = $input; $input ~~ $constraint; };
            $failed = $msg =~ m{\A [[:upper:]] }xms ? "$msg "
                    : $msg =~ m{\A \W }xms          ? $opt_ref->{-prompt}
                                                    . "$msg "
                    :                                 $opt_ref->{-prompt}
                                                    . "(must $msg) "
                    ;
            last CONSTRAINT;
        }
    }

    # If any constraint not satisfied...
    if ($failed) {
        # Return failure if not actually prompting at the moment...
        return 0 if !$outputter_ref;

        # Redraw post-menu prompt with failure message appended...
        $failed =~ s{.*$MENU_MK}{}xms;
        $outputter_ref->(-style => _wipe_line(), $failed);

        # Reset input collector...
        ${$input_ref}  = q{};

        # Reset faked input, if any...
        if (defined $fake_input && length($fake_input) > 0) {
            $fake_input =~ s{ \A (.*) \R? }{}xm;
            ${$local_fake_input_ref} = $1;
        }

        no warnings 'exiting';
        next INPUT;
    }

    # Otherwise succeed...
    return 1;
}

# Build a sub to read from specified filehandle, with or without timeout...
sub _generate_buffered_reader_from {
    my ($in_fh, $outputter_ref, $opt_ref) = @_;

    # Set-up for timeouts...
    my $fileno      = fileno($in_fh) // -1;
    my $has_timeout = exists $opt_ref->{-timeout} && $fileno >= 0;
    my $timeout     = $opt_ref->{-timeout};
    my $readbits    = q{};
    if ($has_timeout && $fileno >= 0) {
        vec($readbits,$fileno,1) = 1;
    }

    # Set up local faked input, if any...
    my $local_fake_input;
    my $orig_fake_input;
    if (defined $fake_input && length($fake_input) > 0) {
        $fake_input =~ s{ \A (.*) \R? }{}xm;
        $orig_fake_input = $local_fake_input = $1;
    }

    return sub {
        my ($extra_constraints) = @_;

        INPUT:
        while (1) {
            if (!$has_timeout || select $readbits, undef, undef, $timeout) {
                my $input;

                # Real input comes from real filehandles...
                if (!defined $local_fake_input) {
                    $input = readline $in_fh;
                }
                # Fake input has to be typed...
                else {
                    $input = $local_fake_input;
                    sleep 1;
                    for ($local_fake_input =~ m/\X/g) {
                        _simulate_typing();
                        $outputter_ref->(-echostyle => $opt_ref->{-echo}($_));
                    }
                    readline $in_fh;

                    # Check for simulated EOF...
                    if ($input =~ m{^ \s* (?: \cD | \cZ ) }xms) {
                        $input = undef;
                    }
                }

                if (defined $input) {
                    _verify_input_constraints(
                        \$input, \$local_fake_input, $outputter_ref, $opt_ref, $extra_constraints
                    );
                }

                return defined $input && $opt_ref->{-single}
                            ? substr($input, 0, 1)
                            : $input;
            }
            else {
                return;
            }
        }
    }
}

sub _autoflush {
    my ($fh) = @_;
    my $prev_selected = select $fh;
    $| = 1;
    select $prev_selected;
    return;
}

sub _simulate_typing {
    state $TYPING_SPEED = 0.07; # seconds per character
    select undef, undef, undef, rand $TYPING_SPEED;
}

sub _term_width {
    my ($term_width) = eval { no warnings 'deprecated'; Term::ReadKey::GetTerminalSize(\*STDERR) };
    return $term_width // $DEFAULT_TERM_WIDTH;
}

sub _wipe_line {
    return qq{\r} . q{ } x (_term_width()-1) . qq{\r};
}

# Convert a specification into a list of possible completions...
sub _current_completions_for {
    my ($input_text, $opt_ref) = @_;
    my $completer = $opt_ref->{-complete};

    # Isolate the final whitespace-separated word...
    my ($prefix, $lastword)
        = $input_text =~ m{
            (?| ^ (.*\s+) (.*)
              | ^ ()      (.*)
            )
          }xms;

    # Find candidates...
    my @candidates;
    given (ref($completer) || $completer // q{}) {
        # If completer is sub, recursively call it with input words...
        when ('CODE') {
            ($prefix, @candidates)
                = _current_completions_for(
                    $input_text,
                    { %{$opt_ref},
                      -complete => $completer->(split /\s+/, $input_text, -1)
                    }
                  );
        }

        # If completer is array, grep the appropriate elements...
        when ('ARRAY') {
            @candidates = grep { /\A\Q$lastword\E/ } @{$completer};
        }

        # If completer is hash, grep the appropriate keys...
        when ('HASH') {
            @candidates = grep { /\A\Q$lastword\E/ } keys %{$completer};
        }

        # If completer is 'file...', glob up the appropriate filenames...
        when (/^file\w*$/) {
            @candidates = glob($lastword.'*');
        }

        # If completer is 'dir...', glob up the appropriate directories...
        when (/^dir\w*$/) {
            @candidates = grep {-d} glob($lastword.'*');
        }
    }

    chomp @candidates;
    return ($prefix, @candidates);
}


sub _current_history_for {
    my ($prefix, $opt_ref) = @_;

    my $prefix_len = length($prefix);
    return q{}, map { /\A (.*?) \R \Z/x ? $1 : $_ }
               grep { substr($_,0,$prefix_len) eq $prefix }
                    @{ $history_cache{$opt_ref->{-history}} };
}

sub _longest_common_prefix_for {
    my $prefix = shift @_;
    for my $comparison (@_) {
        ($comparison ^ $prefix) =~ m{ \A (\0*) }xms;
        my $common_length = length($1);
        return q{} if !$common_length;
        $prefix = substr($prefix, 0, $common_length);
    }
    return $prefix;
}

sub _display_completions {
    my ($input, @candidates) = @_;

    return q{} if @candidates <= 1;

    # How big is each field in the table?
    my $field_width
        = _term_width() / $COMPLETE_DISPLAY_FIELDS - $COMPLETE_DISPLAY_GAP;

    # Crop the possibilities intelligently to that width...
    for my $candidate (@candidates) {
        substr($candidate, 0, length($input)) =~ s{ \A .* [/\\] }{}xms;
        $candidate
            = sprintf "%-*s", $field_width, substr($candidate,0,$field_width);
    }

    # Collect them into rows...
    my $display = "\n";
    my $gap     = q{ } x $COMPLETE_DISPLAY_GAP;
    while (@candidates) {
        $display .= $gap
                  . join($gap, splice(@candidates, 0, $COMPLETE_DISPLAY_FIELDS))
                  . "\n";
    }

    return $display;
}

sub _generate_unbuffered_reader_from {
    my ($in_fh, $outputter_ref, $opt_ref) = @_;

    my $has_readkey = eval { no warnings 'deprecated'; require Term::ReadKey };

    # If no per-character reads, fall back on buffered input...
    if (!-t $in_fh || !$has_readkey) {
        return _generate_buffered_reader_from($in_fh, $outputter_ref, $opt_ref);
    }

    # Adapt to local control characters...
    my %ctrl = eval { Term::ReadKey::GetControlChars($in_fh) };
    delete $ctrl{$_} for grep { $ctrl{$_} eq "\cA" } keys %ctrl;

    $ctrl{EOF}       //= "\4";
    $ctrl{INTERRUPT} //= "\3";
    $ctrl{ERASE}     //= $^O eq 'MSWin32' ? "\10" : "0177";

    my $ctrl           = join '|', values %ctrl;

    my $VERBATIM_KEY = $ctrl{QUOTENEXT} // $DEFAULT_VERBATIM_KEY;

    # Translate timeout for ReadKey (with 32-bit MAXINT workaround for Windows)...
    my $timeout = !defined $opt_ref->{-timeout} ? 0x7FFFFFFF    # 68 years
                : $opt_ref->{-timeout} == 0     ? -1
                :                                 $opt_ref->{-timeout}
                ;

    return sub {
        my ($extra_constraints) = @_;

        # Short-circuit on unreadable filehandle...
        return if !openhandle($in_fh);

        # Set up direct reading, and prepare to clean up on abnormal exit...
        Term::ReadKey::ReadMode('raw', $in_fh);
        my $prev_SIGINT = $SIG{INT};
        local $SIG{INT} = sub { given ($prev_SIGINT) {
                                    when ('IGNORE')  { }
                                    Term::ReadKey::ReadMode('restore', $in_fh);
                                    when ('DEFAULT') { exit(1) }
                                    when (undef)     { exit(1) }
                                    default {
                                        package main;
                                        no strict 'refs';
                                        $prev_SIGINT->()
                                    }
                                }
                          };

        # Set up local faked input, if any...
        my $local_fake_input;
        my $orig_fake_input;
        if (defined $fake_input && length($fake_input) > 0) {
            $fake_input =~ s{ \A (.*) \R? }{}xm;
            $orig_fake_input = $local_fake_input = $1;
        }

        my $input = q{};
        my $insert_offset = 0;
        INPUT:
        while (1) {
            state $prev_was_verbatim = 0;
            state $completion_level  = 0;
            state $completion_type   = q{};

            # Get next character entered...
            my $next = Term::ReadKey::ReadKey($timeout, $in_fh);

            # Finished with completion mode?
            if (($next//q{}) !~ m{ $COMPLETE_INIT | $COMPLETE_CYCLE }xms) {
                $completion_level = 0;
                $completion_type = q{};
            }

            # Are we faking input?
            my $faking = defined $local_fake_input;

            # If not EOF...
            if (defined $next) {
                # Remember where we were parked...
                my $prev_insert_offset = $insert_offset;

                # Handle interrupts...
                if ($next eq $ctrl{INTERRUPT}) {
                    $SIG{INT}();
                    next INPUT;
                }

                # Handle verbatim quoter...
                elsif (!$prev_was_verbatim && $next eq $VERBATIM_KEY) {
                    $prev_was_verbatim = 1;
                    next INPUT;
                }

                # Handle completions...
                elsif (!$prev_was_verbatim
                       && ( $next =~ $COMPLETE_INIT
                         || $completion_level > 0 && $next =~ $COMPLETE_CYCLE
                       )
                ) {
                    state @completion_list;  # ...all candidates for completion
                    state @completion_ring;  # ..."next" candidate cycle
                    state $completion_ring_first;  # ...special case first time
                    state $completion_prefix;      # ...skipped before completing

                    # Track completion type and level (switch if necessary)...
                    if ($next =~ $COMPLETE_INIT && index($completion_type, $next) < 0) {
                        $completion_type = index($COMPLETE_KEY, $next) >= 0 ? $COMPLETE_KEY : $COMPLETE_HIST;
                        $completion_level = 1;
                    }
                    else {
                        $completion_level++;
                    }

                    # If starting completion, cache completions...
                    if ($completion_level == 1) {
                        ($completion_prefix, @completion_list)
                           = index($COMPLETE_KEY, $next) >= 0
                                ? _current_completions_for($input, $opt_ref)
                                : _current_history_for($input, $opt_ref);
                        @completion_ring = (@completion_list, q{});
                        $completion_ring_first = 1;
                    }

                    # Can only complete if there are completions to be had...
                    if (@completion_list) {
                        # Select the appropriate mode...
                        my $mode = $COMPLETE_MODE{$completion_type}[$completion_level-1]
                                // $COMPLETE_MODE{$completion_type}[-1];

                        # 'longest mode' finds longest consistent prefix...
                        if ($mode =~ /longest/) {
                            $input
                                = $completion_prefix
                                . _longest_common_prefix_for(@completion_list);
                        }
                        # 'full mode' suggests next full match...
                        elsif ($mode =~ /full/) {
                            if (!$completion_ring_first) {
                                if ($next eq $COMPLETE_PREV) {
                                    unshift @completion_ring,
                                            pop @completion_ring;
                                }
                                else {
                                    push @completion_ring,
                                         shift @completion_ring;
                                }
                            }
                            $input = $completion_prefix . $completion_ring[0];
                            $completion_ring_first = 0;
                        }
                        # 'list mode' lists all possibilities...
                        my $list_display = $mode =~ /list/
                            ? _display_completions($input, @completion_list)
                            : q{};

                        # Update prompt with selected completion...
                        $outputter_ref->( -style =>
                            $list_display,
                            _wipe_line(),
                            $opt_ref->{-prompt}, $input
                        );

                        # If last completion was unique choice, completed...
                        if (@completion_list <= 1) {
                            $completion_level = 0;
                        }
                    }
                    next INPUT;
                }

                # Handle erasures (including pushbacks if faking)...
                elsif (!$prev_was_verbatim && $next eq $ctrl{ERASE}) {
                    if (!length $input) {
                        # Do nothing...
                    }
                    elsif ($insert_offset) {
                        # Can't erase past start of input...
                        next INPUT if $insert_offset >= length($input);

                        # Erase character just before cursor...
                        substr($input, -$insert_offset-1, 1, q{});

                        # Redraw...
                        my $input_pre  = substr($input.' ',0,length($input)-$insert_offset+1);
                        my $input_post = substr($input.' ',length($input)-$insert_offset);
                        my $display_pre
                            = join q{}, map { $opt_ref->{-echo}($_) } $input_pre =~ m/\X/g;
                        my $display_post
                            = join q{}, map { $opt_ref->{-echo}($_) } $input_post =~ m/\X/g;
                        $outputter_ref->( -echostyle =>
                              "\b" x length($display_pre)
                            . join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g)
                            . q{ } x length($opt_ref->{-echo}(q{ }))
                            . "\b" x length($display_post)
                        );
                    }
                    else {
                        my $erased = substr($input, -1, 1, q{});
                        if ($faking) {
                            substr($local_fake_input,0,0,$erased);
                        }
                        $outputter_ref->( -nostyle =>
                            map { $_ x (length($opt_ref->{-echo}($_)//'X')) }
                                "\b", ' ', "\b"
                        );
                    }
                    next INPUT;
                }

                # Handle EOF (including cancelling any remaining fake input)...
                elsif (!$prev_was_verbatim && $next eq $ctrl{EOF}) {
                    Term::ReadKey::ReadMode('restore', $in_fh);
                    close $in_fh;
                    undef $fake_input;
                    return length($input) ? $input : undef;
                }

                # Handle escape from faking...
                elsif (!$prev_was_verbatim && $faking && $next eq $FAKE_ESC) {
                    my $lookahead = Term::ReadKey::ReadKey(0, $in_fh);

                    # Two  implies the current faked line is deferred...
                    if ($lookahead eq $FAKE_ESC) {
                        $fake_input =~ s{ \A }{$orig_fake_input\n}xm;
                    }
                    # Only one  implies the current faked line is replaced...
                    else {
                        $in_fh->ungetc(ord($lookahead));
                    }
                    undef $local_fake_input;
                    $faking = 0;
                    next INPUT;
                }

                # Handle returns...
                elsif (!$prev_was_verbatim && $next =~ /\A\R\z/) {
                    # Complete faked line, if faked input incomplete...
                    if ($faking && length($local_fake_input)) {
                        for ($local_fake_input =~ m/\X/g) {
                            _simulate_typing();
                            $outputter_ref->(-echostyle => $opt_ref->{-echo}($_));
                        }
                        $input .= $local_fake_input;
                    }

                    # Add newline to the accumulated input string...
                    $input .= $next;

                    # Check that input satisfied any constraints...
                    _verify_input_constraints(
                        \$input, \$local_fake_input, $outputter_ref,
                        $opt_ref, $extra_constraints,
                    );

                    # Echo a default value if appropriate...
                    if ($input =~ m{\A\R?\Z}xms && defined $opt_ref->{-def}) {
                        my $def_val = $opt_ref->{-def};

                        # Try to find the key, for a menu...
                        if (exists $opt_ref->{-menu_curr_level}) {
                            for my $key ( keys %{$opt_ref->{-menu_curr_level}}) {
                                if ($def_val ~~ $opt_ref->{-menu_curr_level}{$key}) {
                                    $def_val = $key;
                                    last;
                                }
                            }
                        }

                        # Echo it as if it had been typed...
                        $outputter_ref->(-echostyle => $opt_ref->{-echo}($def_val));
                    }

                    # Echo the return (or otherwise, as specified)...
                    $outputter_ref->(-echostyle => $opt_ref->{-return}($next));

                    # Clean up, and return the input...
                    Term::ReadKey::ReadMode('restore', $in_fh);

                    # Handle fake EOF...
                    if ($faking && $input =~ m{^ (?: \cD | \cZ) }xms) {
                        return undef;
                    }

                    return $input;
                }

                # Handle anything else...
                elsif ($prev_was_verbatim || $next !~ /$ctrl/) {
                    # If so, get the next fake character...
                    if ($faking) {
                        $next = length($local_fake_input)
                                    ? substr($local_fake_input,0,1,q{})
                                    : q{};
                    }

                    # Handle editing...
                    if ($next eq $EDIT{BACK}) {
                        $insert_offset += ($insert_offset < length $input) ? 1 : 0;
                    }
                    elsif ($next eq $EDIT{FORWARD}) {
                        $insert_offset += ($insert_offset > 0) ? -1 : 0;
                    }
                    elsif ($next eq $EDIT{START}) {
                        $insert_offset = length($input);
                    }
                    elsif ($next eq $EDIT{END}) {
                        $insert_offset = 0;
                    }

                    # Handle non-editing...
                    else {
                        # Check for input restrictions...
                        if (exists $opt_ref->{-guarantee}) {
                            next INPUT if ($input.$next) !~ $opt_ref->{-guarantee};
                        }

                        # Add the new input char to the accumulated input string...
                        if ($insert_offset) {
                            substr($input, -$insert_offset, 0) = $next;
                            $prev_insert_offset++;
                        }
                        else {
                            $input .= $next;
                        }
                    }

                    # Display the character (or whatever was specified)...

                    if ($insert_offset || $prev_insert_offset) {
                        my $input_pre  = substr($input,0,length($input)-$prev_insert_offset);
                        my $input_post = substr($input,length($input)-$insert_offset);
                        my $display_pre
                            = join q{}, map { $opt_ref->{-echo}($_) } $input_pre =~ m/\X/g;
                        my $display_post
                            = join q{}, map { $opt_ref->{-echo}($_) } $input_post =~ m/\X/g;
                        $outputter_ref->( -echostyle =>
                              "\b" x length($display_pre)
                            . join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g)
                            . "\b" x length($display_post)
                        );
                    }
                    elsif ($next !~ $EDIT_KEY) {
                        $outputter_ref->(-echostyle => $opt_ref->{-echo}($next));
                    }

                    # Not verbatim after this...
                    $prev_was_verbatim = 0;
                }
                else {
                    # Not verbatim after mysterious ctrl input...
                    $prev_was_verbatim = 0;

                    next INPUT;
                }
            }
            if ($opt_ref->{-single} || !defined $next || $input =~ m{\Q$/\E$}) {
                # Did we get an acceptable value?
                if (defined $next) {
                    _verify_input_constraints(
                       \$input, \$local_fake_input, $outputter_ref,
                       $opt_ref, $extra_constraints,
                    );
                }

                # Reset terminal...
                Term::ReadKey::ReadMode('restore', $in_fh);

                # Return failure if failed before input...
                return undef if !defined $next && length($input) == 0;

                # Otherwise supply a final newline if necessary...
                if ( $opt_ref->{-single}
                &&   exists $opt_ref->{-return}
                &&   $input !~ /\A\R\z/ ) {
                    $outputter_ref->(-echostyle => $opt_ref->{-return}(q{}));
                }

                return $input;
            }
        }
    }
}

# Build a menu...
sub _build_menu {
    my ($source_ref, $initial_prompt, $is_numeric) = @_;
    my $prompt = ($initial_prompt//q{}) . qq{\n};
    my $final = q{};
    my %value_for;
    my %key_for;
    my @selectors;

    given (ref $source_ref) {
        when ('HASH') {
            my @sorted_keys = sort(keys(%{$source_ref}));
            @selectors = $is_numeric ? (1..@sorted_keys) : ('a'..'z','A'..'Z');
            @key_for{@selectors}   = @sorted_keys;
            @value_for{@selectors} = @{$source_ref}{@sorted_keys};
            $source_ref = \@sorted_keys;
            $_ = 'ARRAY';
            continue;
        }
        when ('SCALAR') {
            $source_ref = [ split "\n", ${$source_ref} ];
            $_ = 'ARRAY';
            continue;
        }
        when ('ARRAY') {
            my @source = @{$source_ref};
            @selectors = $is_numeric ? (1..@source) : ('a'..'z','A'..'Z');
            if (!keys %value_for) {
                @value_for{@selectors} = @source;
            }
            ITEM:
            for my $tag (@selectors) {
                my $item = shift(@source) // last ITEM;
                chomp $item;
                $prompt .= sprintf("%4s. $item\n", $tag);
                $final = $tag;
            }
            if (@source) {
                _warn( misc =>
                    "prompt(): Too many menu items. Ignoring the final " . @source
                );
            }
        }
    }

    my $constraint = $is_numeric       ? '(?:' . join('|',@selectors) .')'
                   : $final =~ /[A-Z]/ ? "[a-zA-$final]"
                   :                     "[a-$final]";
    my $constraint_desc = $is_numeric  ? "[1-$selectors[-1]]" : $constraint;
    $constraint = '\A\s*' . $constraint . '\s*\Z';

    return {
        data       => $source_ref,
        key_for    => \%key_for,
        value_for  => \%value_for,
        prompt     => "$prompt\n",
        is_numeric => $is_numeric,
        constraint => { "Enter $constraint_desc: " => qr/$constraint|$MENU_ESC/ },
    };
}

# Vocabulary that _stylize understands...
my %synonyms = (
    bold      => [qw],
    dark      => [qw],
    faint     => [qw],
    underline => [qw],
    blink     => [qw],
    reverse   => [qw],
    concealed => [qw],
    reset     => [qw],
    bright_   => [qw< bright\s+ vivid\s+ >],
    red       => [qw< scarlet vermilion crimson ruby cherry cerise cardinal carmine
                      burgundy claret chestnut copper garnet geranium russet
                      salmon titian coral cochineal rose cinnamon ginger gules >],
    yellow    => [qw< gold golden lemon cadmium daffodil mustard primrose tawny
                      amber aureate canary champagne citrine citron cream goldenrod honey straw >],
    green     => [qw< olive jade pea emerald lime chartreuse forest sage vert >],
    cyan      => [qw< aqua aquamarine teal turquoise ultramarine >],
    blue      => [qw< azure cerulean cobalt indigo navy sapphire >],
    magenta   => [qw< amaranthine amethyst lavender lilac mauve mulberry orchid periwinkle
                      plum pomegranate violet purple aubergine cyclamen fuchsia modena puce
                      purpure >],
    black     => [qw< charcoal ebon ebony jet obsidian onyx raven sable slate >],
    white     => [qw< alabaster ash chalk ivory milk pearl silver argent >],
);

# Back-mapping to standard terms...
my %normalize
    = map { join('|', map { "$_\\b" } reverse sort @{$synonyms{$_}}) => $_ }
          keys %synonyms;

my $BACKGROUND = qr{
     (\S+) \s+ (?: behind | beneath | below | under(?:neath)? )\b
   | \b (?:upon|over|on) \s+ (?:an?)? \s+ (.*?) \s+ (?:background|bg|field) \b
   | \b (?:upon\s+ | over\s+ | (?:(on|upon|over)\s+a\s+)?  (?:background|bg|field) \s+ (?:of\s+|in\s+)? | on\s+) (\S+)
}ixms;

# Convert a description to ANSI colour codes...
sub _stylize {
    my $spec = shift // q{};

    # Handle arrays and hashes as args...
    if (ref($spec) eq 'ARRAY') {
        $spec = join q{ }, @{$spec};
    }
    elsif (ref($spec) eq 'HASH') {
        $spec = join q{ }, keys %{$spec};
    }

    # Ignore punctuation...
    $spec =~ s/[^\w\s]//g;

    # Handle backgrounds...
    $spec =~ s/$BACKGROUND/on_$+/g;

    # Apply standard translations...
    for my $pattern (keys %normalize) {
        $spec =~ s{\b(on_|\b) $pattern}{($1//q{}).$normalize{$pattern}}geixms;
    }

    # Ignore anything unknown...
    $spec =~ s{((?:on_)?(\S+))}{ exists $synonyms{$2} ? $1 : q{} }gxmse;

    # Build ANSI terminal codes around text...
    my $raw_text = join q{}, @_;
    my ($prews, $text, $postws) = $raw_text =~ m{\A (\s*) (.*?) (\s*) \Z}xms;
    my @style = split /\s+/, $spec;
    return $prews
         . ( @style ? Term::ANSIColor::colored(\@style, $text) : $text )
         . $postws;
}

# Build a subroutine that prints printable chars to the specified filehandle...
sub _std_printer_to {
    my ($out_filehandle, $opt_ref) = @_;
    no strict 'refs';
    _autoflush($out_filehandle);
    if (eval { require Term::ANSIColor}) {
        return sub {
            my $style = shift;
            my @loc = (@_);
            s{\e}{^}gxms for @loc;
            print {$out_filehandle} _stylize($opt_ref->{$style}(@loc), @loc);
        };
    }
    else {
        return sub {
            shift; # ...ignore style
            my @loc = (@_);
            s{\e}{^}gxms for @loc;
            print {$out_filehandle} @loc;
        };
    }
}

# Build a subroutine that prints to nowhere...
sub _null_printer {
    return sub {};
}

1; # Magic true value required at end of module
__END__