File Coverage

blib/lib/IO/Prompter.pm

Criterion	Covered	Total	%
statement	430	847	50.7
branch	234	548	42.7
condition	110	310	35.4
subroutine	52	82	63.4
pod	1	1	100.0
total	827	1788	46.2

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 >;
use match::smart qw< match >;

our $VERSION = '0.005004';

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->(-noindent, -nostyle => "\n" x 1000);
    }

    # Handle menu structures...
    my $input;
    eval {
        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->(-indent, -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...
                (my $submenu_name = $menu[-1]{key_for}{$tag}) =~ s{\A(?:[\cA-\cZ]|\\c[a-zA-Z])\h*}{};
                push @menu,
                    _build_menu($input,
                                "Select from $submenu_name: ",
                                $opt_ref->{-number} || $opt_ref->{-integer}
                    );
                $menu[-1]{prompt} .= '> ';
            }
        }

        # Otherwise, simply ask and ye shall receive...
        else {
                $outputter_ref->(-indent, -style => $opt_ref->{-prompt});
                $input = $inputter_ref->();
        }
        1;
    }
    // do {
        # Supply the missing newline if requested...
        $outputter_ref->(-noindent, -echostyle => $opt_ref->{-return}(q{}))
            if exists $opt_ref->{-return};

        # Rethrow any other exception...
        my $error = $@;
        die $@ unless ref($error) eq 'IO::Prompter::Cancellation';

        # Return failure on cancellation...
        return if $opt_ref->{-verbatim};
        return PUREBOOL { 0 }
                   BOOL { 0 }
                 SCALAR { ${$error}  }
                 METHOD { defaulted => sub { 0 }, timedout  => sub { 0 } };
    };

    # Provide default value if available and necessary...
    my $defaulted = 0;
    { no warnings 'uninitialized';
        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}   && match($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') {
        no warnings 'uninitialized';
        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.', qq{"$_"})
            } @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" },
        -indent    => q{},
    );

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

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

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

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

            elsif ($arg =~ /^-a/) {
                $option{-argv} = 1;
                $redo = 1;
            }

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

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

            # Specify an immediate failure condition...
            elsif ($arg =~ /^-cancel/) {
                _opt_err('Missing', -cancel, 'cancellation condition') if !@_;
                $option{-cancel} = shift @_;
            }

            # Specify a file request...
            elsif ($arg =~ /^-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...
            elsif ($arg =~ /^-style/) {
                _opt_err('Missing -style specification') if !@_;
                my $style = _decode_style(shift @_);
                $option{-style} = _gen_wrapper_for($style);
            }

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

            # Specify an indent at the start of each line...
            elsif ($arg =~ /^-indent/) {
                my $indent = shift(@_) // q{};
                $indent = q{ } x $indent if looks_like_number($indent);
                $indent =~ s/\v+//g;
                $option{-indent} = $indent;
            }

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


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

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

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

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

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

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

            # Specify a set of input constraints...
            elsif ($arg =~ /^-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...
            elsif ($arg =~ '-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;

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

            # Specify a set of return constraints...
            elsif ($arg =~ /^-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...
            elsif ($arg =~ /^-history/) {
                $option{-history}
                    = @_ && $_[0] !~ /^-/ ? shift @_
                    :                       undef;
                _opt_err('Invalid', -history, 'history set name', qq{'$option{-history}'})
                    if ref($option{-history});
            }
            elsif ($arg =~ /^-h(.*)/)   { $option{-history} = length($1) ? $1 : undef; }

            # Specify completions...
            elsif ($arg =~ /^-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...
            elsif ($arg =~ /^-(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));
            }
            elsif ($arg =~ /^-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));
            }
            elsif ($arg =~ /^-r(.+)/) {
                my $arg = $1;
                $option{-return} = _gen_wrapper_for(_decode_echo($arg));
            }
            elsif ($arg =~ /^-r/) {
                $option{-return} = sub{ "\n" };
            }

            # Specify an initial input...
            elsif ($arg =~ /^-prefill/) {
                _opt_err('Missing', '-prefill', 'string') if !@_;
                $option{-prefill} = shift @_;
                _opt_err('Invalid', '-prefill', 'string', 'reference')
                    if ref($option{-prefill});
            }

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

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

            # A monitoring sub is called on every input character...
            elsif ($arg =~ /^-monitor/) {
                _opt_err('Missing', '-monitor', 'a monitor subref')
                    if !@_ || ref $_[0] ne 'CODE';
                $option{-monitor} = shift(@_);
            }

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

            # Anything else is part fo the prompt...
            else { $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, $found) = @_;
    if (@_ > 3) {
        Carp::croak "prompt(): $problem value for $option (expected $expectation, but found $found)";
    }
    else {
        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; match($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->(-indent, -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->(-noindent, -echostyle => $opt_ref->{-echo}($_));
                    }
                    readline $in_fh;

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

                if (exists $opt_ref->{-cancel}) {
                    for my $nextchar (split q{}, $input) {
                        die bless \$input, 'IO::Prompter::Cancellation'
                            if match($nextchar, $opt_ref->{-cancel});
                    }
                }

                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;
    for my $completer_type (ref($completer) || $completer // q{}) {
        # If completer is sub, recursively call it with input words...
        if ($completer_type eq '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...
        elsif ($completer_type eq 'ARRAY') {
            @candidates = grep { /\A\Q$lastword\E/ } @{$completer};
        }

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

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

        # If completer is 'dir...', glob up the appropriate directories...
        elsif ($completer_type eq /^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 { return if defined $prev_SIGINT && $prev_SIGINT eq 'IGNORE';
                                Term::ReadKey::ReadMode('restore', $in_fh);
                                exit(1) if !defined $prev_SIGINT
                                        || $prev_SIGINT eq '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 = exists $opt_ref->{-prefill} ? $opt_ref->{-prefill} : q{};
        if (exists $opt_ref->{-prefill}) {
            if (exists $opt_ref->{-monitor}) {
                my %opts = ( -cursor_pos => length($input),
                             -prompt     => $opt_ref->{-prompt},
                             -style      => $opt_ref->{-style}->(),
                             -echostyle  => $opt_ref->{-echostyle}->(),
                        );
                my $input_copy = $input;
                eval { $opt_ref->{-monitor}->($input_copy, \%opts) };
            }
            $outputter_ref->( -indent, -style => $opt_ref->{-style}, _wipe_line(), $opt_ref->{-prompt});
            $outputter_ref->( -noindent, -echostyle => join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g) );
        }

        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);

            # Check for cancellation...
            if (exists $opt_ref->{-cancel} && match($next, $opt_ref->{-cancel})) {
                Term::ReadKey::ReadMode('restore', $in_fh);
                die bless \$input, 'IO::Prompter::Cancellation';
            }

            # 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->( -indent,
                            -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->( -noindent, -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->( -noindent, -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->(-noindent, -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 (match($def_val, $opt_ref->{-menu_curr_level}{$key})) {
                                    $def_val = $key;
                                    last;
                                }
                            }
                        }

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

                    # Echo the return (or otherwise, as specified)...
                    $outputter_ref->(-noindent, -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->(-noindent,  -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->(-noindent, -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 or cancelled...
                if (!defined $next && length($input) == 0
                ||  exists $opt_ref->{-cancel} && match($next, $opt_ref->{-cancel})) {
                    return if $opt_ref->{-verbatim};
                    return PUREBOOL { 0 }
                               BOOL { 0 }
                               SCALAR { undef  }
                               METHOD { defaulted => sub { 0 }, timedout  => sub { 0 } };
                }

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

                return $input;
            }
        }
        continue {
            # Perform monitor (if any) and redraw prompt (if required)...
            if ($opt_ref->{-monitor}) {
                my %opts = ( -cursor_pos => length($input) - $insert_offset,
                             -prompt     => $opt_ref->{-prompt},
                             -style      => $opt_ref->{-style}->(),
                             -echostyle  => $opt_ref->{-echostyle}->(),
                        );
                my $input_copy = $input;
                my $output_pos = $outputter_ref->(-tell);
                if (!defined eval { $opt_ref->{-monitor}->($input_copy, \%opts) }
                ||  $output_pos != $outputter_ref->(-tell)) {
                    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->(-indent,  -style => $opt_ref->{-style}, _wipe_line(), $opt_ref->{-prompt});
                    $outputter_ref->(-noindent,  -echostyle =>
                                    join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g)
                                    . "\b" x (length($display_post)-1)
                    );
                }
            }
        }
    }
}

# 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;

    my $source_type = ref $source_ref;
    if ($source_type eq '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;
    }
    elsif ($source_type eq 'SCALAR') {
        $source_ref = [ split "\n", ${$source_ref} ];
    }

    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) =~s{\A(?:[\cA-\cZ]|\\c[a-zA-Z])\h*|\s*\z}{}g;
        $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],
    italic    => [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_)?(?:(ansi\d+|rgb\d+)|(\S+)))}{ $2 || exists $synonyms{$3} ? $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';
    my $indent = $opt_ref->{-indent};
    _autoflush($out_filehandle);
    if (eval { require Term::ANSIColor}) {
        return sub {
            my ($indent_mode, $style, @loc) = @_;
            return tell($out_filehandle) if $style eq -tell;
            s{\e}{^}gxms for @loc;
            if ($indent_mode eq -indent) { s{^}{$indent}gxms for @loc; }
            print {$out_filehandle} _stylize($opt_ref->{$style}(@loc), @loc);
        };
    }
    else {
        return sub {
            my ($indent_mode, $style, @loc) = @_;
            return tell($out_filehandle) if $style eq -tell;
            s{\e}{^}gxms for @loc;
            if ($indent_mode eq -indent) { s{^}{$indent}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__